From 417161dbb36323b5a6572859dedad02ca92fc65c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 16:22:43 -0800 Subject: altos/lisp: Clean up OS integration bits, add defun Provide an abstraction for the OS interface so that it can build more cleanly on Linux and AltOS. Add defun macro. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_lambda.c | 188 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 188 insertions(+) create mode 100644 src/lisp/ao_lisp_lambda.c (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c new file mode 100644 index 00000000..cc5af4bc --- /dev/null +++ b/src/lisp/ao_lisp_lambda.c @@ -0,0 +1,188 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#define DBG_EVAL 0 +#include "ao_lisp.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_lambda); +} + +void +lambda_mark(void *addr) +{ + struct ao_lisp_lambda *lambda = addr; + + ao_lisp_poly_mark(lambda->code, 0); + ao_lisp_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ + struct ao_lisp_lambda *lambda = addr; + + ao_lisp_poly_move(&lambda->code, 0); + ao_lisp_poly_move(&lambda->frame, 0); +} + +const struct ao_lisp_type ao_lisp_lambda_type = { + .size = lambda_size, + .mark = lambda_mark, + .move = lambda_move, +}; + +static int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} + +void +ao_lisp_lambda_print(ao_poly poly) +{ + struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); + struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); + + printf("("); + printf("%s", ao_lisp_args_name(lambda->args)); + while (cons) { + printf(" "); + ao_lisp_poly_print(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) +{ + struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + struct ao_lisp_cons *arg; + int f; + + if (!lambda) + return AO_LISP_NIL; + + if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, code, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + f = 0; + arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + while (arg) { + if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); + arg = ao_lisp_poly_cons(arg->cdr); + f++; + } + + lambda->type = AO_LISP_LAMBDA; + lambda->args = args; + lambda->code = ao_lisp_cons_poly(code); + lambda->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); + DBG_STACK(); + return ao_lisp_lambda_poly(lambda); +} + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); +} + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); +} + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); +} + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); +} + +ao_poly +ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, + struct ao_lisp_cons *cons) +{ + struct ao_lisp_cons *code; + struct ao_lisp_cons *args; + struct ao_lisp_frame *next_frame; + int args_wanted; + int args_provided; + + code = ao_lisp_poly_cons(lambda->code); + DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); + args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + if (lambda->args == AO_LISP_FUNC_LAMBDA) + args_provided = ao_lisp_cons_length(cons) - 1; + else + args_provided = 1; + if (args_wanted != args_provided) + return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + next_frame = ao_lisp_frame_new(args_wanted); + switch (lambda->args) { + case AO_LISP_FUNC_LAMBDA: { + int f; + struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); + + for (f = 0; f < args_wanted; f++) { + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = vals->car; + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + break; + } + case AO_LISP_FUNC_LEXPR: + case AO_LISP_FUNC_NLAMBDA: + case AO_LISP_FUNC_MACRO: + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(cons->cdr); DBG("\n"); + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = cons->cdr; + break; + } + next_frame->next = lambda->frame; + DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); + ao_lisp_frame_current = next_frame; + ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBG_STACK(); + return ao_lisp_arg(code, 1); +} -- cgit v1.2.3 From 7da6bfc195fad97e3afc576c609897c131fd4d8c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 10 Nov 2016 23:29:21 -0800 Subject: altos/lisp: Deal with memory compation in the middle of operations Handle memory compaction in places where we've got pointers into the heap across an allocation operation. Either re-compute the values from managed global references or add new roots across the allocation. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 7 +-- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_cons.c | 8 ++- src/lisp/ao_lisp_eval.c | 59 +++++------------- src/lisp/ao_lisp_frame.c | 28 ++++++--- src/lisp/ao_lisp_lambda.c | 19 ++++-- src/lisp/ao_lisp_mem.c | 149 ++++++++++++++++++++++++---------------------- 7 files changed, 137 insertions(+), 135 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 6122a2ed..60a97f2c 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -510,8 +510,8 @@ ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num); -struct ao_lisp_frame * -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); +int +ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); void ao_lisp_frame_print(ao_poly p); @@ -538,8 +538,7 @@ ao_poly ao_lisp_macro(struct ao_lisp_cons *cons); ao_poly -ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, - struct ao_lisp_cons *cons); +ao_lisp_lambda_eval(void); /* error */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 5c6d5a67..efa4f621 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -147,7 +147,7 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val) if (ref) *ref = val; else - ao_lisp_frame_global = ao_lisp_frame_add(ao_lisp_frame_global, atom, val); + ao_lisp_frame_add(&ao_lisp_frame_global, atom, val); return val; } diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 855079b8..cd8a8d1d 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -67,7 +67,13 @@ const struct ao_lisp_type ao_lisp_cons_type = { struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { - struct ao_lisp_cons *cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + struct ao_lisp_cons *cons; + + ao_lisp_root_add(&ao_lisp_cons_type, &cdr); + ao_lisp_root_poly_add(&car); + cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + ao_lisp_root_clear(&car); + ao_lisp_root_clear(&cdr); if (!cons) return NULL; cons->car = car; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index c5addcb0..ae2436b8 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,7 @@ * General Public License for more details. */ -#define DBG_EVAL 1 +#define DBG_EVAL 0 #include "ao_lisp.h" #include @@ -46,19 +46,20 @@ stack_move(void *addr) struct ao_lisp_stack *stack = addr; while (stack) { - void *prev; + struct ao_lisp_stack *prev; int ret; (void) ao_lisp_poly_move(&stack->sexprs, 0); (void) ao_lisp_poly_move(&stack->values, 0); (void) ao_lisp_poly_move(&stack->values_tail, 0); (void) ao_lisp_poly_move(&stack->frame, 0); prev = ao_lisp_poly_stack(stack->prev); - ret = ao_lisp_move(&ao_lisp_stack_type, &prev); + ret = ao_lisp_move_memory((void **) &prev, + sizeof (struct ao_lisp_stack)); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); if (ret) break; - stack = ao_lisp_poly_stack(stack->prev); + stack = prev; } } @@ -101,8 +102,8 @@ ao_lisp_stack_push(void) ao_lisp_stack = stack; ao_lisp_stack_reset(stack); DBGI("stack push\n"); - DBG_IN(); DBG_FRAMES(); + DBG_IN(); return 1; } @@ -236,37 +237,11 @@ static int ao_lisp_eval_val(void) { DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); -#if 0 - if (ao_lisp_stack->macro) { - DBGI(".. end macro %d\n", ao_lisp_stack->macro); - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - ao_lisp_frames_dump(); - - ao_lisp_stack_pop(); -#if 0 - /* - * Re-use the current stack to evaluate - * the value from the macro - */ - ao_lisp_stack->state = eval_sexpr; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->macro_frame); - ao_lisp_stack->frame = ao_lisp_stack->macro_frame; - ao_lisp_stack->macro = 0; - ao_lisp_stack->macro_frame = AO_LISP_NIL; - ao_lisp_stack->sexprs = AO_LISP_NIL; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; -#endif - } else -#endif - { - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_lisp_stack_pop(); - } + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_lisp_stack_pop(); DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); return 1; } @@ -305,7 +280,6 @@ ao_lisp_eval_formal(void) break; case AO_LISP_FUNC_MACRO: /* Evaluate the result once more */ - prev = ao_lisp_stack; ao_lisp_stack->state = eval_sexpr; if (!ao_lisp_stack_push()) return 0; @@ -313,6 +287,7 @@ ao_lisp_eval_formal(void) /* After the function returns, take that * value and re-evaluate it */ + prev = ao_lisp_poly_stack(ao_lisp_stack->prev); ao_lisp_stack->state = eval_sexpr; ao_lisp_stack->sexprs = prev->sexprs; prev->sexprs = AO_LISP_NIL; @@ -400,8 +375,7 @@ ao_lisp_eval_exec(void) case AO_LISP_LAMBDA: ao_lisp_stack->state = eval_sexpr; DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_v = ao_lisp_lambda_eval(ao_lisp_poly_lambda(ao_lisp_v), - ao_lisp_poly_cons(ao_lisp_stack->values)); + ao_lisp_v = ao_lisp_lambda_eval(); DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; @@ -464,12 +438,11 @@ ao_lisp_eval_cond_test(void) struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); - ao_lisp_stack->state = eval_val; if (c) { + ao_lisp_stack->state = eval_sexpr; ao_lisp_v = c->car; - if (!ao_lisp_stack_push()) - return 0; - } + } else + ao_lisp_stack->state = eval_val; } else { ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 7978f20a..90344719 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -174,8 +174,9 @@ ao_lisp_frame_new(int num) } static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) +ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) { + struct ao_lisp_frame *frame = *frame_ref; struct ao_lisp_frame *new; int copy; @@ -184,34 +185,45 @@ ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) new = ao_lisp_frame_new(new_num); if (!new) return NULL; + /* + * Re-fetch the frame as it may have moved + * during the allocation + */ + frame = *frame_ref; copy = new_num; if (copy > frame->num) copy = frame->num; memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); - if (frame) - new->next = frame->next; + new->next = frame->next; return new; } -struct ao_lisp_frame * -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +int +ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) { + struct ao_lisp_frame *frame = *frame_ref; ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; + if (!ref) { int f; + ao_lisp_root_poly_add(&atom); + ao_lisp_root_poly_add(&val); if (frame) { f = frame->num; - frame = ao_lisp_frame_realloc(frame, f + 1); + frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; frame = ao_lisp_frame_new(1); } + ao_lisp_root_clear(&atom); + ao_lisp_root_clear(&val); if (!frame) - return NULL; + return 0; + *frame_ref = frame; DBG ("add atom %s %d, val %d at %d\n", ao_lisp_poly_atom(atom)->name, OFFSET(atom), OFFSET(val), f); frame->vals[f].atom = atom; ref = &frame->vals[f].val; } *ref = val; - return frame; + return 1; } diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index cc5af4bc..8eafb187 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -133,18 +133,17 @@ ao_lisp_macro(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, - struct ao_lisp_cons *cons) +ao_lisp_lambda_eval(void) { - struct ao_lisp_cons *code; - struct ao_lisp_cons *args; + struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); + struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); struct ao_lisp_frame *next_frame; int args_wanted; int args_provided; - code = ao_lisp_poly_cons(lambda->code); DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); args_wanted = ao_lisp_cons_length(args); @@ -156,7 +155,15 @@ ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, args_provided = 1; if (args_wanted != args_provided) return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + next_frame = ao_lisp_frame_new(args_wanted); + + /* Re-fetch all of the values in case something moved */ + lambda = ao_lisp_poly_lambda(ao_lisp_v); + cons = ao_lisp_poly_cons(ao_lisp_stack->values); + code = ao_lisp_poly_cons(lambda->code); + args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + switch (lambda->args) { case AO_LISP_FUNC_LAMBDA: { int f; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 66e09db0..b763d78b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -28,32 +28,33 @@ uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); #endif #if 0 -#define DBG_COLLECT_ALWAYS +#define MDBG_COLLECT_ALWAYS #endif #if 0 -#define DBG_POOL +#define MDBG_POOL #endif #if 0 -#define DBG_INCLUDE -#define DBG_DUMP 0 -#define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) -#define DBG(...) printf(__VA_ARGS__) -#define DBG_DO(a) a -static int move_dump = 1; +#define MDBG_INCLUDE +#define MDBG_DUMP 1 +#define MDBG_MOVE 0 +#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) +#define MDBG(...) printf(__VA_ARGS__) +#define MDBG_DO(a) a +static int move_dump = MDBG_MOVE; static int move_depth; -#define DBG_RESET() (move_depth = 0) -#define DBG_MOVE(...) do { if(move_dump) { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) -#define DBG_MOVE_IN() (move_depth++) -#define DBG_MOVE_OUT() (move_depth--) +#define MDBG_RESET() (move_depth = 0) +#define MDBG_MOVE(...) do { if(move_dump) { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MOVE_IN() (move_depth++) +#define MDBG_MOVE_OUT() (move_depth--) #else -#define DBG(...) -#define DBG_DO(a) -#define DBG_RESET() -#define DBG_MOVE(...) -#define DBG_MOVE_IN() -#define DBG_MOVE_OUT() +#define MDBG(...) +#define MDBG_DO(a) +#define MDBG_RESET() +#define MDBG_MOVE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() #endif uint8_t ao_lisp_exception; @@ -69,7 +70,7 @@ static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; static uint8_t ao_lisp_busy[AO_LISP_POOL / 32]; static uint8_t ao_lisp_moving[AO_LISP_POOL / 32]; -static uint8_t ao_lisp_cons[AO_LISP_POOL / 32]; +static uint8_t ao_lisp_cons_note[AO_LISP_POOL / 32]; static uint8_t ao_lisp_cons_last[AO_LISP_POOL / 32]; static uint8_t ao_lisp_cons_noted; @@ -78,6 +79,7 @@ uint16_t ao_lisp_top; static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; + tag[byte] |= (1 << bit); } @@ -166,10 +168,11 @@ busy_object(uint8_t *tag, void *addr) { static void note_cons(void *addr) { - DBG_MOVE("note cons %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("note cons %d\n", MDBG_OFFSET(addr)); if (AO_LISP_IS_POOL(addr)) { + int offset = (uint8_t *) addr - ao_lisp_pool; ao_lisp_cons_noted = 1; - mark(ao_lisp_cons, (uint8_t *) addr - ao_lisp_pool); + mark(ao_lisp_cons_note, offset); } } @@ -182,11 +185,11 @@ move_object(void) { int i; - DBG_RESET(); - DBG_MOVE("move %d -> %d\n", DBG_OFFSET(move_old), DBG_OFFSET(move_new)); - DBG_MOVE_IN(); + MDBG_RESET(); + MDBG_MOVE("move %d -> %d\n", MDBG_OFFSET(move_old), MDBG_OFFSET(move_new)); + MDBG_MOVE_IN(); memset(ao_lisp_moving, '\0', sizeof (ao_lisp_moving)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_ROOT; i++) { if (!ao_lisp_root[i].addr) @@ -195,10 +198,10 @@ move_object(void) void *addr = *ao_lisp_root[i].addr; if (!addr) continue; - DBG_MOVE("root %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("root %d\n", MDBG_OFFSET(addr)); if (!ao_lisp_move(ao_lisp_root[i].type, ao_lisp_root[i].addr)) { - DBG_MOVE("root moves from %p to %p\n", + MDBG_MOVE("root moves from %p to %p\n", addr, *ao_lisp_root[i].addr); } @@ -207,31 +210,31 @@ move_object(void) if (!p) continue; if (!ao_lisp_poly_move((ao_poly *) ao_lisp_root[i].addr, 0)) { - DBG_MOVE("root poly move from %04x to %04x\n", + MDBG_MOVE("root poly move from %04x to %04x\n", p, *(ao_poly *) ao_lisp_root[i].addr); } } } while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons, sizeof (ao_lisp_cons)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_POOL; i += 4) { if (busy(ao_lisp_cons_last, i)) { void *addr = ao_lisp_pool + i; - DBG_MOVE("cons %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("cons %d\n", MDBG_OFFSET(addr)); if (!ao_lisp_move(&ao_lisp_cons_type, &addr)) { - DBG_MOVE("cons moves from %p to %p\n", + MDBG_MOVE("cons moves from %p to %p\n", ao_lisp_pool + i, addr); } } } } - DBG_MOVE_OUT(); - DBG_MOVE("move done\n"); + MDBG_MOVE_OUT(); + MDBG_MOVE("move done\n"); } -#if DBG_DUMP +#if MDBG_DUMP static void dump_busy(void) { @@ -272,32 +275,32 @@ ao_lisp_mark_busy(void) int i; memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; - DBG("mark\n"); + MDBG("mark\n"); for (i = 0; i < AO_LISP_ROOT; i++) { if (ao_lisp_root[i].type) { void **a = ao_lisp_root[i].addr, *v; if (a && (v = *a)) { - DBG("root %d\n", DBG_OFFSET(v)); + MDBG("root %d\n", MDBG_OFFSET(v)); ao_lisp_mark(ao_lisp_root[i].type, v); } } else { ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; if (a && (p = *a)) { - DBG("root 0x%04x\n", p); + MDBG("root 0x%04x\n", p); ao_lisp_poly_mark(p, 0); } } } while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons, sizeof (ao_lisp_cons)); - memset(ao_lisp_cons, '\0', sizeof (ao_lisp_cons)); + memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); + memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_POOL; i += 4) { if (busy(ao_lisp_cons_last, i)) { void *v = ao_lisp_pool + i; - DBG("cons %d\n", DBG_OFFSET(v)); + MDBG("cons %d\n", MDBG_OFFSET(v)); ao_lisp_mark(&ao_lisp_cons_type, v); } } @@ -310,13 +313,13 @@ ao_lisp_collect(void) int i; int top; - DBG("collect\n"); + MDBG("collect\n"); /* Mark */ ao_lisp_mark_busy(); DUMP_BUSY(); /* Compact */ - DBG("find first busy\n"); + MDBG("find first busy\n"); for (i = 0; i < ao_lisp_top; i += 4) { if (!busy(ao_lisp_busy, i)) break; @@ -324,23 +327,25 @@ ao_lisp_collect(void) top = i; while(i < ao_lisp_top) { if (busy(ao_lisp_busy, i)) { - DBG("busy %d -> %d\n", i, top); + MDBG("busy %d -> %d\n", i, top); move_old = &ao_lisp_pool[i]; move_new = &ao_lisp_pool[top]; move_size = 0; move_object(); - DBG("\tbusy size %d\n", move_size); + MDBG("\tbusy size %d\n", move_size); if (move_size == 0) ao_lisp_abort(); clear_object(ao_lisp_busy, move_old, move_size); mark_object(ao_lisp_busy, move_new, move_size); - if (busy_object(ao_lisp_cons, move_old)) { - clear_object(ao_lisp_cons, move_old, move_size); - mark_object(ao_lisp_cons, move_new, move_size); + if (busy_object(ao_lisp_cons_note, move_old)) { + clear_object(ao_lisp_cons_note, move_old, move_size); + mark_object(ao_lisp_cons_note, move_new, move_size); } i += move_size; top += move_size; +#if MDBG_MOVE DUMP_BUSY(); +#endif } else { i += 4; } @@ -404,9 +409,9 @@ static void * check_move(void *addr, int size) { if (addr == move_old) { - DBG_MOVE("mapping %d -> %d\n", DBG_OFFSET(addr), DBG_OFFSET(move_new)); + MDBG_MOVE("mapping %d -> %d\n", MDBG_OFFSET(addr), MDBG_OFFSET(move_new)); if (!busy_object(ao_lisp_moving, addr)) { - DBG_MOVE(" copy %d\n", size); + MDBG_MOVE(" copy %d\n", size); memmove(move_new, move_old, size); move_size = (size + 3) & ~3; } @@ -429,24 +434,24 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) if (AO_LISP_IS_CONST(addr)) return 1; #endif - DBG_MOVE("object %d\n", DBG_OFFSET(addr)); + MDBG_MOVE("object %d\n", MDBG_OFFSET(addr)); if (!AO_LISP_IS_POOL(a)) ao_lisp_abort(); - DBG_MOVE_IN(); + MDBG_MOVE_IN(); addr = check_move(addr, size); if (addr != *ref) *ref = addr; if (mark_object(ao_lisp_moving, addr, size)) { - DBG_MOVE("already moved\n"); - DBG_MOVE_OUT(); + MDBG_MOVE("already moved\n"); + MDBG_MOVE_OUT(); return 1; } - DBG_MOVE_OUT(); - DBG_MOVE("recursing...\n"); - DBG_MOVE_IN(); + MDBG_MOVE_OUT(); + MDBG_MOVE("recursing...\n"); + MDBG_MOVE_IN(); type->move(addr); - DBG_MOVE_OUT(); - DBG_MOVE("done %d\n", DBG_OFFSET(addr)); + MDBG_MOVE_OUT(); + MDBG_MOVE("done %d\n", MDBG_OFFSET(addr)); return 0; } @@ -457,17 +462,17 @@ ao_lisp_move_memory(void **ref, int size) if (!addr) return 1; - DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); - DBG_MOVE_IN(); + MDBG_MOVE("memory %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); addr = check_move(addr, size); if (addr != *ref) *ref = addr; if (mark_object(ao_lisp_moving, addr, size)) { - DBG_MOVE("already moved\n"); - DBG_MOVE_OUT(); + MDBG_MOVE("already moved\n"); + MDBG_MOVE_OUT(); return 1; } - DBG_MOVE_OUT(); + MDBG_MOVE_OUT(); return 0; } @@ -505,14 +510,14 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) if (addr != ao_lisp_ref(p)) { ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); - DBG("poly %d moved %04x -> %04x\n", + MDBG("poly %d moved %04x -> %04x\n", type, p, np); *ref = np; } return ret; } -#ifdef DBG_POOL +#ifdef MDBG_POOL static int AO_LISP_POOL_CUR = AO_LISP_POOL / 8; static void @@ -557,18 +562,18 @@ ao_lisp_alloc(int size) void *addr; size = ao_lisp_mem_round(size); -#ifdef DBG_COLLECT_ALWAYS +#ifdef MDBG_COLLECT_ALWAYS ao_lisp_collect(); #endif if (ao_lisp_top + size > AO_LISP_POOL_CUR) { -#ifdef DBG_POOL +#ifdef MDBG_POOL if (AO_LISP_POOL_CUR < AO_LISP_POOL) { AO_LISP_POOL_CUR += AO_LISP_POOL / 8; ao_lisp_poison(); } else #endif ao_lisp_collect(); -#ifdef DBG_POOL +#ifdef MDBG_POOL { int i; @@ -580,7 +585,7 @@ ao_lisp_alloc(int size) #endif if (ao_lisp_top + size > AO_LISP_POOL) { - ao_lisp_exception |= AO_LISP_OOM; + ao_lisp_error(AO_LISP_OOM, "out of memory"); return NULL; } } @@ -593,7 +598,7 @@ int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) { int i; - DBG("add root type %p addr %p\n", type, addr); + MDBG("add root type %p addr %p\n", type, addr); for (i = 0; i < AO_LISP_ROOT; i++) { if (!ao_lisp_root[i].addr) { ao_lisp_root[i].addr = addr; -- cgit v1.2.3 From 7f7e2431f5d1f7c1782ed6e774ccfc70fb4c87cf Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 11 Nov 2016 00:28:31 -0800 Subject: altos/lisp: add length, pack, unpack and flush lots more builtins Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lisp_os.h | 6 +++++ src/lisp/ao_lisp.h | 17 ++++++++++++++ src/lisp/ao_lisp_builtin.c | 47 +++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_cons.c | 11 +++++++++ src/lisp/ao_lisp_lambda.c | 11 --------- src/lisp/ao_lisp_make_const.c | 4 ++++ src/lisp/ao_lisp_os.h | 5 ++++ src/lisp/ao_lisp_string.c | 52 +++++++++++++++++++++++++++++++++++++---- src/test/ao_lisp_os.h | 5 ++++ 9 files changed, 142 insertions(+), 16 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lambdakey-v1.0/ao_lisp_os.h b/src/lambdakey-v1.0/ao_lisp_os.h index df158f6a..1993ac44 100644 --- a/src/lambdakey-v1.0/ao_lisp_os.h +++ b/src/lambdakey-v1.0/ao_lisp_os.h @@ -35,6 +35,12 @@ ao_lisp_getc() { return c; } +static inline void +ao_lisp_os_flush(void) +{ + flush(); +} + static inline void ao_lisp_abort(void) { diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 60a97f2c..86a5ddcf 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -36,10 +36,14 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_cdr _atom("cdr") #define _ao_lisp_atom_cons _atom("cons") #define _ao_lisp_atom_last _atom("last") +#define _ao_lisp_atom_length _atom("length") #define _ao_lisp_atom_cond _atom("cond") #define _ao_lisp_atom_lambda _atom("lambda") #define _ao_lisp_atom_led _atom("led") #define _ao_lisp_atom_delay _atom("delay") +#define _ao_lisp_atom_pack _atom("pack") +#define _ao_lisp_atom_unpack _atom("unpack") +#define _ao_lisp_atom_flush _atom("flush") #define _ao_lisp_atom_eval _atom("eval") #define _ao_lisp_atom_read _atom("read") #define _ao_lisp_atom_eof _atom("eof") @@ -215,6 +219,7 @@ enum ao_lisp_builtin_id { builtin_cdr, builtin_cons, builtin_last, + builtin_length, builtin_quote, builtin_set, builtin_setq, @@ -233,6 +238,9 @@ enum ao_lisp_builtin_id { builtin_greater, builtin_less_equal, builtin_greater_equal, + builtin_pack, + builtin_unpack, + builtin_flush, builtin_delay, builtin_led, _builtin_last @@ -409,6 +417,9 @@ ao_lisp_cons_print(ao_poly); void ao_lisp_cons_patom(ao_poly); +int +ao_lisp_cons_length(struct ao_lisp_cons *cons); + /* string */ extern const struct ao_lisp_type ao_lisp_string_type; @@ -421,6 +432,12 @@ ao_lisp_string_copy(char *a); char * ao_lisp_string_cat(char *a, char *b); +ao_poly +ao_lisp_string_pack(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_string_unpack(char *a); + void ao_lisp_string_print(ao_poly s); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 57d9ee10..30631980 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -58,6 +58,7 @@ static const ao_poly builtin_names[] = { [builtin_cdr] = _ao_lisp_atom_cdr, [builtin_cons] = _ao_lisp_atom_cons, [builtin_last] = _ao_lisp_atom_last, + [builtin_length] = _ao_lisp_atom_length, [builtin_quote] = _ao_lisp_atom_quote, [builtin_set] = _ao_lisp_atom_set, [builtin_setq] = _ao_lisp_atom_setq, @@ -76,6 +77,9 @@ static const ao_poly builtin_names[] = { [builtin_greater] = _ao_lisp_atom_3e, [builtin_less_equal] = _ao_lisp_atom_3c3d, [builtin_greater_equal] = _ao_lisp_atom_3e3d, + [builtin_pack] = _ao_lisp_atom_pack, + [builtin_unpack] = _ao_lisp_atom_unpack, + [builtin_flush] = _ao_lisp_atom_flush, [builtin_delay] = _ao_lisp_atom_delay, [builtin_led] = _ao_lisp_atom_led, }; @@ -200,6 +204,16 @@ ao_lisp_last(struct ao_lisp_cons *cons) return AO_LISP_NIL; } +ao_poly +ao_lisp_length(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); +} + ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { @@ -470,6 +484,35 @@ ao_lisp_greater_equal(struct ao_lisp_cons *cons) return ao_lisp_compare(cons, builtin_greater_equal); } +ao_poly +ao_lisp_pack(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); +} + +ao_poly +ao_lisp_unpack(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) + return AO_LISP_NIL; + return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); +} + +ao_poly +ao_lisp_flush(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) + return AO_LISP_NIL; + ao_lisp_os_flush(); + return _ao_lisp_atom_t; +} + ao_poly ao_lisp_led(struct ao_lisp_cons *cons) { @@ -524,6 +567,7 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, [builtin_last] = ao_lisp_last, + [builtin_length] = ao_lisp_length, [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, @@ -542,6 +586,9 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_greater] = ao_lisp_greater, [builtin_less_equal] = ao_lisp_less_equal, [builtin_greater_equal] = ao_lisp_greater_equal, + [builtin_pack] = ao_lisp_pack, + [builtin_unpack] = ao_lisp_unpack, + [builtin_flush] = ao_lisp_flush, [builtin_led] = ao_lisp_led, [builtin_delay] = ao_lisp_delay, }; diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index cd8a8d1d..b75ffaa0 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -107,3 +107,14 @@ ao_lisp_cons_patom(ao_poly c) cons = ao_lisp_poly_cons(cons->cdr); } } + +int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 8eafb187..c53a38fd 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -49,17 +49,6 @@ const struct ao_lisp_type ao_lisp_lambda_type = { .move = lambda_move, }; -static int -ao_lisp_cons_length(struct ao_lisp_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); - } - return len; -} - void ao_lisp_lambda_print(ao_poly poly) { diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 4fc43e58..0b3e25a6 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -43,6 +43,7 @@ struct builtin_func funcs[] = { "cdr", AO_LISP_FUNC_LAMBDA, builtin_cdr, "cons", AO_LISP_FUNC_LAMBDA, builtin_cons, "last", AO_LISP_FUNC_LAMBDA, builtin_last, + "length", AO_LISP_FUNC_LAMBDA, builtin_length, "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, "set", AO_LISP_FUNC_LAMBDA, builtin_set, "setq", AO_LISP_FUNC_MACRO, builtin_setq, @@ -61,6 +62,9 @@ struct builtin_func funcs[] = { ">", AO_LISP_FUNC_LEXPR, builtin_greater, "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, + "pack", AO_LISP_FUNC_LAMBDA, builtin_pack, + "unpack", AO_LISP_FUNC_LAMBDA, builtin_unpack, + "flush", AO_LISP_FUNC_LAMBDA, builtin_flush, "delay", AO_LISP_FUNC_LAMBDA, builtin_delay, "led", AO_LISP_FUNC_LEXPR, builtin_led, }; diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h index 55ffed50..b7bf7a2c 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/lisp/ao_lisp_os.h @@ -27,6 +27,11 @@ ao_lisp_getc() { return getchar(); } +static inline void +ao_lisp_os_flush() { + fflush(stdout); +} + static inline void ao_lisp_abort(void) { diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 0064064c..9ee1a7dd 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -34,6 +34,12 @@ static void string_move(void *addr) (void) addr; } +const struct ao_lisp_type ao_lisp_string_type = { + .mark = string_mark, + .size = string_size, + .move = string_move, +}; + char * ao_lisp_string_new(int len) { char *a = ao_lisp_alloc(len + 1); @@ -68,11 +74,47 @@ ao_lisp_string_cat(char *a, char *b) return r; } -const struct ao_lisp_type ao_lisp_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, -}; +ao_poly +ao_lisp_string_pack(struct ao_lisp_cons *cons) +{ + int len = ao_lisp_cons_length(cons); + char *r = ao_lisp_alloc(len + 1); + char *s = r; + + while (cons) { + if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) + return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); + *s++ = ao_lisp_poly_int(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } + *s++ = 0; + return ao_lisp_string_poly(r); +} + +ao_poly +ao_lisp_string_unpack(char *a) +{ + struct ao_lisp_cons *cons = NULL, *tail = NULL; + int c; + + ao_lisp_root_add(&ao_lisp_cons_type, &cons); + ao_lisp_root_add(&ao_lisp_cons_type, &tail); + while ((c = *a++)) { + struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); + if (!n) { + cons = NULL; + break; + } + if (tail) + tail->cdr = ao_lisp_cons_poly(n); + else + cons = n; + tail = n; + } + ao_lisp_root_clear(&cons); + ao_lisp_root_clear(&tail); + return ao_lisp_cons_poly(cons); +} void ao_lisp_string_print(ao_poly p) diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h index 19bd4f64..c979697e 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_lisp_os.h @@ -24,6 +24,11 @@ extern int ao_lisp_getc(void); +static inline void +ao_lisp_os_flush() { + fflush(stdout); +} + static inline void ao_lisp_abort(void) { -- cgit v1.2.3 From ddb4b8d90478ae324aa207a7541352c1ac9451ee Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 14 Nov 2016 18:45:12 -0800 Subject: altos/lisp: Change GC to do moves in batches of 32 This should make it quite a bit faster than doing one at a time. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 69 ++++- src/lisp/ao_lisp_atom.c | 14 +- src/lisp/ao_lisp_cons.c | 32 +- src/lisp/ao_lisp_eval.c | 21 +- src/lisp/ao_lisp_frame.c | 48 +-- src/lisp/ao_lisp_lambda.c | 3 + src/lisp/ao_lisp_mem.c | 745 ++++++++++++++++++++++++++++++++-------------- src/lisp/ao_lisp_read.c | 64 ++-- src/lisp/ao_lisp_string.c | 33 +- 9 files changed, 674 insertions(+), 355 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index ea3d2a09..906bae19 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -134,6 +134,7 @@ struct ao_lisp_type { int (*size)(void *addr); void (*mark)(void *addr); void (*move)(void *addr); + char name[]; }; struct ao_lisp_cons { @@ -304,11 +305,17 @@ ao_lisp_other_poly(const void *other) } static inline int -ao_lisp_mem_round(int size) +ao_lisp_size_round(int size) { return (size + 3) & ~3; } +static inline int +ao_lisp_size(const struct ao_lisp_type *type, void *addr) +{ + return ao_lisp_size_round(type->size(addr)); +} + #define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) static inline int ao_lisp_poly_base_type(ao_poly poly) { @@ -389,7 +396,7 @@ ao_lisp_mark(const struct ao_lisp_type *type, void *addr); /* returns 1 if the object was already marked */ int -ao_lisp_mark_memory(void *addr, int size); +ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); void * ao_lisp_move_map(void *addr); @@ -400,7 +407,7 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref); /* returns 1 if the object was already moved */ int -ao_lisp_move_memory(void **ref, int size); +ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); void * ao_lisp_alloc(int size); @@ -408,14 +415,23 @@ ao_lisp_alloc(int size); void ao_lisp_collect(void); -int -ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); +void +ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); -int -ao_lisp_root_poly_add(ao_poly *p); +struct ao_lisp_cons * +ao_lisp_cons_fetch(int id); void -ao_lisp_root_clear(void *addr); +ao_lisp_string_stash(int id, char *string); + +char * +ao_lisp_string_fetch(int id); + +void +ao_lisp_poly_stash(int id, ao_poly poly); + +ao_poly +ao_lisp_poly_fetch(int id); /* cons */ extern const struct ao_lisp_type ao_lisp_cons_type; @@ -435,9 +451,6 @@ ao_lisp_cons_length(struct ao_lisp_cons *cons); /* string */ extern const struct ao_lisp_type ao_lisp_string_type; -char * -ao_lisp_string_new(int len); - char * ao_lisp_string_copy(char *a); @@ -529,6 +542,10 @@ char * ao_lisp_args_name(uint8_t args); /* read */ +extern struct ao_lisp_cons *ao_lisp_read_cons; +extern struct ao_lisp_cons *ao_lisp_read_cons_tail; +extern struct ao_lisp_cons *ao_lisp_read_stack; + ao_poly ao_lisp_read(void); @@ -585,6 +602,8 @@ ao_lisp_restore(struct ao_lisp_cons *cons); /* error */ +extern const struct ao_lisp_type ao_lisp_stack_type; + void ao_lisp_stack_print(void); @@ -631,4 +650,32 @@ ao_lisp_frames_dump(void) #define DBG_FRAMES() #endif +#define DBG_MEM 1 +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) + +extern int dbg_mem; + +#define MDBG_DO(a) a +#define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) +#define MDBG_MOVE_IN() (dbg_move_depth++) +#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) + +#else + +#define MDBG_DO(a) +#define MDBG_MOVE(...) +#define MDBG_MORE(...) +#define MDBG_MOVE_IN() +#define MDBG_MOVE_OUT() + +#endif + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index e1d9b082..6705f140 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -38,7 +38,7 @@ static void atom_mark(void *addr) atom = ao_lisp_poly_atom(atom->next); if (!atom) break; - if (ao_lisp_mark_memory(atom, atom_size(atom))) + if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) break; } } @@ -53,7 +53,7 @@ static void atom_move(void *addr) if (!next) break; - ret = ao_lisp_move_memory((void **) &next, atom_size(next)); + ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); if (next != ao_lisp_poly_atom(atom->next)) atom->next = ao_lisp_atom_poly(next); if (ret) @@ -66,6 +66,7 @@ const struct ao_lisp_type ao_lisp_atom_type = { .mark = atom_mark, .size = atom_size, .move = atom_move, + .name = "atom" }; struct ao_lisp_atom *ao_lisp_atoms; @@ -85,12 +86,12 @@ ao_lisp_atom_intern(char *name) return atom; } #endif + ao_lisp_string_stash(0, name); atom = ao_lisp_alloc(name_size(name)); + name = ao_lisp_string_fetch(0); if (atom) { atom->type = AO_LISP_ATOM; atom->next = ao_lisp_atom_poly(ao_lisp_atoms); - if (!ao_lisp_atoms) - ao_lisp_root_add(&ao_lisp_atom_type, &ao_lisp_atoms); ao_lisp_atoms = atom; strcpy(atom->name, name); } @@ -103,11 +104,8 @@ struct ao_lisp_frame *ao_lisp_frame_current; static void ao_lisp_atom_init(void) { - if (!ao_lisp_frame_global) { + if (!ao_lisp_frame_global) ao_lisp_frame_global = ao_lisp_frame_new(0); - ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global); - ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current); - } } static ao_poly * diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index c7d8382f..311d63ab 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -14,8 +14,6 @@ #include "ao_lisp.h" -#define OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_const)) - static void cons_mark(void *addr) { struct ao_lisp_cons *cons = addr; @@ -25,7 +23,7 @@ static void cons_mark(void *addr) cons = ao_lisp_poly_cons(cons->cdr); if (!cons) break; - if (ao_lisp_mark_memory(cons, sizeof (struct ao_lisp_cons))) + if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) break; } } @@ -47,13 +45,17 @@ static void cons_move(void *addr) struct ao_lisp_cons *cdr; int ret; + MDBG_MOVE("cons_move start %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); (void) ao_lisp_poly_move(&cons->car, 1); cdr = ao_lisp_poly_cons(cons->cdr); if (!cdr) break; - ret = ao_lisp_move_memory((void **) &cdr, sizeof (struct ao_lisp_cons)); + ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); if (cdr != ao_lisp_poly_cons(cons->cdr)) cons->cdr = ao_lisp_cons_poly(cdr); + MDBG_MOVE("cons_move end %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); if (ret) break; cons = cdr; @@ -64,31 +66,23 @@ const struct ao_lisp_type ao_lisp_cons_type = { .mark = cons_mark, .size = cons_size, .move = cons_move, + .name = "cons", }; -static ao_poly cons_car; -static struct ao_lisp_cons *cons_cdr; -static int been_here; - struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { struct ao_lisp_cons *cons; - if (!been_here) { - ao_lisp_root_add(&ao_lisp_cons_type, &cons_cdr); - ao_lisp_root_poly_add(&cons_car); - been_here = 1; - } - cons_car = car; - cons_cdr = cdr; + ao_lisp_poly_stash(0, car); + ao_lisp_cons_stash(0, cdr); cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + car = ao_lisp_poly_fetch(0); + cdr = ao_lisp_cons_fetch(0); if (!cons) return NULL; - cons->car = cons_car; - cons->cdr = ao_lisp_cons_poly(cons_cdr); - cons_car = AO_LISP_NIL; - cons_cdr = NULL; + cons->car = car; + cons->cdr = ao_lisp_cons_poly(cdr); return cons; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index f945bc16..04d0e70a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -16,6 +16,8 @@ #include "ao_lisp.h" #include +const struct ao_lisp_type ao_lisp_stack_type; + static int stack_size(void *addr) { @@ -34,13 +36,11 @@ stack_mark(void *addr) ao_lisp_poly_mark(stack->frame, 0); ao_lisp_poly_mark(stack->list, 0); stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) + if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) break; } } -static const struct ao_lisp_type ao_lisp_stack_type; - static void stack_move(void *addr) { @@ -57,8 +57,7 @@ stack_move(void *addr) prev = ao_lisp_poly_stack(stack->prev); if (!prev) break; - ret = ao_lisp_move_memory((void **) &prev, - sizeof (struct ao_lisp_stack)); + ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); if (ret) @@ -67,10 +66,11 @@ stack_move(void *addr) } } -static const struct ao_lisp_type ao_lisp_stack_type = { +const struct ao_lisp_type ao_lisp_stack_type = { .size = stack_size, .mark = stack_mark, - .move = stack_move + .move = stack_move, + .name = "stack" }; struct ao_lisp_stack *ao_lisp_stack; @@ -567,14 +567,7 @@ ao_lisp_eval_restart(void) ao_poly ao_lisp_eval(ao_poly _v) { - static uint8_t been_here; - ao_lisp_v = _v; - if (!been_here) { - been_here = 1; - ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack); - ao_lisp_root_poly_add(&ao_lisp_v); - } if (!ao_lisp_stack_push()) return AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 082860ee..e23a6413 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -14,12 +14,6 @@ #include "ao_lisp.h" -#if 0 -#define DBG(...) printf(__VA_ARGS__) -#else -#define DBG(...) -#endif - static inline int frame_num_size(int num) { @@ -33,8 +27,6 @@ frame_size(void *addr) return frame_num_size(frame->num); } -#define OFFSET(a) ((int) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const)) - static void frame_mark(void *addr) { @@ -42,22 +34,23 @@ frame_mark(void *addr) int f; for (;;) { - DBG("frame mark %p\n", frame); + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); - DBG ("\tframe mark atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - OFFSET(v->atom), OFFSET(v->val), f); + MDBG_MOVE("frame mark atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); } frame = ao_lisp_poly_frame(frame->next); - DBG("frame next %p\n", frame); + MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) break; - if (ao_lisp_mark_memory(frame, frame_size(frame))) + if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) break; } } @@ -72,22 +65,29 @@ frame_move(void *addr) struct ao_lisp_frame *next; int ret; - DBG("frame move %p\n", frame); + MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); - DBG("moved atom %s\n", ao_lisp_poly_atom(v->atom)->name); ao_lisp_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); } next = ao_lisp_poly_frame(frame->next); if (!next) break; - ret = ao_lisp_move_memory((void **) &next, frame_size(next)); - if (next != ao_lisp_poly_frame(frame->next)) + ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &next); + if (next != ao_lisp_poly_frame(frame->next)) { + MDBG_MOVE("frame next moved from %d to %d\n", + MDBG_OFFSET(ao_lisp_poly_frame(frame->next)), + MDBG_OFFSET(next)); frame->next = ao_lisp_frame_poly(next); + } if (ret) break; frame = next; @@ -97,7 +97,8 @@ frame_move(void *addr) const struct ao_lisp_type ao_lisp_frame_type = { .mark = frame_mark, .size = frame_size, - .move = frame_move + .move = frame_move, + .name = "frame", }; void @@ -206,8 +207,8 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) if (!ref) { int f; - ao_lisp_root_poly_add(&atom); - ao_lisp_root_poly_add(&val); + ao_lisp_poly_stash(0, atom); + ao_lisp_poly_stash(1, val); if (frame) { f = frame->num; frame = ao_lisp_frame_realloc(frame_ref, f + 1); @@ -215,12 +216,11 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) f = 0; frame = ao_lisp_frame_new(1); } - ao_lisp_root_clear(&atom); - ao_lisp_root_clear(&val); + atom = ao_lisp_poly_fetch(0); + val = ao_lisp_poly_fetch(1); if (!frame) return 0; *frame_ref = frame; - DBG ("add atom %s %d, val %d at %d\n", ao_lisp_poly_atom(atom)->name, OFFSET(atom), OFFSET(val), f); frame->vals[f].atom = atom; ref = &frame->vals[f].val; } diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index c53a38fd..6020a8b8 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -47,6 +47,7 @@ const struct ao_lisp_type ao_lisp_lambda_type = { .size = lambda_size, .mark = lambda_mark, .move = lambda_move, + .name = "lambda", }; void @@ -68,7 +69,9 @@ ao_lisp_lambda_print(ao_poly poly) ao_poly ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) { + ao_lisp_cons_stash(0, code); struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + code = ao_lisp_cons_fetch(0); struct ao_lisp_cons *arg; int f; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 0373f015..60f4bbee 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -18,64 +18,243 @@ #include #ifdef AO_LISP_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + #include uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define ao_lisp_pool ao_lisp_const #undef AO_LISP_POOL #define AO_LISP_POOL AO_LISP_POOL_CONST + #else + uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); -#endif -#if 0 -#define MDBG_COLLECT_ALWAYS #endif #if 0 #define MDBG_POOL #endif -#if 0 -#include -#define MDBG_INCLUDE -#if 1 -#define MDBG_MOVE(...) do { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } while (0) -#endif -#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) -#define MDBG(...) printf(__VA_ARGS__) -#define MDBG_DO(a) a -static int move_depth; -#define MDBG_MOVE_IN() (move_depth++) -#define MDBG_MOVE_OUT() (assert(--move_depth >= 0)) +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_collects = 0; +int dbg_validate = 0; + +struct ao_lisp_record { + struct ao_lisp_record *next; + const struct ao_lisp_type *type; + void *addr; + int size; +}; + +static struct ao_lisp_record *record_head, **record_tail; + +static void +ao_lisp_record_free(struct ao_lisp_record *record) +{ + while (record) { + struct ao_lisp_record *next = record->next; + free(record); + record = next; + } +} + +static void +ao_lisp_record_reset(void) +{ + ao_lisp_record_free(record_head); + record_head = NULL; + record_tail = &record_head; +} + +static void +ao_lisp_record(const struct ao_lisp_type *type, + void *addr, + int size) +{ + struct ao_lisp_record *r = malloc(sizeof (struct ao_lisp_record)); + + r->next = NULL; + r->type = type; + r->addr = addr; + r->size = size; + *record_tail = r; + record_tail = &r->next; +} + +static struct ao_lisp_record * +ao_lisp_record_save(void) +{ + struct ao_lisp_record *r = record_head; + + record_head = NULL; + record_tail = &record_head; + return r; +} + +static void +ao_lisp_record_compare(char *where, + struct ao_lisp_record *a, + struct ao_lisp_record *b) +{ + while (a && b) { + if (a->type != b->type || a->size != b->size) { + printf("%s record difers %d %s %d -> %d %s %d\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_lisp_abort(); + } + a = a->next; + b = b->next; + } + if (a) { + printf("%s record differs %d %s %d -> NULL\n", + where, + MDBG_OFFSET(a->addr), + a->type->name, + a->size); + ao_lisp_abort(); + } + if (b) { + printf("%s record differs NULL -> %d %s %d\n", + where, + MDBG_OFFSET(b->addr), + b->type->name, + b->size); + ao_lisp_abort(); + } +} + #else -#define MDBG(...) -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() +#define ao_lisp_record_reset() #endif uint8_t ao_lisp_exception; struct ao_lisp_root { - void **addr; const struct ao_lisp_type *type; + void **addr; }; -#define AO_LISP_ROOT 16 +static struct ao_lisp_cons *save_cons[2]; +static char *save_string[2]; +static ao_poly save_poly[2]; + +static const struct ao_lisp_root ao_lisp_root[] = { + { + .type = &ao_lisp_cons_type, + .addr = (void **) &save_cons[0], + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &save_cons[1], + }, + { + .type = &ao_lisp_string_type, + .addr = (void **) &save_string[0] + }, + { + .type = &ao_lisp_string_type, + .addr = (void **) &save_string[1] + }, + { + .type = NULL, + .addr = (void **) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) &save_poly[1] + }, + { + .type = &ao_lisp_atom_type, + .addr = (void **) &ao_lisp_atoms + }, + { + .type = &ao_lisp_frame_type, + .addr = (void **) &ao_lisp_frame_global, + }, + { + .type = &ao_lisp_frame_type, + .addr = (void **) &ao_lisp_frame_current, + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &ao_lisp_stack, + }, + { + .type = NULL, + .addr = (void **) &ao_lisp_v, + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &ao_lisp_read_cons, + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &ao_lisp_read_cons_tail, + }, + { + .type = &ao_lisp_cons_type, + .addr = (void **) &ao_lisp_read_stack, + }, +}; -static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; +#define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) #define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_moving[AO_LISP_BUSY_SIZE]; static uint8_t ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; static uint8_t ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; static uint8_t ao_lisp_cons_noted; uint16_t ao_lisp_top; +struct ao_lisp_chunk { + uint16_t old_addr; + union { + uint16_t size; + uint16_t new_addr; + }; +}; + +#define AO_LISP_NCHUNK 32 + +static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; + +/* Offset of an address within the pool. */ +static inline uint16_t pool_offset(void *addr) { + if (!AO_LISP_IS_POOL(addr)) + ao_lisp_abort(); + return ((uint8_t *) addr) - ao_lisp_pool; +} + +/* + * Convert back and forth between 'poly's used + * as short addresses in the pool and addresses. + * These are used in the chunk code. + */ +static inline ao_poly pool_poly(void *addr) { + if (!AO_LISP_IS_POOL(addr)) + ao_lisp_abort(); + return ((uint8_t *) addr) - AO_LISP_POOL_BASE; +} + +static inline void *pool_ref(ao_poly p) { + return AO_LISP_POOL_BASE + p; +} + static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; @@ -101,24 +280,28 @@ static inline int limit(int offset) { return min(AO_LISP_POOL, max(offset, 0)); } +static int total_marked; + +/* + * Mark a range of addresses + */ static int mark_object(uint8_t *tag, void *addr, int size) { int base; int bound; - if (!addr) - return 1; + MDBG_DO(if (!AO_LISP_IS_POOL((uint8_t *) addr + size - 1)) + ao_lisp_abort()); - if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) - return 1; - - base = (uint8_t *) addr - ao_lisp_pool; + base = pool_offset(addr); bound = base + size; - base = limit(base); - bound = limit(bound); + MDBG_DO(if (bound > ao_lisp_top) ao_lisp_abort()); + if (busy(tag, base)) return 1; + if (tag == ao_lisp_busy) + total_marked += size; while (base < bound) { mark(tag, base); base += 4; @@ -126,12 +309,14 @@ mark_object(uint8_t *tag, void *addr, int size) { return 0; } +MDBG_DO( static int clear_object(uint8_t *tag, void *addr, int size) { int base; int bound; - if (!addr) - return 1; + + MDBG_DO(if (!AO_LISP_IS_POOL((uint8_t *) addr + size - 1)) + ao_lisp_abort()); base = (uint8_t *) addr - ao_lisp_pool; bound = base + size; @@ -140,29 +325,13 @@ clear_object(uint8_t *tag, void *addr, int size) { bound = limit(bound); if (!busy(tag, base)) return 1; + total_marked -= size; while (base < bound) { clear(tag, base); base += 4; } return 0; -} - -static int -busy_object(uint8_t *tag, void *addr) { - int base; - - if (!addr) - return 1; - - if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) - return 1; - - base = (uint8_t *) addr - ao_lisp_pool; - base = limit(base); - if (busy(tag, base)) - return 1; - return 0; -} +}) static void note_cons(void *addr) @@ -175,31 +344,63 @@ note_cons(void *addr) } } +static uint16_t chunk_low; +static uint16_t chunk_first, chunk_last; + +static void +note_chunk(uint16_t addr, uint16_t size) +{ + int i; + + if (addr < chunk_low) + return; + + for (i = 0; i < AO_LISP_NCHUNK; i++) { + if (ao_lisp_chunk[i].size && ao_lisp_chunk[i].old_addr == addr) { + if (ao_lisp_chunk[i].size != size) + ao_lisp_abort(); + return; + } + if (ao_lisp_chunk[i].old_addr > addr) { + memmove(&ao_lisp_chunk[i+1], + &ao_lisp_chunk[i], + (AO_LISP_NCHUNK - (i+1)) * sizeof (struct ao_lisp_chunk)); + ao_lisp_chunk[i].size = 0; + } + if (ao_lisp_chunk[i].size == 0) { + ao_lisp_chunk[i].old_addr = addr; + ao_lisp_chunk[i].size = size; + return; + } + } +} + /* * Walk all referenced objects calling functions on each one */ static void -walk(uint8_t *tag, - int (*visit_addr)(const struct ao_lisp_type *type, void **addr), +walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) { int i; - memset(tag, '\0', sizeof (ao_lisp_busy)); + total_marked = 0; + ao_lisp_record_reset(); + memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; for (i = 0; i < AO_LISP_ROOT; i++) { if (ao_lisp_root[i].type) { void **a = ao_lisp_root[i].addr, *v; if (a && (v = *a)) { - MDBG("root ptr %d\n", MDBG_OFFSET(v)); + MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); visit_addr(ao_lisp_root[i].type, a); } } else { ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; if (a && (p = *a)) { - MDBG("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); + MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); visit_poly(a, 0); } } @@ -211,33 +412,32 @@ walk(uint8_t *tag, for (i = 0; i < AO_LISP_POOL; i += 4) { if (busy(ao_lisp_cons_last, i)) { void *v = ao_lisp_pool + i; - MDBG("root cons %d\n", MDBG_OFFSET(v)); + MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); visit_addr(&ao_lisp_cons_type, &v); } } } } -static void *move_old, *move_new; -static int move_size; - #if MDBG_DUMP static void dump_busy(void) { int i; - printf("busy:"); + MDBG_MOVE("busy:"); for (i = 0; i < ao_lisp_top; i += 4) { - if ((i & 0xff) == 0) - printf("\n"); + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } else if ((i & 0x1f) == 0) - printf(" "); + MDBG_MORE(" "); if (busy(ao_lisp_busy, i)) - putchar('*'); + MDBG_MORE("*"); else - putchar('-'); + MDBG_MORE("-"); } - printf ("\n"); + MDBG_MORE ("\n"); } #define DUMP_BUSY() dump_busy() #else @@ -272,183 +472,241 @@ ao_lisp_collect(void) { int i; int top; +#if DBG_MEM + int loops = 0; + int marked; + int moved; + struct ao_lisp_record *mark_record = NULL, *move_record = NULL; + + ++dbg_collects; + MDBG_MOVE("collect %d\n", dbg_collects); + marked = moved = 0; +#endif + chunk_low = 0; + top = 0; + for (;;) { + MDBG_DO(loops++); + MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); + /* Find the sizes of the first chunk of objects to move */ + memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); +#if DBG_MEM + marked = total_marked; + + ao_lisp_record_free(mark_record); + mark_record = ao_lisp_record_save(); + if (mark_record && move_record) + ao_lisp_record_compare("mark", move_record, mark_record); + + if (moved && moved != marked) + ao_lisp_abort(); +#endif - MDBG("collect\n"); - /* Mark */ - walk(ao_lisp_busy, ao_lisp_mark_ref, ao_lisp_poly_mark_ref); + DUMP_BUSY(); - DUMP_BUSY(); - /* Compact */ - MDBG("find first busy\n"); - for (i = 0; i < ao_lisp_top; i += 4) { - if (!busy(ao_lisp_busy, i)) - break; - } - top = i; - while(i < ao_lisp_top) { - if (busy(ao_lisp_busy, i)) { - MDBG("busy %d -> %d\n", i, top); - MDBG_MOVE_IN(); - move_old = &ao_lisp_pool[i]; - move_new = &ao_lisp_pool[top]; - move_size = 0; - walk(ao_lisp_moving, ao_lisp_move, ao_lisp_poly_move); - MDBG("\tbusy size %d\n", move_size); - if (move_size == 0) + /* Find the first moving object */ + for (i = 0; i < AO_LISP_NCHUNK; i++) { + uint16_t size = ao_lisp_chunk[i].size; + + if (!size) + break; + + if (ao_lisp_chunk[i].old_addr > top) + break; + if (ao_lisp_chunk[i].old_addr != top) + ao_lisp_abort(); + + top += size; + MDBG_MOVE("chunk %d %d not moving\n", + ao_lisp_chunk[i].old_addr, + ao_lisp_chunk[i].size); + chunk_low = ao_lisp_chunk[i].old_addr + size; + } + + chunk_first = i; + /* Copy all of the objects */ + for (; i < AO_LISP_NCHUNK; i++) { + uint16_t size = ao_lisp_chunk[i].size; + + if (!size) + break; + + MDBG_MOVE("chunk %d %d -> %d\n", + ao_lisp_chunk[i].old_addr, + size, + top); + ao_lisp_chunk[i].new_addr = top; + memmove(&ao_lisp_pool[top], + &ao_lisp_pool[ao_lisp_chunk[i].old_addr], + size); + MDBG_DO(clear_object(ao_lisp_busy, &ao_lisp_pool[ao_lisp_chunk[i].old_addr], size)); + MDBG_DO(mark_object(ao_lisp_busy, &ao_lisp_pool[top], size)); + top += size; + chunk_low = ao_lisp_chunk[i].old_addr + size; + } + + MDBG_MOVE("after moving objects, busy is now:\n"); + DUMP_BUSY(); + chunk_last = i; + + if (chunk_first < chunk_last) { + /* Relocate all references to the objects */ + walk(ao_lisp_move, ao_lisp_poly_move); + +#if DBG_MEM + ao_lisp_record_free(move_record); + move_record = ao_lisp_record_save(); + if (mark_record && move_record) + ao_lisp_record_compare("move", mark_record, move_record); + + moved = total_marked; + if (moved != marked) ao_lisp_abort(); - clear_object(ao_lisp_busy, move_old, move_size); - mark_object(ao_lisp_busy, move_new, move_size); - if (busy_object(ao_lisp_cons_note, move_old)) { - clear_object(ao_lisp_cons_note, move_old, move_size); - mark_object(ao_lisp_cons_note, move_new, move_size); - } - i += move_size; - top += move_size; -#if MDBG_MOVE - DUMP_BUSY(); #endif - MDBG_MOVE_OUT(); - } else { - i += 4; } + + if (chunk_last != AO_LISP_NCHUNK) + break; } ao_lisp_top = top; + + MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); + +// printf ("collect. top %d loops %d\n", top, loops); } +/* + * Mark interfaces for objects + * + * Note a reference to memory and + * collect information about a few object sizes + * at a time + */ int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr) +ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) { - if (!addr) + int size; + if (!AO_LISP_IS_POOL(addr)) return 1; - MDBG_MOVE_IN(); + + size = ao_lisp_size(type, addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (!mark_object(ao_lisp_busy, addr, size)) { + note_chunk(pool_offset(addr), size); + MDBG_DO(ao_lisp_record(type, addr, size)); + return 0; + } + MDBG_MOVE("already marked\n"); + return 1; +} + +int +ao_lisp_mark(const struct ao_lisp_type *type, void *addr) +{ + int ret; MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); - if (mark_object(ao_lisp_busy, addr, type->size(addr))) { - MDBG_MOVE("already marked\n"); - MDBG_MOVE_OUT(); - return 1; + MDBG_MOVE_IN(); + ret = ao_lisp_mark_memory(type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + type->mark(addr); } - type->mark(addr); MDBG_MOVE_OUT(); - return 0; + return ret; } int ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) { - uint8_t type = ao_lisp_poly_type(p); + uint8_t type; + void *addr; if (!p) return 1; + + type = ao_lisp_poly_base_type(p); + addr = ao_lisp_ref(p); + + if (!AO_LISP_IS_POOL(addr)) + return 1; + if (type == AO_LISP_CONS && do_note_cons) { - MDBG_MOVE("note cons %d\n", MDBG_OFFSET(ao_lisp_ref(p))); note_cons(ao_lisp_ref(p)); - return 0; - } else { - const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; - if (lisp_type) - return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); return 1; - } -} + } else { + const struct ao_lisp_type *lisp_type; -int -ao_lisp_mark_memory(void *addr, int size) -{ - return mark_object(ao_lisp_busy, addr, size); -} + if (type == AO_LISP_OTHER) { + type = ao_lisp_other_type(ao_lisp_poly_other(p)); + if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) + ao_lisp_abort(); + } -/* - * After the object has been moved, we have to reference it - * in the new location. This is only relevant for ao_lisp_poly_move - * as it needs to fetch the type byte from the object, which - * may have been overwritten by the copy - */ -void * -ao_lisp_move_map(void *addr) -{ - if (addr == move_old) { - if (move_size != 0) - return move_new; + lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; + if (!lisp_type) + return 1; + return ao_lisp_mark(lisp_type, ao_lisp_ref(p)); } - return addr; } static void * -check_move(void *addr, int size) +move_map(void *addr) { - if (addr == move_old) { - MDBG_MOVE("mapping %d -> %d\n", MDBG_OFFSET(addr), MDBG_OFFSET(move_new)); - if (move_size && move_size != ((size + 3) & ~3)) - ao_lisp_abort(); - - /* Only copy the object once, otherwise we may - * smash stuff - */ - if (move_size == 0) { - MDBG_MOVE(" copy %d\n", size); - memmove(move_new, move_old, size); - move_size = (size + 3) & ~3; + uint16_t offset = pool_offset(addr); + int i; + + for (i = chunk_first; i < chunk_last; i++) { + if (ao_lisp_chunk[i].old_addr == offset) { + MDBG_MOVE("move %d -> %d\n", + ao_lisp_chunk[i].old_addr, + ao_lisp_chunk[i].new_addr); + return ao_lisp_pool + ao_lisp_chunk[i].new_addr; } - addr = move_new; } return addr; } int -ao_lisp_move(const struct ao_lisp_type *type, void **ref) +ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) { void *addr = *ref; - uint8_t *a = addr; - int size = type->size(ao_lisp_move_map(addr)); + int size; - if (!addr) + if (!AO_LISP_IS_POOL(addr)) return 1; -#ifndef AO_LISP_MAKE_CONST - if (AO_LISP_IS_CONST(addr)) - return 1; -#endif - MDBG_MOVE("object %d\n", MDBG_OFFSET(addr)); - if (!AO_LISP_IS_POOL(a)) - ao_lisp_abort(); - MDBG_MOVE_IN(); - addr = check_move(addr, size); - if (addr != *ref) + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); + addr = move_map(addr); + size = ao_lisp_size(type, addr); + if (addr != *ref) { + MDBG_MOVE("update ref %d %d -> %d\n", + AO_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + MDBG_OFFSET(*ref), MDBG_OFFSET(addr)); *ref = addr; - if (mark_object(ao_lisp_moving, addr, size)) { - MDBG_MOVE("already moved\n"); - MDBG_MOVE_OUT(); - return 1; } - MDBG_MOVE_OUT(); - MDBG_MOVE("recursing...\n"); - MDBG_MOVE_IN(); - type->move(addr); - MDBG_MOVE_OUT(); - MDBG_MOVE("done %d\n", MDBG_OFFSET(addr)); - return 0; + if (!mark_object(ao_lisp_busy, addr, size)) { + MDBG_DO(ao_lisp_record(type, addr, size)); + return 0; + } + MDBG_MOVE("already moved\n"); + return 1; } int -ao_lisp_move_memory(void **ref, int size) +ao_lisp_move(const struct ao_lisp_type *type, void **ref) { - void *addr = *ref; - if (!addr) - return 1; - - MDBG_MOVE("memory %d\n", MDBG_OFFSET(addr)); + int ret; + MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); MDBG_MOVE_IN(); - addr = check_move(addr, size); - if (addr != *ref) - *ref = addr; - if (mark_object(ao_lisp_moving, addr, size)) { - MDBG_MOVE("already moved\n"); - MDBG_MOVE_OUT(); - return 1; + ret = ao_lisp_move_memory(type, ref); + if (!ret) { + MDBG_MOVE("move recurse\n"); + type->move(*ref); } MDBG_MOVE_OUT(); - return 0; + return ret; } int @@ -456,7 +714,6 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) { uint8_t type; ao_poly p = *ref; - const struct ao_lisp_type *lisp_type; int ret; void *addr; @@ -466,20 +723,24 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) type = ao_lisp_poly_base_type(p); addr = ao_lisp_ref(p); - if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) + if (!AO_LISP_IS_POOL(addr)) return 1; if (type == AO_LISP_CONS && do_note_cons) { - addr = check_move(addr, sizeof (struct ao_lisp_cons)); +// addr = move_map(addr); + MDBG_DO(if (addr != move_map(addr)) MDBG_MOVE("noting cons at old addr %d instead of new addr %d\n", MDBG_OFFSET(addr), MDBG_OFFSET(move_map(addr)));); + note_cons(addr); + addr = move_map(addr); ret = 1; } else { + const struct ao_lisp_type *lisp_type; - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); - - if (type >= AO_LISP_NUM_TYPE) - ao_lisp_abort(); + if (type == AO_LISP_OTHER) { + type = ao_lisp_other_type(move_map(ao_lisp_poly_other(p))); + if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) + ao_lisp_abort(); + } lisp_type = ao_lisp_types[type]; if (!lisp_type) @@ -487,10 +748,11 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) ret = ao_lisp_move(lisp_type, &addr); } + /* Re-write the poly value */ if (addr != ao_lisp_ref(p)) { ao_poly np = ao_lisp_poly(addr, p & AO_LISP_TYPE_MASK); - MDBG("poly %d moved %d -> %d\n", - type, MDBG_OFFSET(ao_lisp_ref(p)), MDBG_OFFSET(ao_lisp_ref(np))); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, MDBG_OFFSET(ao_lisp_ref(p)), MDBG_OFFSET(ao_lisp_ref(np))); *ref = np; } return ret; @@ -535,15 +797,28 @@ ao_lisp_poison(void) #define AO_LISP_POOL_CUR AO_LISP_POOL #endif +#if DBG_MEM +void +ao_lisp_validate(void) +{ + chunk_low = 0; + memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); +} + +int dbg_allocs; + +#endif + + void * ao_lisp_alloc(int size) { void *addr; - size = ao_lisp_mem_round(size); -#ifdef MDBG_COLLECT_ALWAYS - ao_lisp_collect(); -#endif + MDBG_DO(++dbg_allocs); + MDBG_DO(if (dbg_validate) ao_lisp_validate()); + size = ao_lisp_size_round(size); if (ao_lisp_top + size > AO_LISP_POOL_CUR) { #ifdef MDBG_POOL if (AO_LISP_POOL_CUR < AO_LISP_POOL) { @@ -573,37 +848,47 @@ ao_lisp_alloc(int size) return addr; } -int -ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) +void +ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) { - int i; - MDBG("add root type %p addr %p\n", type, addr); - for (i = 0; i < AO_LISP_ROOT; i++) { - if (!ao_lisp_root[i].addr) { - ao_lisp_root[i].addr = addr; - ao_lisp_root[i].type = type; - return 1; - } - } - ao_lisp_abort(); - return 0; + if (save_cons[id] != NULL) + ao_lisp_abort(); + save_cons[id] = cons; } -int -ao_lisp_root_poly_add(ao_poly *p) +struct ao_lisp_cons * +ao_lisp_cons_fetch(int id) { - return ao_lisp_root_add(NULL, p); + struct ao_lisp_cons *cons = save_cons[id]; + save_cons[id] = NULL; + return cons; } void -ao_lisp_root_clear(void *addr) +ao_lisp_string_stash(int id, char *string) { - int i; - for (i = 0; i < AO_LISP_ROOT; i++) { - if (ao_lisp_root[i].addr == addr) { - ao_lisp_root[i].addr = 0; - ao_lisp_root[i].type = 0; - break; - } - } + if (save_cons[id] != NULL) + ao_lisp_abort(); + save_string[id] = string; +} + +char * +ao_lisp_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} +void +ao_lisp_poly_stash(int id, ao_poly poly) +{ + save_poly[id] = poly; +} + +ao_poly +ao_lisp_poly_fetch(int id) +{ + ao_poly poly = save_poly[id]; + save_poly[id] = AO_LISP_NIL; + return poly; } diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 7a5751ce..b792c2f1 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -357,25 +357,25 @@ lex(void) } static int parse_token; -static uint8_t been_here; -static struct ao_lisp_cons *read_cons; -static struct ao_lisp_cons *read_cons_tail; -static struct ao_lisp_cons *read_stack; + +struct ao_lisp_cons *ao_lisp_read_cons; +struct ao_lisp_cons *ao_lisp_read_cons_tail; +struct ao_lisp_cons *ao_lisp_read_stack; static int push_read_stack(int cons, int in_quote) { - DBGI("push read stack %p %d\n", read_cons, in_quote); + DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); DBG_IN(); if (cons) { - read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), + ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), - read_stack)); - if (!read_stack) + ao_lisp_read_stack)); + if (!ao_lisp_read_stack) return 0; } - read_cons = NULL; - read_cons_tail = NULL; + ao_lisp_read_cons = NULL; + ao_lisp_read_cons_tail = NULL; return 1; } @@ -384,21 +384,21 @@ pop_read_stack(int cons) { int in_quote = 0; if (cons) { - read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = ao_lisp_poly_cons(read_stack->cdr); - in_quote = ao_lisp_poly_int(read_stack->car); - read_stack = ao_lisp_poly_cons(read_stack->cdr); - for (read_cons_tail = read_cons; - read_cons_tail && read_cons_tail->cdr; - read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) + ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); + ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); + in_quote = ao_lisp_poly_int(ao_lisp_read_stack->car); + ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); + for (ao_lisp_read_cons_tail = ao_lisp_read_cons; + ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; + ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) ; } else { - read_cons = 0; - read_cons_tail = 0; - read_stack = 0; + ao_lisp_read_cons = 0; + ao_lisp_read_cons_tail = 0; + ao_lisp_read_stack = 0; } DBG_OUT(); - DBGI("pop read stack %p %d\n", read_cons, in_quote); + DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); return in_quote; } @@ -411,18 +411,12 @@ ao_lisp_read(void) int in_quote; ao_poly v; - if (!been_here) { - ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); - ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); - ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); - been_here = 1; - } parse_token = lex(); DBGI("token %d (%s)\n", parse_token, token_string); cons = 0; in_quote = 0; - read_cons = read_cons_tail = read_stack = 0; + ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; for (;;) { while (parse_token == OPEN) { if (!push_read_stack(cons, in_quote)) @@ -469,7 +463,7 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; } - v = ao_lisp_cons_poly(read_cons); + v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; in_quote = pop_read_stack(cons); break; @@ -484,16 +478,16 @@ ao_lisp_read(void) if (!read) return AO_LISP_NIL; - if (read_cons_tail) - read_cons_tail->cdr = ao_lisp_cons_poly(read); + if (ao_lisp_read_cons_tail) + ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); else - read_cons = read; - read_cons_tail = read; + ao_lisp_read_cons = read; + ao_lisp_read_cons_tail = read; - if (!in_quote || !read_cons->cdr) + if (!in_quote || !ao_lisp_read_cons->cdr) break; - v = ao_lisp_cons_poly(read_cons); + v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; in_quote = pop_read_stack(cons); } diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 9ee1a7dd..207d4f3b 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -38,23 +38,17 @@ const struct ao_lisp_type ao_lisp_string_type = { .mark = string_mark, .size = string_size, .move = string_move, + .name = "string", }; -char * -ao_lisp_string_new(int len) { - char *a = ao_lisp_alloc(len + 1); - if (!a) - return NULL; - a[len] = '\0'; - return a; -} - char * ao_lisp_string_copy(char *a) { int alen = strlen(a); + ao_lisp_string_stash(0, a); char *r = ao_lisp_alloc(alen + 1); + a = ao_lisp_string_fetch(0); if (!r) return NULL; strcpy(r, a); @@ -66,7 +60,12 @@ ao_lisp_string_cat(char *a, char *b) { int alen = strlen(a); int blen = strlen(b); + + ao_lisp_string_stash(0, a); + ao_lisp_string_stash(1, b); char *r = ao_lisp_alloc(alen + blen + 1); + a = ao_lisp_string_fetch(0); + b = ao_lisp_string_fetch(1); if (!r) return NULL; strcpy(r, a); @@ -78,7 +77,9 @@ ao_poly ao_lisp_string_pack(struct ao_lisp_cons *cons) { int len = ao_lisp_cons_length(cons); + ao_lisp_cons_stash(0, cons); char *r = ao_lisp_alloc(len + 1); + cons = ao_lisp_cons_fetch(0); char *s = r; while (cons) { @@ -96,11 +97,17 @@ ao_lisp_string_unpack(char *a) { struct ao_lisp_cons *cons = NULL, *tail = NULL; int c; + int i; - ao_lisp_root_add(&ao_lisp_cons_type, &cons); - ao_lisp_root_add(&ao_lisp_cons_type, &tail); - while ((c = *a++)) { + for (i = 0; (c = a[i]); i++) { + ao_lisp_cons_stash(0, cons); + ao_lisp_cons_stash(1, tail); + ao_lisp_string_stash(0, a); struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); + cons = ao_lisp_cons_fetch(0); + tail = ao_lisp_cons_fetch(1); + a = ao_lisp_string_fetch(0); + if (!n) { cons = NULL; break; @@ -111,8 +118,6 @@ ao_lisp_string_unpack(char *a) cons = n; tail = n; } - ao_lisp_root_clear(&cons); - ao_lisp_root_clear(&tail); return ao_lisp_cons_poly(cons); } -- cgit v1.2.3 From 5557f6b87a9b8bc9716de8191f2062a772a6ae6c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 14 Nov 2016 21:25:38 -0800 Subject: altos/lisp: Cache freed cons and stack items Track freed cons cells and stack items from the eval process where possible so that they can be re-used without needing to collect. This dramatically reduces the number of collect calls. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 17 ++++++++++++++ src/lisp/ao_lisp_cons.c | 32 +++++++++++++++++++------ src/lisp/ao_lisp_eval.c | 33 +++++++++++++++++++++----- src/lisp/ao_lisp_lambda.c | 1 + src/lisp/ao_lisp_make_const.c | 54 +++++++++++++++++++++---------------------- src/lisp/ao_lisp_mem.c | 41 ++++++++++++++++++++++++-------- src/lisp/ao_lisp_save.c | 2 +- 7 files changed, 130 insertions(+), 50 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index e90d791a..efd13cf5 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -206,6 +206,7 @@ ao_lisp_stack_poly(struct ao_lisp_stack *stack) } extern struct ao_lisp_stack *ao_lisp_stack; +extern struct ao_lisp_stack *ao_lisp_stack_free_list; extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 @@ -213,6 +214,14 @@ extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_MACRO 2 #define AO_LISP_FUNC_LEXPR 3 +#define AO_LISP_FUNC_FREE_ARGS 0x80 +#define AO_LISP_FUNC_MASK 0x7f + +#define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) +#define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) +#define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) +#define AO_LISP_FUNC_F_LEXPR (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) + struct ao_lisp_builtin { uint8_t type; uint8_t args; @@ -390,6 +399,9 @@ ao_lisp_builtin_poly(struct ao_lisp_builtin *b) } /* memory functions */ + +extern int ao_lisp_collects; + /* returns 1 if the object was already marked */ int ao_lisp_mark(const struct ao_lisp_type *type, void *addr); @@ -439,6 +451,11 @@ extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); +extern struct ao_lisp_cons *ao_lisp_cons_free_list; + +void +ao_lisp_cons_free(struct ao_lisp_cons *cons); + void ao_lisp_cons_print(ao_poly); diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 311d63ab..d2b60c9a 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -69,23 +69,41 @@ const struct ao_lisp_type ao_lisp_cons_type = { .name = "cons", }; +struct ao_lisp_cons *ao_lisp_cons_free_list; + struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { struct ao_lisp_cons *cons; - ao_lisp_poly_stash(0, car); - ao_lisp_cons_stash(0, cdr); - cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - car = ao_lisp_poly_fetch(0); - cdr = ao_lisp_cons_fetch(0); - if (!cons) - return NULL; + if (ao_lisp_cons_free_list) { + cons = ao_lisp_cons_free_list; + ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); + } else { + ao_lisp_poly_stash(0, car); + ao_lisp_cons_stash(0, cdr); + cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); + car = ao_lisp_poly_fetch(0); + cdr = ao_lisp_cons_fetch(0); + if (!cons) + return NULL; + } cons->car = car; cons->cdr = ao_lisp_cons_poly(cdr); return cons; } +void +ao_lisp_cons_free(struct ao_lisp_cons *cons) +{ + while (cons) { + ao_poly cdr = cons->cdr; + cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); + ao_lisp_cons_free_list = cons; + cons = ao_lisp_poly_cons(cdr); + } +} + void ao_lisp_cons_print(ao_poly c) { diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 04d0e70a..5cc1b75a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -76,6 +76,8 @@ const struct ao_lisp_type ao_lisp_stack_type = { struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; +struct ao_lisp_stack *ao_lisp_stack_free_list; + ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -97,9 +99,15 @@ ao_lisp_stack_reset(struct ao_lisp_stack *stack) static int ao_lisp_stack_push(void) { - struct ao_lisp_stack *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; + struct ao_lisp_stack *stack; + if (ao_lisp_stack_free_list) { + stack = ao_lisp_stack_free_list; + ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); + } else { + stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!stack) + return 0; + } stack->prev = ao_lisp_stack_poly(ao_lisp_stack); stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); stack->list = AO_LISP_NIL; @@ -114,9 +122,15 @@ ao_lisp_stack_push(void) static void ao_lisp_stack_pop(void) { + ao_poly prev; + if (!ao_lisp_stack) return; - ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); + prev = ao_lisp_stack->prev; + ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); + ao_lisp_stack_free_list = ao_lisp_stack; + + ao_lisp_stack = ao_lisp_poly_stack(prev); if (ao_lisp_stack) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else @@ -141,7 +155,7 @@ func_type(ao_poly func) return ao_lisp_error(AO_LISP_INVALID, "func is nil"); switch (ao_lisp_poly_type(func)) { case AO_LISP_BUILTIN: - return ao_lisp_poly_builtin(func)->args; + return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; case AO_LISP_LAMBDA: return ao_lisp_poly_lambda(func)->args; default: @@ -359,12 +373,15 @@ static int ao_lisp_eval_exec(void) { ao_poly v; + struct ao_lisp_builtin *builtin; + DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); ao_lisp_stack->sexprs = AO_LISP_NIL; switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_BUILTIN: ao_lisp_stack->state = eval_val; - v = ao_lisp_func(ao_lisp_poly_builtin(ao_lisp_v)) ( + builtin = ao_lisp_poly_builtin(ao_lisp_v); + v = ao_lisp_func(builtin) ( ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); @@ -372,6 +389,10 @@ ao_lisp_eval_exec(void) ao_poly val = ao_lisp_arg(cons, 2); DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); + builtin = ao_lisp_poly_builtin(ao_lisp_v); + if (builtin->args & AO_LISP_FUNC_FREE_ARGS) + ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); + ao_lisp_v = v; DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 6020a8b8..0dd8c698 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -168,6 +168,7 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } + ao_lisp_cons_free(cons); break; } case AO_LISP_FUNC_LEXPR: diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6a29f402..178b041e 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -33,42 +33,42 @@ struct builtin_func { }; struct builtin_func funcs[] = { - "eval", AO_LISP_FUNC_LAMBDA, builtin_eval, - "read", AO_LISP_FUNC_LAMBDA, builtin_read, + "eval", AO_LISP_FUNC_F_LAMBDA, builtin_eval, + "read", AO_LISP_FUNC_F_LAMBDA, builtin_read, "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, "macro", AO_LISP_FUNC_NLAMBDA, builtin_macro, - "car", AO_LISP_FUNC_LAMBDA, builtin_car, - "cdr", AO_LISP_FUNC_LAMBDA, builtin_cdr, - "cons", AO_LISP_FUNC_LAMBDA, builtin_cons, - "last", AO_LISP_FUNC_LAMBDA, builtin_last, - "length", AO_LISP_FUNC_LAMBDA, builtin_length, + "car", AO_LISP_FUNC_F_LAMBDA, builtin_car, + "cdr", AO_LISP_FUNC_F_LAMBDA, builtin_cdr, + "cons", AO_LISP_FUNC_F_LAMBDA, builtin_cons, + "last", AO_LISP_FUNC_F_LAMBDA, builtin_last, + "length", AO_LISP_FUNC_F_LAMBDA, builtin_length, "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, - "set", AO_LISP_FUNC_LAMBDA, builtin_set, + "set", AO_LISP_FUNC_F_LAMBDA, builtin_set, "setq", AO_LISP_FUNC_MACRO, builtin_setq, "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, "progn", AO_LISP_FUNC_NLAMBDA, builtin_progn, "while", AO_LISP_FUNC_NLAMBDA, builtin_while, - "print", AO_LISP_FUNC_LEXPR, builtin_print, - "patom", AO_LISP_FUNC_LEXPR, builtin_patom, - "+", AO_LISP_FUNC_LEXPR, builtin_plus, - "-", AO_LISP_FUNC_LEXPR, builtin_minus, - "*", AO_LISP_FUNC_LEXPR, builtin_times, - "/", AO_LISP_FUNC_LEXPR, builtin_divide, - "%", AO_LISP_FUNC_LEXPR, builtin_mod, - "=", AO_LISP_FUNC_LEXPR, builtin_equal, - "<", AO_LISP_FUNC_LEXPR, builtin_less, - ">", AO_LISP_FUNC_LEXPR, builtin_greater, - "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, - ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, - "pack", AO_LISP_FUNC_LAMBDA, builtin_pack, - "unpack", AO_LISP_FUNC_LAMBDA, builtin_unpack, - "flush", AO_LISP_FUNC_LAMBDA, builtin_flush, - "delay", AO_LISP_FUNC_LAMBDA, builtin_delay, - "led", AO_LISP_FUNC_LEXPR, builtin_led, - "save", AO_LISP_FUNC_LAMBDA, builtin_save, - "restore", AO_LISP_FUNC_LAMBDA, builtin_restore, + "print", AO_LISP_FUNC_F_LEXPR, builtin_print, + "patom", AO_LISP_FUNC_F_LEXPR, builtin_patom, + "+", AO_LISP_FUNC_F_LEXPR, builtin_plus, + "-", AO_LISP_FUNC_F_LEXPR, builtin_minus, + "*", AO_LISP_FUNC_F_LEXPR, builtin_times, + "/", AO_LISP_FUNC_F_LEXPR, builtin_divide, + "%", AO_LISP_FUNC_F_LEXPR, builtin_mod, + "=", AO_LISP_FUNC_F_LEXPR, builtin_equal, + "<", AO_LISP_FUNC_F_LEXPR, builtin_less, + ">", AO_LISP_FUNC_F_LEXPR, builtin_greater, + "<=", AO_LISP_FUNC_F_LEXPR, builtin_less_equal, + ">=", AO_LISP_FUNC_F_LEXPR, builtin_greater_equal, + "pack", AO_LISP_FUNC_F_LAMBDA, builtin_pack, + "unpack", AO_LISP_FUNC_F_LAMBDA, builtin_unpack, + "flush", AO_LISP_FUNC_F_LAMBDA, builtin_flush, + "delay", AO_LISP_FUNC_F_LAMBDA, builtin_delay, + "led", AO_LISP_FUNC_F_LEXPR, builtin_led, + "save", AO_LISP_FUNC_F_LAMBDA, builtin_save, + "restore", AO_LISP_FUNC_F_LAMBDA, builtin_restore, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 08b5bac0..e7ece960 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -43,7 +43,6 @@ uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4 #if DBG_MEM int dbg_move_depth; int dbg_mem = DBG_MEM_START; -int dbg_collects = 0; int dbg_validate = 0; struct ao_lisp_record { @@ -212,6 +211,13 @@ static const struct ao_lisp_root ao_lisp_root[] = { #define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) +static const void ** const ao_lisp_cache[] = { + (const void **) &ao_lisp_cons_free_list, + (const void **) &ao_lisp_stack_free_list, +}; + +#define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) + #define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; @@ -229,14 +235,16 @@ struct ao_lisp_chunk { }; }; -#define AO_LISP_NCHUNK 32 +#define AO_LISP_NCHUNK 64 static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; /* Offset of an address within the pool. */ static inline uint16_t pool_offset(void *addr) { +#if DBG_MEM if (!AO_LISP_IS_POOL(addr)) ao_lisp_abort(); +#endif return ((uint8_t *) addr) - ao_lisp_pool; } @@ -246,8 +254,10 @@ static inline uint16_t pool_offset(void *addr) { * These are used in the chunk code. */ static inline ao_poly pool_poly(void *addr) { +#if DBG_MEM if (!AO_LISP_IS_POOL(addr)) ao_lisp_abort(); +#endif return ((uint8_t *) addr) - AO_LISP_POOL_BASE; } @@ -306,8 +316,10 @@ note_chunk(uint16_t addr, uint16_t size) for (i = 0; i < AO_LISP_NCHUNK; i++) { if (ao_lisp_chunk[i].size && ao_lisp_chunk[i].old_addr == addr) { +#if DBG_MEM if (ao_lisp_chunk[i].size != size) ao_lisp_abort(); +#endif return; } if (ao_lisp_chunk[i].old_addr > addr) { @@ -339,7 +351,7 @@ walk(int (*visit_addr)(const struct ao_lisp_type *type, void **addr), memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); ao_lisp_cons_noted = 0; - for (i = 0; i < AO_LISP_ROOT; i++) { + for (i = 0; i < (int) AO_LISP_ROOT; i++) { if (ao_lisp_root[i].type) { void **a = ao_lisp_root[i].addr, *v; if (a && (v = *a)) { @@ -416,6 +428,8 @@ ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) return ao_lisp_poly_mark(*p, do_note_cons); } +int ao_lisp_collects; + void ao_lisp_collect(void) { @@ -427,10 +441,15 @@ ao_lisp_collect(void) int moved; struct ao_lisp_record *mark_record = NULL, *move_record = NULL; - ++dbg_collects; - MDBG_MOVE("collect %d\n", dbg_collects); + MDBG_MOVE("collect %d\n", ao_lisp_collects); marked = moved = 0; #endif + + ++ao_lisp_collects; + + /* Clear references to all caches */ + for (i = 0; i < (int) AO_LISP_CACHE; i++) + *ao_lisp_cache[i] = NULL; chunk_low = 0; top = 0; for (;;) { @@ -462,8 +481,10 @@ ao_lisp_collect(void) if (ao_lisp_chunk[i].old_addr > top) break; +#if DBG_MEM if (ao_lisp_chunk[i].old_addr != top) ao_lisp_abort(); +#endif top += size; MDBG_MOVE("chunk %d %d not moving\n", @@ -585,8 +606,10 @@ ao_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) if (type == AO_LISP_OTHER) { type = ao_lisp_other_type(ao_lisp_poly_other(p)); +#if DBG_MEM if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) ao_lisp_abort(); +#endif } lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; @@ -622,6 +645,8 @@ ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) if (!AO_LISP_IS_POOL(addr)) return 1; + (void) type; + MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); addr = move_map(addr); if (addr != *ref) { @@ -682,8 +707,10 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) if (type == AO_LISP_OTHER) { type = ao_lisp_other_type(move_map(ao_lisp_poly_other(p))); +#if DBG_MEM if (type <= AO_LISP_OTHER || AO_LISP_NUM_TYPE <= type) ao_lisp_abort(); +#endif } lisp_type = ao_lisp_types[type]; @@ -795,8 +822,6 @@ ao_lisp_alloc(int size) void ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) { - if (save_cons[id] != NULL) - ao_lisp_abort(); save_cons[id] = cons; } @@ -811,8 +836,6 @@ ao_lisp_cons_fetch(int id) void ao_lisp_string_stash(int id, char *string) { - if (save_cons[id] != NULL) - ao_lisp_abort(); save_string[id] = string; } diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index 030846b7..d5f28e7d 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -27,7 +27,7 @@ ao_lisp_save(struct ao_lisp_cons *cons) os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); os->const_checksum = ao_lisp_const_checksum; - os->const_checksum_inv = ~ao_lisp_const_checksum; + os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; if (ao_lisp_os_save()) return _ao_lisp_atom_t; -- cgit v1.2.3 From 881161fe1c5fb0e2b1220c30572eb2c45bedbafe Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 15 Nov 2016 20:18:59 -0800 Subject: altos/lisp: re-use small frames This saves a pile more use of the allocator by noting when frames have not been referenced from another frame and freeing them when they go out of scope. Frames with references are left to the allocator to deal with. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 37 +++++++++++++++++-- src/lisp/ao_lisp_atom.c | 4 +-- src/lisp/ao_lisp_error.c | 6 ++-- src/lisp/ao_lisp_eval.c | 6 +++- src/lisp/ao_lisp_frame.c | 91 +++++++++++++++++++++++++++++++---------------- src/lisp/ao_lisp_lambda.c | 4 +-- src/lisp/ao_lisp_mem.c | 8 +++++ 7 files changed, 116 insertions(+), 40 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 2db4914f..bcb0a17f 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -156,13 +156,33 @@ struct ao_lisp_val { struct ao_lisp_frame { uint8_t type; - uint8_t num; - ao_poly next; + uint8_t _num; + ao_poly prev; struct ao_lisp_val vals[]; }; +#define AO_LISP_FRAME_NUM_MASK 0x7f + +/* Set when the frame escapes the lambda */ +#define AO_LISP_FRAME_MARK 0x80 + +static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { + if (f->_num == 0xff) + ao_lisp_abort(); + return f->_num & AO_LISP_FRAME_NUM_MASK; +} + +static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { + if (f->_num == 0xff) + ao_lisp_abort(); + return f->_num & AO_LISP_FRAME_MARK; +} + static inline struct ao_lisp_frame * ao_lisp_poly_frame(ao_poly poly) { + struct ao_lisp_frame *frame = ao_lisp_ref(poly); + if (frame && frame->_num == 0xff) + ao_lisp_abort(); return ao_lisp_ref(poly); } @@ -500,6 +520,9 @@ ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); +ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom); + ao_poly ao_lisp_atom_get(ao_poly atom); @@ -574,12 +597,22 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; +#define AO_LISP_FRAME_FREE 4 + +extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + +ao_poly +ao_lisp_frame_mark(struct ao_lisp_frame *frame); + ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num); +void +ao_lisp_frame_free(struct ao_lisp_frame *frame); + int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 6705f140..8c9e8ed1 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -108,7 +108,7 @@ ao_lisp_atom_init(void) ao_lisp_frame_global = ao_lisp_frame_new(0); } -static ao_poly * +ao_poly * ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) { ao_poly *ref; @@ -117,7 +117,7 @@ ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) ref = ao_lisp_frame_ref(frame, atom); if (ref) return ref; - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } if (ao_lisp_frame_global) { ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index cfa78d22..2b15c418 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -49,7 +49,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { if (f != 0) { tabs(indent); printf(" "); @@ -59,8 +59,8 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) ao_lisp_poly_print(frame->vals[f].val); printf("\n"); } - if (frame->next) - ao_lisp_error_frame(indent + 1, "next: ", ao_lisp_poly_frame(frame->next)); + if (frame->prev) + ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); } tabs(indent); printf(" }\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3af56796..6f56a120 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -122,7 +122,8 @@ ao_lisp_stack_push(void) static void ao_lisp_stack_pop(void) { - ao_poly prev; + ao_poly prev; + struct ao_lisp_frame *prev_frame; if (!ao_lisp_stack) return; @@ -131,10 +132,13 @@ ao_lisp_stack_pop(void) ao_lisp_stack_free_list = ao_lisp_stack; ao_lisp_stack = ao_lisp_poly_stack(prev); + prev_frame = ao_lisp_frame_current; if (ao_lisp_stack) ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); else ao_lisp_frame_current = NULL; + if (ao_lisp_frame_current != prev_frame) + ao_lisp_frame_free(prev_frame); DBG_OUT(); DBGI("stack pop\n"); DBG_FRAMES(); diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index e23a6413..052d27d7 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -24,7 +24,7 @@ static int frame_size(void *addr) { struct ao_lisp_frame *frame = addr; - return frame_num_size(frame->num); + return frame_num_size(ao_lisp_frame_num(frame)); } static void @@ -37,7 +37,7 @@ frame_mark(void *addr) MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); @@ -46,7 +46,7 @@ frame_mark(void *addr) MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); } - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) break; @@ -62,13 +62,13 @@ frame_move(void *addr) int f; for (;;) { - struct ao_lisp_frame *next; + struct ao_lisp_frame *prev; int ret; MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); @@ -78,19 +78,19 @@ frame_move(void *addr) MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); } - next = ao_lisp_poly_frame(frame->next); - if (!next) + prev = ao_lisp_poly_frame(frame->prev); + if (!prev) break; - ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &next); - if (next != ao_lisp_poly_frame(frame->next)) { - MDBG_MOVE("frame next moved from %d to %d\n", - MDBG_OFFSET(ao_lisp_poly_frame(frame->next)), - MDBG_OFFSET(next)); - frame->next = ao_lisp_frame_poly(next); + ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); + if (prev != ao_lisp_poly_frame(frame->prev)) { + MDBG_MOVE("frame prev moved from %d to %d\n", + MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), + MDBG_OFFSET(prev)); + frame->prev = ao_lisp_frame_poly(prev); } if (ret) break; - frame = next; + frame = prev; } } @@ -109,15 +109,15 @@ ao_lisp_frame_print(ao_poly p) printf ("{"); if (frame) { - for (f = 0; f < frame->num; f++) { + for (f = 0; f < ao_lisp_frame_num(frame); f++) { if (f != 0) printf(", "); ao_lisp_poly_print(frame->vals[f].atom); printf(" = "); ao_lisp_poly_print(frame->vals[f].val); } - if (frame->next) - ao_lisp_poly_print(frame->next); + if (frame->prev) + ao_lisp_poly_print(frame->prev); } printf("}"); } @@ -126,7 +126,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; - for (f = 0; f < frame->num; f++) + for (f = 0; f < ao_lisp_frame_num(frame); f++) if (frame->vals[f].atom == atom) return &frame->vals[f].val; return NULL; @@ -143,7 +143,7 @@ ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) return 1; } } - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } return 0; } @@ -155,25 +155,55 @@ ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) ao_poly *ref = ao_lisp_frame_ref(frame, atom); if (ref) return *ref; - frame = ao_lisp_poly_frame(frame->next); + frame = ao_lisp_poly_frame(frame->prev); } return AO_LISP_NIL; } +struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + struct ao_lisp_frame * ao_lisp_frame_new(int num) { - struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num)); + struct ao_lisp_frame *frame; - if (!frame) - return NULL; + if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) + ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); + else { + frame = ao_lisp_alloc(frame_num_size(num)); + if (!frame) + return NULL; + } frame->type = AO_LISP_FRAME; - frame->num = num; - frame->next = AO_LISP_NIL; + frame->_num = num; + frame->prev = AO_LISP_NIL; memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); return frame; } +ao_poly +ao_lisp_frame_mark(struct ao_lisp_frame *frame) +{ + if (!frame) + return AO_LISP_NIL; + if (frame->_num == 0xff) + ao_lisp_abort(); + frame->_num |= AO_LISP_FRAME_MARK; + return ao_lisp_frame_poly(frame); +} + +void +ao_lisp_frame_free(struct ao_lisp_frame *frame) +{ + if (!ao_lisp_frame_marked(frame)) { + int num = ao_lisp_frame_num(frame); + if (num < AO_LISP_FRAME_FREE) { + frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); + ao_lisp_frame_free_list[num] = frame; + } + } +} + static struct ao_lisp_frame * ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) { @@ -181,7 +211,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) struct ao_lisp_frame *new; int copy; - if (new_num == frame->num) + if (new_num == ao_lisp_frame_num(frame)) return frame; new = ao_lisp_frame_new(new_num); if (!new) @@ -192,10 +222,11 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) */ frame = *frame_ref; copy = new_num; - if (copy > frame->num) - copy = frame->num; + if (copy > ao_lisp_frame_num(frame)) + copy = ao_lisp_frame_num(frame); memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); - new->next = frame->next; + new->prev = frame->prev; + ao_lisp_frame_free(frame); return new; } @@ -210,7 +241,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); if (frame) { - f = frame->num; + f = ao_lisp_frame_num(frame); frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 0dd8c698..8b761714 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -94,7 +94,7 @@ ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) lambda->type = AO_LISP_LAMBDA; lambda->args = args; lambda->code = ao_lisp_cons_poly(code); - lambda->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); DBG_STACK(); return ao_lisp_lambda_poly(lambda); @@ -179,7 +179,7 @@ ao_lisp_lambda_eval(void) next_frame->vals[0].val = cons->cdr; break; } - next_frame->next = lambda->frame; + next_frame->prev = lambda->frame; DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); ao_lisp_frame_current = next_frame; ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index e7ece960..7e7464c4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -214,8 +214,16 @@ static const struct ao_lisp_root ao_lisp_root[] = { static const void ** const ao_lisp_cache[] = { (const void **) &ao_lisp_cons_free_list, (const void **) &ao_lisp_stack_free_list, + (const void **) &ao_lisp_frame_free_list[0], + (const void **) &ao_lisp_frame_free_list[1], + (const void **) &ao_lisp_frame_free_list[2], + (const void **) &ao_lisp_frame_free_list[3], }; +#if AO_LISP_FRAME_FREE != 4 +#error Unexpected AO_LISP_FRAME_FREE value +#endif + #define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) #define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) -- cgit v1.2.3 From 1a00bf4ac12a6505d4b23d94e99b4b46bf679020 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 15 Nov 2016 20:21:47 -0800 Subject: altos/lisp: Allow macro/nlambda/lexpr to have multiple args Entries from the params are bound to the formals with whatever remaining formals there are bound to the last argument as a list. This makes writing functions a bit easier. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_lambda.c | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 8b761714..186236f6 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -134,6 +134,8 @@ ao_lisp_lambda_eval(void) struct ao_lisp_frame *next_frame; int args_wanted; int args_provided; + int f; + struct ao_lisp_cons *vals DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); @@ -141,12 +143,14 @@ ao_lisp_lambda_eval(void) /* Create a frame to hold the variables */ - if (lambda->args == AO_LISP_FUNC_LAMBDA) - args_provided = ao_lisp_cons_length(cons) - 1; - else - args_provided = 1; - if (args_wanted != args_provided) - return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + args_provided = ao_lisp_cons_length(cons) - 1; + if (lambda->args == AO_LISP_FUNC_LAMBDA) { + if (args_wanted != args_provided) + return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); + } else { + if (args_provided < args_wanted - 1) + return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); + } next_frame = ao_lisp_frame_new(args_wanted); @@ -155,12 +159,10 @@ ao_lisp_lambda_eval(void) cons = ao_lisp_poly_cons(ao_lisp_stack->values); code = ao_lisp_poly_cons(lambda->code); args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + vals = ao_lisp_poly_cons(cons->cdr); switch (lambda->args) { - case AO_LISP_FUNC_LAMBDA: { - int f; - struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); - + case AO_LISP_FUNC_LAMBDA: for (f = 0; f < args_wanted; f++) { DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); next_frame->vals[f].atom = args->car; @@ -170,13 +172,19 @@ ao_lisp_lambda_eval(void) } ao_lisp_cons_free(cons); break; - } case AO_LISP_FUNC_LEXPR: case AO_LISP_FUNC_NLAMBDA: case AO_LISP_FUNC_MACRO: - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(cons->cdr); DBG("\n"); - next_frame->vals[0].atom = args->car; - next_frame->vals[0].val = cons->cdr; + for (f = 0; f < args_wanted - 1; f++) { + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = vals->car; + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(); DBG("\n"); + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = ao_lisp_cons_poly(vals); break; } next_frame->prev = lambda->frame; -- cgit v1.2.3 From eaa528e4e62ba1d9765888760d387303487b2e01 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 17 Nov 2016 16:08:15 -0800 Subject: altos/lisp: Make lambda, cond and while all have implicit progns This lets all of these execute more than one sexpr, returning the value of the last. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_eval.c | 26 +++++++++++++++----------- src/lisp/ao_lisp_lambda.c | 22 ++++++++++++++-------- 2 files changed, 29 insertions(+), 19 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 6f56a120..5fa9e0ad 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -310,7 +310,6 @@ ao_lisp_eval_formal(void) * value and re-evaluate it */ prev = ao_lisp_poly_stack(ao_lisp_stack->prev); - ao_lisp_stack->state = eval_sexpr; ao_lisp_stack->sexprs = prev->sexprs; DBGI(".. start macro\n"); @@ -401,10 +400,11 @@ ao_lisp_eval_exec(void) DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; case AO_LISP_LAMBDA: - ao_lisp_stack->state = eval_sexpr; DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_v = ao_lisp_lambda_eval(); - DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_stack->state = eval_progn; + v = ao_lisp_lambda_eval(); + ao_lisp_stack->sexprs = v; + DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; } @@ -442,7 +442,6 @@ ao_lisp_eval_cond(void) ao_lisp_stack->state = eval_cond_test; if (!ao_lisp_stack_push()) return 0; - ao_lisp_stack->state = eval_sexpr; } return 1; } @@ -464,11 +463,11 @@ ao_lisp_eval_cond_test(void) DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); if (ao_lisp_v) { struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); - struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); + ao_poly c = car->cdr; if (c) { - ao_lisp_stack->state = eval_sexpr; - ao_lisp_v = c->car; + ao_lisp_stack->state = eval_progn; + ao_lisp_stack->sexprs = c; } else ao_lisp_stack->state = eval_val; } else { @@ -502,6 +501,10 @@ ao_lisp_eval_progn(void) } else { ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + + /* If there are more sexprs to do, then come back here, otherwise + * return the value of the last one by just landing in eval_sexpr + */ if (ao_lisp_stack->sexprs) { ao_lisp_stack->state = eval_progn; if (!ao_lisp_stack_push()) @@ -530,7 +533,6 @@ ao_lisp_eval_while(void) ao_lisp_stack->state = eval_while_test; if (!ao_lisp_stack_push()) return 0; - ao_lisp_stack->state = eval_sexpr; } return 1; } @@ -547,11 +549,11 @@ ao_lisp_eval_while_test(void) if (ao_lisp_v) { ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - if (ao_lisp_v) - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; ao_lisp_stack->state = eval_while; if (!ao_lisp_stack_push()) return 0; + ao_lisp_stack->state = eval_progn; + ao_lisp_stack->sexprs = ao_lisp_v; } else ao_lisp_stack->state = eval_val; @@ -567,6 +569,8 @@ ao_lisp_eval_macro(void) { DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + if (ao_lisp_v == AO_LISP_NIL) + ao_lisp_abort(); if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { *ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); ao_lisp_v = ao_lisp_stack->sexprs; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 186236f6..e2053a6f 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -78,8 +78,9 @@ ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) if (!lambda) return AO_LISP_NIL; - if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, code, 2, 2)) - return AO_LISP_NIL; + if (!code->cdr) + return ao_lisp_error(AO_LISP_INVALID, "missing parameters to lambda"); + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; f = 0; @@ -135,7 +136,7 @@ ao_lisp_lambda_eval(void) int args_wanted; int args_provided; int f; - struct ao_lisp_cons *vals + struct ao_lisp_cons *vals; DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); @@ -161,6 +162,10 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); vals = ao_lisp_poly_cons(cons->cdr); + next_frame->prev = lambda->frame; + ao_lisp_frame_current = next_frame; + ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + switch (lambda->args) { case AO_LISP_FUNC_LAMBDA: for (f = 0; f < args_wanted; f++) { @@ -171,6 +176,7 @@ ao_lisp_lambda_eval(void) vals = ao_lisp_poly_cons(vals->cdr); } ao_lisp_cons_free(cons); + cons = NULL; break; case AO_LISP_FUNC_LEXPR: case AO_LISP_FUNC_NLAMBDA: @@ -182,15 +188,15 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(); DBG("\n"); + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); next_frame->vals[f].atom = args->car; next_frame->vals[f].val = ao_lisp_cons_poly(vals); break; + default: + break; } - next_frame->prev = lambda->frame; DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); - ao_lisp_frame_current = next_frame; - ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); DBG_STACK(); - return ao_lisp_arg(code, 1); + DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); + return code->cdr; } -- cgit v1.2.3 From e600fc409c577eec02af612a36431c477a9c875e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 19:04:05 -0800 Subject: altos/lisp: Add continuations This provides call/cc and makes 'stacks' visible to the application. Signed-off-by: Keith Packard --- src/lisp/Makefile | 1 + src/lisp/ao_lisp.h | 77 +++++++++--- src/lisp/ao_lisp_builtin.c | 6 +- src/lisp/ao_lisp_error.c | 82 +++++-------- src/lisp/ao_lisp_eval.c | 151 ++++------------------- src/lisp/ao_lisp_frame.c | 44 ++++--- src/lisp/ao_lisp_lambda.c | 3 +- src/lisp/ao_lisp_make_const.c | 3 +- src/lisp/ao_lisp_mem.c | 28 +++++ src/lisp/ao_lisp_poly.c | 4 + src/lisp/ao_lisp_stack.c | 279 ++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 461 insertions(+), 217 deletions(-) create mode 100644 src/lisp/ao_lisp_stack.c (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 15297999..dd5a0cb4 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -21,6 +21,7 @@ SRCS=\ ao_lisp_eval.c \ ao_lisp_rep.c \ ao_lisp_save.c \ + ao_lisp_stack.c \ ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index bcefbabf..a8e1715a 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -75,6 +75,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_eof _atom("eof") #define _ao_lisp_atom_save _atom("save") #define _ao_lisp_atom_restore _atom("restore") +#define _ao_lisp_atom_call2fcc _atom("call/cc") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -99,7 +100,11 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA]; #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 #define AO_LISP_LAMBDA 7 -#define AO_LISP_NUM_TYPE 8 +#define AO_LISP_STACK 8 +#define AO_LISP_NUM_TYPE 9 + +/* Leave two bits for types to use as they please */ +#define AO_LISP_OTHER_TYPE_MASK 0x3f #define AO_LISP_NIL 0 @@ -153,22 +158,17 @@ struct ao_lisp_val { struct ao_lisp_frame { uint8_t type; - uint8_t _num; + uint8_t num; ao_poly prev; struct ao_lisp_val vals[]; }; -#define AO_LISP_FRAME_NUM_MASK 0x7f - -/* Set when the frame escapes the lambda */ +/* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 - -static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_NUM_MASK; -} +#define AO_LISP_FRAME_PRINT 0x40 static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_MARK; + return f->type & AO_LISP_FRAME_MARK; } static inline struct ao_lisp_frame * @@ -195,6 +195,7 @@ enum eval_state { }; struct ao_lisp_stack { + uint8_t type; /* AO_LISP_STACK */ uint8_t state; /* enum eval_state */ ao_poly prev; /* previous stack frame */ ao_poly sexprs; /* expressions to evaluate */ @@ -204,6 +205,17 @@ struct ao_lisp_stack { ao_poly list; /* most recent function call */ }; +#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { + return s->type & AO_LISP_STACK_MARK; +} + +static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { + s->type |= AO_LISP_STACK_MARK; +} + static inline struct ao_lisp_stack * ao_lisp_poly_stack(ao_poly p) { @@ -216,8 +228,6 @@ ao_lisp_stack_poly(struct ao_lisp_stack *stack) return ao_lisp_poly(stack, AO_LISP_OTHER); } -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 @@ -276,6 +286,7 @@ enum ao_lisp_builtin_id { builtin_led, builtin_save, builtin_restore, + builtin_call_cc, _builtin_last }; @@ -315,7 +326,7 @@ ao_lisp_poly_other(ao_poly poly) { static inline uint8_t ao_lisp_other_type(void *other) { - return *((uint8_t *) other); + return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; } static inline ao_poly @@ -455,6 +466,12 @@ ao_lisp_string_stash(int id, char *string); char * ao_lisp_string_fetch(int id); +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack); + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id); + void ao_lisp_poly_stash(int id, ao_poly poly); @@ -617,6 +634,8 @@ ao_lisp_frame_print(ao_poly p); /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; +extern const char *ao_lisp_state_names[]; + struct ao_lisp_lambda * ao_lisp_lambda_new(ao_poly cons); @@ -646,12 +665,40 @@ ao_lisp_save(struct ao_lisp_cons *cons); ao_poly ao_lisp_restore(struct ao_lisp_cons *cons); -/* error */ +/* stack */ extern const struct ao_lisp_type ao_lisp_stack_type; +extern struct ao_lisp_stack *ao_lisp_stack; +extern struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack); + +int +ao_lisp_stack_push(void); + +void +ao_lisp_stack_pop(void); + +void +ao_lisp_stack_clear(void); + +void +ao_lisp_stack_print(ao_poly stack); + +ao_poly +ao_lisp_stack_eval(void); + +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons); + +/* error */ + +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); void -ao_lisp_stack_print(void); +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); ao_poly ao_lisp_error(int error, char *format, ...); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6cbcb92c..4c845307 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -86,6 +86,7 @@ static const ao_poly builtin_names[] = { [builtin_led] = _ao_lisp_atom_led, [builtin_save] = _ao_lisp_atom_save, [builtin_restore] = _ao_lisp_atom_restore, + [builtin_call_cc] = _ao_lisp_atom_call2fcc, }; @@ -117,9 +118,7 @@ void ao_lisp_builtin_print(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("[builtin %s %s]", - ao_lisp_args_name(builtin->args), - ao_lisp_builtin_name(builtin->func)); + printf("%s", ao_lisp_builtin_name(builtin->func)); } ao_poly @@ -599,5 +598,6 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_delay] = ao_lisp_delay, [builtin_save] = ao_lisp_save, [builtin_restore] = ao_lisp_restore, + [builtin_call_cc] = ao_lisp_call_cc, }; diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 937739e9..54a9be10 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -15,23 +15,24 @@ #include "ao_lisp.h" #include -static void -ao_lisp_error_poly(char *name, ao_poly poly) +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) { int first = 1; printf("\t\t%s(", name); if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); - - if (cons) { - while (cons) { + if (poly) { + while (poly) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); if (!first) printf("\t\t "); else first = 0; ao_lisp_poly_print(cons->car); printf("\n"); - cons = ao_lisp_poly_cons(cons->cdr); + if (poly == last) + break; + poly = cons->cdr; } printf("\t\t )\n"); } else @@ -48,7 +49,7 @@ static void tabs(int indent) printf("\t"); } -static void +void ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) { int f; @@ -56,51 +57,30 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) { - tabs(indent); - printf(" "); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + printf("\n"); } - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); - printf("\n"); + if (frame->prev) + ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - } - tabs(indent); - printf(" }\n"); + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); } -static const char *state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", -}; - -void -ao_lisp_stack_print(void) -{ - struct ao_lisp_stack *s; - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); - printf("Stack:\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); - printf("\t\tstate: %s\n", state_names[s->state]); -// printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); - ao_lisp_error_poly ("sexprs: ", s->sexprs); - ao_lisp_error_poly ("values: ", s->values); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); -// ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); - printf("\t]\n"); - } -} ao_poly ao_lisp_error(int error, char *format, ...) @@ -112,7 +92,9 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); - ao_lisp_stack_print(); + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Stack:\n"); + ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); printf("Globals:\n\t"); ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); printf("\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index ef521605..2460a32a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -16,68 +16,9 @@ #include "ao_lisp.h" #include -const struct ao_lisp_type ao_lisp_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_lisp_stack *stack = addr; - for (;;) { - ao_lisp_poly_mark(stack->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; -struct ao_lisp_stack *ao_lisp_stack_free_list; - ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -86,72 +27,6 @@ ao_lisp_set_cond(struct ao_lisp_cons *c) return AO_LISP_NIL; } -static void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - - -static int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack; - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - } - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - ao_lisp_stack = stack; - ao_lisp_stack_reset(stack); - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -static void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -static void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - static int func_type(ao_poly func) { @@ -162,6 +37,8 @@ func_type(ao_poly func) return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; case AO_LISP_LAMBDA: return ao_lisp_poly_lambda(func)->args; + case AO_LISP_STACK: + return AO_LISP_FUNC_LAMBDA; default: ao_lisp_error(AO_LISP_INVALID, "not a func"); return -1; @@ -392,10 +269,12 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS) + if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; @@ -404,12 +283,18 @@ ao_lisp_eval_exec(void) ao_lisp_stack->state = eval_progn; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; + case AO_LISP_STACK: + DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_v = ao_lisp_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + break; } - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; return 1; } @@ -599,6 +484,16 @@ static int (*const evals[])(void) = { [eval_macro] = ao_lisp_eval_macro, }; +const char *ao_lisp_state_names[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", + "progn", +}; + /* * Called at restore time to reset all execution state */ diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 9d17f6fa..17fa141a 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -24,7 +24,7 @@ static int frame_size(void *addr) { struct ao_lisp_frame *frame = addr; - return frame_num_size(ao_lisp_frame_num(frame)); + return frame_num_size(frame->num); } static void @@ -37,7 +37,7 @@ frame_mark(void *addr) MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); @@ -68,7 +68,7 @@ frame_move(void *addr) MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); @@ -109,15 +109,21 @@ ao_lisp_frame_print(ao_poly p) printf ("{"); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + } + if (frame->prev) + ao_lisp_poly_print(frame->prev); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_poly_print(frame->prev); } printf("}"); } @@ -126,7 +132,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; - for (f = 0; f < ao_lisp_frame_num(frame); f++) + for (f = 0; f < frame->num; f++) if (frame->vals[f].atom == atom) return &frame->vals[f].val; return NULL; @@ -175,7 +181,7 @@ ao_lisp_frame_new(int num) return NULL; } frame->type = AO_LISP_FRAME; - frame->_num = num; + frame->num = num; frame->prev = AO_LISP_NIL; memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); return frame; @@ -186,7 +192,7 @@ ao_lisp_frame_mark(struct ao_lisp_frame *frame) { if (!frame) return AO_LISP_NIL; - frame->_num |= AO_LISP_FRAME_MARK; + frame->type |= AO_LISP_FRAME_MARK; return ao_lisp_frame_poly(frame); } @@ -194,7 +200,7 @@ void ao_lisp_frame_free(struct ao_lisp_frame *frame) { if (!ao_lisp_frame_marked(frame)) { - int num = ao_lisp_frame_num(frame); + int num = frame->num; if (num < AO_LISP_FRAME_FREE) { frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); ao_lisp_frame_free_list[num] = frame; @@ -209,7 +215,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) struct ao_lisp_frame *new; int copy; - if (new_num == ao_lisp_frame_num(frame)) + if (new_num == frame->num) return frame; new = ao_lisp_frame_new(new_num); if (!new) @@ -220,8 +226,8 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) */ frame = *frame_ref; copy = new_num; - if (copy > ao_lisp_frame_num(frame)) - copy = ao_lisp_frame_num(frame); + if (copy > frame->num) + copy = frame->num; memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); new->prev = frame->prev; ao_lisp_frame_free(frame); @@ -239,7 +245,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); if (frame) { - f = ao_lisp_frame_num(frame); + f = frame->num; frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index e2053a6f..656936cb 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -175,7 +175,8 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } - ao_lisp_cons_free(cons); + if (!ao_lisp_stack_marked(ao_lisp_stack)) + ao_lisp_cons_free(cons); cons = NULL; break; case AO_LISP_FUNC_LEXPR: diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 495e48cd..de9c5725 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -71,6 +71,7 @@ struct builtin_func funcs[] = { { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, + { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) @@ -358,7 +359,7 @@ main(int argc, char **argv) /* Reduce to referenced values */ ao_lisp_collect(AO_LISP_COLLECT_FULL); - for (f = 0; f < ao_lisp_frame_num(ao_lisp_frame_global); f++) { + for (f = 0; f < ao_lisp_frame_global->num; f++) { val = ao_has_macro(ao_lisp_frame_global->vals[f].val); if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 12a5ba55..0dfad1d7 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -144,6 +144,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; +static struct ao_lisp_stack *save_stack[3]; static ao_poly save_poly[2]; static const struct ao_lisp_root ao_lisp_root[] = { @@ -155,6 +156,18 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_cons_type, .addr = (void **) &save_cons[1], }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[0] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[1] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[2] + }, { .type = &ao_lisp_string_type, .addr = (void **) &save_string[0] @@ -434,6 +447,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, + [AO_LISP_STACK] = &ao_lisp_stack_type, }; static int @@ -818,6 +832,20 @@ ao_lisp_cons_fetch(int id) return cons; } +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) +{ + save_stack[id] = stack; +} + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id) +{ + struct ao_lisp_stack *stack = save_stack[id]; + save_stack[id] = NULL; + return stack; +} + void ao_lisp_string_stash(int id, char *string) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 236176e7..800ee06d 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -54,6 +54,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .print = ao_lisp_lambda_print, .patom = ao_lisp_lambda_print, }, + [AO_LISP_STACK] = { + .print = ao_lisp_stack_print, + .patom = ao_lisp_stack_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c new file mode 100644 index 00000000..9c773e83 --- /dev/null +++ b/src/lisp/ao_lisp_stack.c @@ -0,0 +1,279 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define DBG_EVAL 0 +#include "ao_lisp.h" + +const struct ao_lisp_type ao_lisp_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_lisp_stack *stack = addr; + for (;;) { + ao_lisp_poly_mark(stack->sexprs, 0); + ao_lisp_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_lisp_poly_mark(stack->frame, 0); + ao_lisp_poly_mark(stack->list, 0); + stack = ao_lisp_poly_stack(stack->prev); + if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + while (stack) { + struct ao_lisp_stack *prev; + int ret; + (void) ao_lisp_poly_move(&stack->sexprs, 0); + (void) ao_lisp_poly_move(&stack->values, 0); + (void) ao_lisp_poly_move(&stack->values_tail, 0); + (void) ao_lisp_poly_move(&stack->frame, 0); + (void) ao_lisp_poly_move(&stack->list, 0); + prev = ao_lisp_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); + if (prev != ao_lisp_poly_stack(stack->prev)) + stack->prev = ao_lisp_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_LISP_NIL; + stack->values = AO_LISP_NIL; + stack->values_tail = AO_LISP_NIL; +} + +static struct ao_lisp_stack * +ao_lisp_stack_new(void) +{ + struct ao_lisp_stack *stack; + + if (ao_lisp_stack_free_list) { + stack = ao_lisp_stack_free_list; + ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); + } else { + stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!stack) + return 0; + stack->type = AO_LISP_STACK; + } + ao_lisp_stack_reset(stack); + return stack; +} + +int +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *stack = ao_lisp_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_lisp_stack_poly(ao_lisp_stack); + stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack->list = AO_LISP_NIL; + + ao_lisp_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_lisp_stack_pop(void) +{ + ao_poly prev; + struct ao_lisp_frame *prev_frame; + + if (!ao_lisp_stack) + return; + prev = ao_lisp_stack->prev; + if (!ao_lisp_stack_marked(ao_lisp_stack)) { + ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); + ao_lisp_stack_free_list = ao_lisp_stack; + } + + ao_lisp_stack = ao_lisp_poly_stack(prev); + prev_frame = ao_lisp_frame_current; + if (ao_lisp_stack) + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + else + ao_lisp_frame_current = NULL; + if (ao_lisp_frame_current != prev_frame) + ao_lisp_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_lisp_stack_clear(void) +{ + ao_lisp_stack = NULL; + ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; +} + +void +ao_lisp_stack_print(ao_poly poly) +{ + struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); + + if (s->type & AO_LISP_STACK_PRINT) { + printf("[recurse...]"); + return; + } + while (s) { + s->type |= AO_LISP_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); + ao_lisp_error_poly ("values: ", s->values, s->values_tail); + ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); + ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_LISP_STACK_PRINT; + s = ao_lisp_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_lisp_stack * +ao_lisp_stack_copy(struct ao_lisp_stack *old) +{ + struct ao_lisp_stack *new = NULL; + struct ao_lisp_stack *n, *prev = NULL; + + while (old) { + ao_lisp_stack_stash(0, old); + ao_lisp_stack_stash(1, new); + ao_lisp_stack_stash(2, prev); + n = ao_lisp_stack_new(); + prev = ao_lisp_stack_fetch(2); + new = ao_lisp_stack_fetch(1); + old = ao_lisp_stack_fetch(0); + if (!n) + return NULL; + + ao_lisp_stack_mark(old); + ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_lisp_stack_poly(n); + else + new = n; + prev = n; + + old = ao_lisp_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_lisp_stack_eval(void) +{ + struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); + if (!new) + return AO_LISP_NIL; + + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + + if (!cons || !cons->cdr) + return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_lisp_stack = new; + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + + return ao_lisp_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons) +{ + struct ao_lisp_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) + return AO_LISP_NIL; + + /* go get the lambda */ + ao_lisp_v = ao_lisp_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_lisp_stack_copy(ao_lisp_stack); + if (!new) + return AO_LISP_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_lisp_stack_poly(new); + cons->cdr = AO_LISP_NIL; + v = ao_lisp_lambda_eval(); + ao_lisp_stack->sexprs = v; + ao_lisp_stack->state = eval_progn; + return AO_LISP_NIL; +} -- cgit v1.2.3 From 4c812b8c903bd7e689572f8800ecc092af9cfe18 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 21:12:50 -0800 Subject: altos/lisp: Make DBG settings global This avoids having different values in different files, which wasn't useful. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 8 +++++++- src/lisp/ao_lisp_eval.c | 1 - src/lisp/ao_lisp_lambda.c | 1 - 3 files changed, 7 insertions(+), 3 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a8e1715a..cea834fc 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,6 +15,9 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ +#define DBG_MEM 0 +#define DBG_EVAL 0 + #include #include //#include @@ -326,6 +329,10 @@ ao_lisp_poly_other(ao_poly poly) { static inline uint8_t ao_lisp_other_type(void *other) { +#if DBG_MEM + if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) + ao_lisp_abort(); +#endif return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; } @@ -743,7 +750,6 @@ ao_lisp_frames_dump(void) #define DBG_FRAMES() #endif -#define DBG_MEM 0 #define DBG_MEM_START 1 #if DBG_MEM diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 2460a32a..3be7c9c4 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,7 +12,6 @@ * General Public License for more details. */ -#define DBG_EVAL 0 #include "ao_lisp.h" #include diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 656936cb..67ad24ee 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -15,7 +15,6 @@ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. */ -#define DBG_EVAL 0 #include "ao_lisp.h" int -- cgit v1.2.3 From 85db6d68a273859482e036b60fec7e2b84e9c262 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 21:15:33 -0800 Subject: altos/lisp: Empty lambda body is not an error It's not very exciting, but it's still legal Signed-off-by: Keith Packard --- src/lisp/ao_lisp_lambda.c | 3 --- 1 file changed, 3 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 67ad24ee..b164cd66 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -77,9 +77,6 @@ ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) if (!lambda) return AO_LISP_NIL; - if (!code->cdr) - return ao_lisp_error(AO_LISP_INVALID, "missing parameters to lambda"); - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; f = 0; -- cgit v1.2.3 From c3a4d7721f0f5d082336b8cc9c9d765ad2f7d17e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 22:41:46 -0800 Subject: altos/lisp: Sort frames by atom Fortunately, the collector always retains the relative order between addresses, so we can sort based on the atom address itself. This reduces the time spent looking for names in larger (e.g. global) frames. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 5 ++++- src/lisp/ao_lisp_frame.c | 51 +++++++++++++++++++++++++++++++++++++---------- src/lisp/ao_lisp_lambda.c | 9 +++------ src/lisp/ao_lisp_mem.c | 4 +++- 4 files changed, 50 insertions(+), 19 deletions(-) (limited to 'src/lisp/ao_lisp_lambda.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index af6ff8bb..1f7c85e1 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -621,7 +621,7 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; -#define AO_LISP_FRAME_FREE 4 +#define AO_LISP_FRAME_FREE 6 extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; @@ -637,6 +637,9 @@ ao_lisp_frame_new(int num); void ao_lisp_frame_free(struct ao_lisp_frame *frame); +void +ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); + int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 17fa141a..05f6d253 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -128,14 +128,32 @@ ao_lisp_frame_print(ao_poly p) printf("}"); } +static int +ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) +{ + int l = 0; + int r = top - 1; + while (l <= r) { + int m = (l + r) >> 1; + if (frame->vals[m].atom < atom) + l = m + 1; + else + r = m - 1; + } + return l; +} + ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { - int f; - for (f = 0; f < frame->num; f++) - if (frame->vals[f].atom == atom) - return &frame->vals[f].val; - return NULL; + int l = ao_lisp_frame_find(frame, frame->num, atom); + + if (l >= frame->num) + return NULL; + + if (frame->vals[l].atom != atom) + return NULL; + return &frame->vals[l].val; } int @@ -234,6 +252,18 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) return new; } +void +ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) +{ + int l = ao_lisp_frame_find(frame, num, atom); + + memmove(&frame->vals[l+1], + &frame->vals[l], + (num - l) * sizeof (struct ao_lisp_val)); + frame->vals[l].atom = atom; + frame->vals[l].val = val; +} + int ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) { @@ -251,14 +281,13 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) f = 0; frame = ao_lisp_frame_new(1); } - atom = ao_lisp_poly_fetch(0); - val = ao_lisp_poly_fetch(1); if (!frame) return 0; *frame_ref = frame; - frame->vals[f].atom = atom; - ref = &frame->vals[f].val; - } - *ref = val; + atom = ao_lisp_poly_fetch(0); + val = ao_lisp_poly_fetch(1); + ao_lisp_frame_bind(frame, frame->num - 1, atom, val); + } else + *ref = val; return 1; } diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index b164cd66..526863c5 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -166,8 +166,7 @@ ao_lisp_lambda_eval(void) case AO_LISP_FUNC_LAMBDA: for (f = 0; f < args_wanted; f++) { DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = vals->car; + ao_lisp_frame_bind(next_frame, f, args->car, vals->car); args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } @@ -180,14 +179,12 @@ ao_lisp_lambda_eval(void) case AO_LISP_FUNC_MACRO: for (f = 0; f < args_wanted - 1; f++) { DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = vals->car; + ao_lisp_frame_bind(next_frame, f, args->car, vals->car); args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = ao_lisp_cons_poly(vals); + ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); break; default: break; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index e8907cf6..1f09ede8 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -218,9 +218,11 @@ static const void ** const ao_lisp_cache[] = { (const void **) &ao_lisp_frame_free_list[1], (const void **) &ao_lisp_frame_free_list[2], (const void **) &ao_lisp_frame_free_list[3], + (const void **) &ao_lisp_frame_free_list[4], + (const void **) &ao_lisp_frame_free_list[5], }; -#if AO_LISP_FRAME_FREE != 4 +#if AO_LISP_FRAME_FREE != 6 #error Unexpected AO_LISP_FRAME_FREE value #endif -- cgit v1.2.3