diff --git a/src/base.c b/src/base.c index ab2aa69..84c260a 100644 --- a/src/base.c +++ b/src/base.c @@ -37,7 +37,7 @@ void *lisp_alloc_object(size_t size, LispValType type) { lisp_gc_yield(NULL, false); } if (the_stack.depth > 0) { - add_local_reference_no_recurse(obj); + add_local_reference_no_recurse(LISP_STACK_REF(), obj); } lisp_gc_register_object(obj); return obj; @@ -74,6 +74,9 @@ noreturn void signal_type_error(LispVal *obj, LispVal *typespec) { DEFINE_SYMBOL(nil, "nil"); DEFINE_SYMBOL(t, "t"); DEFINE_SYMBOL(unbound, "unbound"); +DEFINE_SYMBOL(lexical_environment, "lexical-environment"); + +LispVal *Vlexical_environment; DEFUN(id, "id", (LispVal * obj), "(id)", "") { // TODO not all values are handled here diff --git a/src/base.h b/src/base.h index 19f2e10..51f99de 100644 --- a/src/base.h +++ b/src/base.h @@ -278,6 +278,9 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, { DECLARE_SYMBOL(nil); DECLARE_SYMBOL(t); DECLARE_SYMBOL(unbound); +DECLARE_SYMBOL(lexical_environment); + +extern LispVal *Vlexical_environment; static ALWAYS_INLINE bool NILP(LispVal *val) { return val == Qnil; @@ -302,6 +305,16 @@ DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist)); DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def)); DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val)); +static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) { + assert(SYMBOLP(sym)); + return ((LispSymbol *) sym)->value; +} + +static ALWAYS_INLINE void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) { + assert(SYMBOLP(sym)); + ((LispSymbol *) sym)->value = value; +} + // condition stuff DECLARE_SYMBOL(condition_class); DECLARE_FUNCTION(condition_class_p, (LispVal * val)); diff --git a/src/function.c b/src/function.c index 868f679..6720459 100644 --- a/src/function.c +++ b/src/function.c @@ -240,10 +240,10 @@ static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) { LispVal *end; DOLIST(arg, args) { if (NILP(start)) { - start = CONS(Feval(arg, PARENT_LEXENV()), Qnil); + start = CONS(Feval(arg, Vlexical_environment), Qnil); end = start; } else { - RPLACD(end, CONS(Feval(arg, PARENT_LEXENV()), Qnil)); + RPLACD(end, CONS(Feval(arg, Vlexical_environment), Qnil)); end = XCDR(end); } } @@ -330,11 +330,12 @@ process_complex_native_args(LispFunction *fobj, LispVal *args, static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) { - push_stack_frame(orig_func, fobj, args); + StackFrame *stack_ref = LISP_STACK_REF(); + push_call_frame(orig_func, fobj, args); if (!fobj->impl.native.no_eval_args) { args = evaluate_function_arguments(args); } - set_stack_evaluated_args(args); + set_stack_evaluated_args(LISP_STACK_REF(), args); LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL}; size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj); intptr_t rest_idx; @@ -351,7 +352,7 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, if (!arg_arr[i]) { arg_arr[i] = Qnil; } - add_local_reference(arg_arr[i]); + add_local_reference(LISP_STACK_REF(), arg_arr[i]); } LispVal *retval; switch (count) { @@ -380,8 +381,8 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, abort(); } the_stack.nogc_retval = retval; - pop_stack_frame(); - add_local_reference(the_stack.nogc_retval); + unwind_to(stack_ref); + add_local_reference(LISP_STACK_REF(), the_stack.nogc_retval); return retval; } @@ -395,7 +396,7 @@ static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec, static ALWAYS_INLINE void push_missing_optional_argument_to_lexenv(LispVal *spec) { - new_lexical_variable(XCAR(spec), Feval(SECOND(spec), TOP_LEXENV())); + new_lexical_variable(XCAR(spec), Feval(SECOND(spec), Vlexical_environment)); if (!NILP(THIRD(spec))) { new_lexical_variable(THIRD(spec), Qnil); } @@ -403,7 +404,6 @@ push_missing_optional_argument_to_lexenv(LispVal *spec) { static ALWAYS_INLINE enum ProcessArgsResult push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) { - LISP_STACK_TOP()->lexenv = fobj->impl.interp.lexenv; LispVal *rem_req = fobj->args.req; LispVal *rem_opt = fobj->args.opt; while (!NILP(rem_req)) { @@ -459,10 +459,13 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) { static ALWAYS_INLINE LispVal * call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) { - push_stack_frame(orig_func, fobj, args); + StackFrame *stack_ref = LISP_STACK_REF(); + push_call_frame(orig_func, fobj, args); LispVal *evaled_args = evaluate_function_arguments(args); - set_stack_evaluated_args(evaled_args); - enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, args); + set_stack_evaluated_args(LISP_STACK_REF(), evaled_args); + push_dynamic_binding(Qlexical_environment, fobj->impl.interp.lexenv); + enum ProcessArgsResult par = + push_interpreted_args_to_lexenv(fobj, evaled_args); if (par != PROCESS_ARGS_OK) { // TODO better error handling fprintf(stderr, "Bad args to interp func: %s\n", @@ -471,8 +474,8 @@ call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) { } LispVal *rval = Fprogn(fobj->impl.interp.body); the_stack.nogc_retval = rval; - pop_stack_frame(); - add_local_reference(rval); + unwind_to(stack_ref); + add_local_reference(LISP_STACK_REF(), rval); return rval; } @@ -482,10 +485,11 @@ DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", if (SYMBOLP(func)) { fobj = Fsymbol_function(func, Qt); } else if (CONSP(func) && EQ(XCAR(func), Qlambda)) { - fobj = Feval(func, TOP_LEXENV()); + fobj = Feval(func, Vlexical_environment); } // include symbol here for the error message CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL); + assert(FUNCTIONP(fobj)); switch (fobj->type) { case FUNCTION_NATIVE: return call_native(func, fobj, args); @@ -542,7 +546,7 @@ DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body), } body = parse_lambda_declare_form(fobj, body); fobj->impl.interp.body = body; - fobj->impl.interp.lexenv = PARENT_LEXENV(); + fobj->impl.interp.lexenv = Vlexical_environment; return fobj; } diff --git a/src/gc.c b/src/gc.c index 448b6f2..9ccfa63 100644 --- a/src/gc.c +++ b/src/gc.c @@ -285,13 +285,30 @@ static void mark_stack_local_refs(struct LocalReferences *restrict refs, saturating_dec(limit, refs->num_refs); } -static void mark_stack_frame(struct StackFrame *frame, size_t *restrict limit) { - mark_object(frame->name); - mark_object(frame->args); - mark_object(frame->fobj); - mark_object(frame->lexenv); - saturating_dec(limit, 4); - mark_stack_local_refs(&frame->local_refs, limit); +static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) { + switch (frame->kind) { + case STACK_FRAME_LOCAL_REFERENCES: + mark_stack_local_refs(&frame->local_references, limit); + break; + case STACK_FRAME_CALL: + mark_object(frame->call.name); + mark_object(frame->call.args); + mark_object(frame->call.fobj); + saturating_dec(limit, 3); + break; + case STACK_FRAME_UNWIND_PROTECT: + // nothing to do + break; + case STACK_FRAME_CONDITION_CASE: + mark_object(frame->condition_case.exceptions); + saturating_dec(limit, 1); + break; + case STACK_FRAME_DYNAMIC_BINDING: + mark_object(frame->dynamic_binding.symbol); + mark_object(frame->dynamic_binding.old_value); + saturating_dec(limit, 2); + break; + } } static void mark_and_compact_the_stack(size_t *restrict limit) { @@ -306,11 +323,6 @@ static void mark_and_compact_the_stack(size_t *restrict limit) { } } if (i == the_stack.depth) { - for (; i < the_stack.first_clear_local_refs; ++i) { - compact_stack_frame(&the_stack.frames[i]); - } - the_stack.first_clear_local_refs = the_stack.depth; - // move to the next step incremental_state.step = GC_STEP_HEAP; } } @@ -402,7 +414,6 @@ void lisp_gc_yield(struct timespec *restrict time_took, bool full) { } void lisp_gc_teardown(void) { - assert(the_stack.depth == 0); while (white_objects) { free_object(white_objects->obj); } diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk index 805ca1c..4d4ec57 100644 --- a/src/gen-init-globals.awk +++ b/src/gen-init-globals.awk @@ -4,6 +4,7 @@ BEGIN { special_syms["t"] = 1 special_syms["nil"] = 1 special_syms["unbound"] = 1 + special_syms["lexical_environment"] = 1 special_syms["hash_string"] = 1 special_syms["strings_equal"] = 1 special_syms["and_rest"] = 1 diff --git a/src/lisp.c b/src/lisp.c index 2d7c6cc..dec3897 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -19,8 +19,10 @@ static void construct_manual_symbols(void) { lisp_gc_register_static_object(Qt); Qunbound = Fmake_symbol(LISP_LITSTR("unbound")); ((LispSymbol *) Qunbound)->value = Qunbound; - ((LispSymbol *) Qunbound)->value = Qunbound; lisp_gc_register_static_object(Qunbound); + Qlexical_environment = Fmake_symbol(LISP_LITSTR("lexical-environment")); + ((LispSymbol *) Qlexical_environment)->value = Qnil; + lisp_gc_register_static_object(Qlexical_environment); Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string")); lisp_gc_register_static_object(Qhash_string); @@ -41,6 +43,7 @@ static void register_manual_symbols(void) { void lisp_init(void) { construct_manual_symbols(); + Vlexical_environment = Qnil; obarray = Fmake_hash_table(Qhash_string, Qstrings_equal); lisp_gc_register_static_object(obarray); @@ -63,8 +66,8 @@ void lisp_init(void) { } void lisp_shutdown(void) { - lisp_gc_teardown(); lisp_teardown_stack(); + lisp_gc_teardown(); } static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) { @@ -120,7 +123,7 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") { LispVal *rval = Qnil; DOLIST(form, forms) { - rval = Feval(form, TOP_LEXENV()); + rval = Feval(form, Vlexical_environment); } return rval; } @@ -128,18 +131,20 @@ DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") { DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), "(bindings &rest body)", "") { CHECK_LISTP(bindings); - copy_parent_lexenv(); + LispVal *lexenv = Vlexical_environment; DOLIST(binding, bindings) { if (SYMBOLP(binding)) { - new_lexical_variable(binding, Qnil); + lexenv = CONS(binding, CONS(Qnil, lexenv)); } else if (CONSP(binding) && list_length_eq(binding, 2)) { - new_lexical_variable(FIRST(binding), - Feval(SECOND(binding), TOP_LEXENV())); + lexenv = CONS( + FIRST(binding), + CONS(Feval(SECOND(binding), Vlexical_environment), lexenv)); } else { // TODO better error abort(); } } + push_dynamic_binding(Qlexical_environment, lexenv); return Fprogn(body); } diff --git a/src/main.c b/src/main.c index 2cb9108..81f9062 100644 --- a/src/main.c +++ b/src/main.c @@ -18,14 +18,15 @@ int main(int argc, const char **argv) { fclose(in); lisp_init(); REGISTER_GLOBAL_FUNCTION(print); - push_stack_frame(Qnil, Qnil, Qnil); + push_local_reference_frame(); + StackFrame *toplevel = LISP_STACK_REF(); ReadStream s; read_stream_init(&s, src, src_len); LispVal *r; while ((r = read(&s))) { Feval(r, Qnil); } - pop_stack_frame(); + unwind_to(toplevel); lisp_shutdown(); free(src); return 0; diff --git a/src/stack.c b/src/stack.c index 5a4f221..408f268 100644 --- a/src/stack.c +++ b/src/stack.c @@ -2,6 +2,7 @@ #include "function.h" #include "hashtable.h" +#include "list.h" #include "memory.h" #include @@ -9,51 +10,14 @@ struct LispStack the_stack; void lisp_init_stack(void) { - the_stack.max_depth = DEFAULT_MAX_LISP_EVAL_DEPTH; + the_stack.max_depth = LISP_STACK_MAX_DEPTH; the_stack.depth = 0; - the_stack.first_clear_local_refs = 0; - the_stack.frames = - lisp_malloc(sizeof(struct StackFrame) * the_stack.max_depth); - for (size_t i = 0; i < the_stack.max_depth; ++i) { - the_stack.frames[i].local_refs.num_refs = 0; - the_stack.frames[i].local_refs.num_blocks = 1; - the_stack.frames[i].local_refs.blocks = - lisp_malloc(sizeof(struct LocalReferencesBlock *)); - the_stack.frames[i].local_refs.blocks[0] = - lisp_malloc(sizeof(struct LocalReferencesBlock)); - } + the_stack.frames = lisp_malloc(sizeof(StackFrame) * the_stack.max_depth); the_stack.nogc_retval = Qnil; + the_stack.unwind_info.set = false; } -static void teardown_stack_frame(struct StackFrame *restrict frame) { - for (size_t i = 0; i < frame->local_refs.num_blocks; ++i) { - lisp_free(frame->local_refs.blocks[i]); - } - lisp_free(frame->local_refs.blocks); -} - -void lisp_teardown_stack(void) { - assert(the_stack.depth == 0); - for (size_t i = 0; i < the_stack.max_depth; ++i) { - teardown_stack_frame(&the_stack.frames[i]); - } - lisp_free(the_stack.frames); -} - -void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) { - assert(the_stack.depth < the_stack.max_depth); - struct StackFrame *frame = &the_stack.frames[the_stack.depth++]; - frame->name = name; - frame->fobj = fobj; - frame->evaled_args = false; - frame->args = args; - frame->lexenv = Qnil; - frame->local_refs.num_refs = 0; - frame->marked = false; - gc_mark_stack_for_rescan(); -} - -static void reset_local_refs(struct LocalReferences *refs) { +static void teardown_local_references(struct LocalReferences *restrict refs) { size_t last_block_size = refs->num_refs % LOCAL_REFERENCES_BLOCK_LENGTH; size_t num_full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH; for (size_t i = 0; i < num_full_blocks; ++i) { @@ -61,23 +25,125 @@ static void reset_local_refs(struct LocalReferences *refs) { assert(OBJECTP(refs->blocks[i]->refs[j])); SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[i]->refs[j], false); } + lisp_free(refs->blocks[i]); } for (size_t i = 0; i < last_block_size; ++i) { assert(OBJECTP(refs->blocks[num_full_blocks]->refs[i])); SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[num_full_blocks]->refs[i], false); } + lisp_free(refs->blocks[num_full_blocks]); + lisp_free(refs->blocks); } -void pop_stack_frame(void) { - assert(the_stack.depth > 0); - struct StackFrame *frame = &the_stack.frames[--the_stack.depth]; - reset_local_refs(&frame->local_refs); +void lisp_teardown_stack(void) { + for (size_t i = 0; i < the_stack.depth; ++i) { + if (the_stack.frames[i].kind == STACK_FRAME_LOCAL_REFERENCES) { + teardown_local_references(&the_stack.frames[i].local_references); + } + } + lisp_free(the_stack.frames); } -static void store_local_reference_in_frame(struct StackFrame *frame, - LispVal *obj) { - struct LocalReferences *refs = &frame->local_refs; +void unwind_to(StackFrame *frame) { + the_stack.unwind_info.set = true; + the_stack.unwind_info.cause = UNWIND_NORMAL; + the_stack.unwind_info.target = frame; + while (&the_stack.frames[the_stack.depth - 1] > frame) { + StackFrame *restrict top = &the_stack.frames[--the_stack.depth]; + switch (top->kind) { + case STACK_FRAME_DYNAMIC_BINDING: + if (top->dynamic_binding.symbol == Qlexical_environment) { + Vlexical_environment = top->dynamic_binding.old_value; + } else { + SET_SYMBOL_VALUE(top->dynamic_binding.symbol, + top->dynamic_binding.old_value); + } + break; + case STACK_FRAME_UNWIND_PROTECT: + longjmp(*top->unwind_protect.target, LISP_LONGJMP_FOR_UNWIND); + case STACK_FRAME_LOCAL_REFERENCES: + teardown_local_references(&top->local_references); + break; + case STACK_FRAME_CALL: + case STACK_FRAME_CONDITION_CASE: + // nothing to do + break; + } + } + the_stack.unwind_info.set = false; +} + +noreturn void continue_unwinding(void) { + assert(the_stack.unwind_info.set); + switch (the_stack.unwind_info.cause) { + case UNWIND_NORMAL: + unwind_to(the_stack.unwind_info.target); + case UNWIND_EXCEPTION: + // TODO implement + abort(); + default: + abort(); + } +} + +static ALWAYS_INLINE StackFrame *PUSH_NEW_FRAME(enum StackFrameKind kind) { + if (the_stack.depth == the_stack.max_depth) { + // TODO error + abort(); + } + StackFrame *last_refs = + the_stack.depth ? the_stack.frames[the_stack.depth - 1].last_references + : NULL; + StackFrame *frame = &the_stack.frames[the_stack.depth++]; + frame->kind = kind; + frame->marked = false; + frame->last_references = last_refs; + gc_mark_stack_for_rescan(); + return frame; +} + +void push_call_frame(LispVal *name, LispVal *fobj, LispVal *args) { + StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_CALL); + frame->call.name = name; + frame->call.fobj = fobj; + frame->call.args = args; + frame->call.evaled_args = false; +} + +void set_stack_evaluated_args(StackFrame *restrict frame, LispVal *args) { + gc_mark_stack_for_rescan(); + assert(frame->kind == STACK_FRAME_CALL); + frame->call.args = args; + frame->call.evaled_args = true; +} + +void push_unwind_protect_frame(jmp_buf *buf) { + StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_UNWIND_PROTECT); + frame->unwind_protect.target = buf; +} + +void push_condition_case_frame(jmp_buf *buf, LispVal **variable, + LispVal *exceptions) { + StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_CONDITION_CASE); + frame->condition_case.target = buf; + frame->condition_case.variable = variable; + frame->condition_case.exceptions = exceptions; + *variable = Qnil; +} + +void push_local_reference_frame(void) { + StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_LOCAL_REFERENCES); + struct LocalReferences *refs = &frame->local_references; + refs->num_refs = 0; + refs->num_blocks = 1; + refs->blocks = lisp_malloc(sizeof(struct LocalReferencesBlock *)); + refs->blocks[0] = lisp_malloc(sizeof(struct LocalReferencesBlock)); + frame->last_references = frame; +} + +static void store_local_reference_in_frame(StackFrame *frame, LispVal *obj) { + struct LocalReferences *restrict refs = &frame->local_references; size_t num_full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH; if (num_full_blocks == refs->num_blocks) { refs->blocks = @@ -87,7 +153,6 @@ static void store_local_reference_in_frame(struct StackFrame *frame, lisp_malloc(sizeof(struct LocalReferencesBlock)); refs->blocks[refs->num_blocks - 1]->refs[0] = obj; refs->num_refs += 1; - the_stack.first_clear_local_refs = the_stack.depth; } else { refs->blocks[num_full_blocks] ->refs[refs->num_refs++ % LOCAL_REFERENCES_BLOCK_LENGTH] = obj; @@ -98,72 +163,78 @@ static void store_local_reference_in_frame(struct StackFrame *frame, gc_mark_stack_for_rescan(); } -void add_local_reference_no_recurse(LispVal *obj) { - assert(the_stack.depth > 0); +void add_local_reference_no_recurse(StackFrame *restrict frame, LispVal *obj) { + frame = frame->last_references; + assert(frame->kind == STACK_FRAME_LOCAL_REFERENCES); if (OBJECTP(obj) && !OBJECT_HAS_LOCAL_REFERENCE_P(obj)) { - store_local_reference_in_frame(LISP_STACK_TOP(), obj); + store_local_reference_in_frame(frame, obj); } } -static LispVal *next_local_reference(size_t *restrict i) { - if (*i >= LISP_STACK_TOP()->local_refs.num_refs) { +static LispVal *next_local_reference(StackFrame *restrict frame, + size_t *restrict i) { + if (*i >= frame->local_references.num_refs) { return NULL; } size_t block_idx = *i / LOCAL_REFERENCES_BLOCK_LENGTH; size_t small_idx = *i % LOCAL_REFERENCES_BLOCK_LENGTH; - LispVal *obj = - LISP_STACK_TOP()->local_refs.blocks[block_idx]->refs[small_idx]; + LispVal *obj = frame->local_references.blocks[block_idx]->refs[small_idx]; ++*i; return obj; } -static inline void add_local_ref_if_not_seen_no_recurse(LispVal *seen_objs, - LispVal *obj) { +static inline void +add_local_ref_if_not_seen_no_recurse(StackFrame *restrict frame, + LispVal *seen_objs, LispVal *obj) { if (NILP(Fgethash(seen_objs, obj, Qnil))) { - add_local_reference_no_recurse(obj); + add_local_reference_no_recurse(frame, obj); Fputhash(seen_objs, obj, Qt); } } -static inline void add_local_refs_for_object_sub_vals(LispVal *seen_objs, - LispVal *val) { +static inline void +add_local_refs_for_object_sub_vals(StackFrame *restrict frame, + LispVal *seen_objs, LispVal *val) { switch (((LispObject *) val)->type) { case TYPE_CONS: - add_local_ref_if_not_seen_no_recurse(seen_objs, + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, ((LispCons *) val)->car); - add_local_ref_if_not_seen_no_recurse(seen_objs, + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, ((LispCons *) val)->cdr); break; case TYPE_SYMBOL: { LispSymbol *sym = val; - add_local_ref_if_not_seen_no_recurse(seen_objs, sym->name); - add_local_ref_if_not_seen_no_recurse(seen_objs, sym->value); - add_local_ref_if_not_seen_no_recurse(seen_objs, sym->function); - add_local_ref_if_not_seen_no_recurse(seen_objs, sym->plist); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->name); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->value); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->function); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->plist); break; } case TYPE_VECTOR: { LispVector *vec = val; for (size_t i = 0; i < vec->length; ++i) { - add_local_ref_if_not_seen_no_recurse(seen_objs, vec->data[i]); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, + vec->data[i]); } break; } case TYPE_HASH_TABLE: { HT_FOREACH_INDEX(val, i) { - add_local_ref_if_not_seen_no_recurse(seen_objs, HASH_KEY(val, i)); - add_local_ref_if_not_seen_no_recurse(seen_objs, HASH_VALUE(val, i)); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, + HASH_KEY(val, i)); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, + HASH_VALUE(val, i)); } break; } case TYPE_FUNCTION: { LispFunction *fobj = val; - add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->name); - add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->docstr); - add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.req); - add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.opt); - add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.kw); - add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->args.rest); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, fobj->name); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, fobj->docstr); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, fobj->args.req); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, fobj->args.opt); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, fobj->args.kw); + add_local_ref_if_not_seen_no_recurse(frame, seen_objs, fobj->args.rest); break; } case TYPE_STRING: @@ -176,54 +247,34 @@ static inline void add_local_refs_for_object_sub_vals(LispVal *seen_objs, } } -void add_local_reference(LispVal *obj) { - add_local_reference_no_recurse(obj); +void add_local_reference(StackFrame *restrict frame, LispVal *obj) { + frame = frame->last_references; + assert(frame->kind == STACK_FRAME_LOCAL_REFERENCES); + add_local_reference_no_recurse(frame, obj); LispVal *seen_objs = make_hash_table_no_gc(Qnil, Qnil); Fputhash(seen_objs, obj, Qt); - size_t i = LISP_STACK_TOP()->local_refs.num_refs - 1; + size_t i = frame->local_references.num_refs - 1; LispVal *cur; - while ((cur = next_local_reference(&i))) { - add_local_refs_for_object_sub_vals(seen_objs, cur); + while ((cur = next_local_reference(frame, &i))) { + add_local_refs_for_object_sub_vals(frame, seen_objs, cur); } release_hash_table_no_gc(seen_objs); } -void set_stack_evaluated_args(LispVal *args) { - assert(the_stack.depth > 0); - LISP_STACK_TOP()->evaled_args = true; - LISP_STACK_TOP()->args = args; - LISP_STACK_TOP()->marked = false; - gc_mark_stack_for_rescan(); +void push_dynamic_binding(LispVal *name, LispVal *new_value) { + assert(SYMBOLP(name)); + StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_DYNAMIC_BINDING); + frame->dynamic_binding.symbol = name; + if (name == Qlexical_environment) { + frame->dynamic_binding.old_value = Vlexical_environment; + Vlexical_environment = new_value; + } else { + frame->dynamic_binding.old_value = SYMBOL_VALUE(name); + SET_SYMBOL_VALUE(name, new_value); + } } -void compact_stack_frame(struct StackFrame *restrict frame) { - struct LocalReferences *restrict refs = &frame->local_refs; - for (size_t i = 1; i < refs->num_blocks; ++i) { - lisp_free(refs->blocks[i]); - } - refs->blocks = - lisp_realloc(refs->blocks, sizeof(struct LocalReferencesBlock *)); - refs->num_blocks = 1; -} - -bool set_lexical_variable(LispVal *name, LispVal *value, - bool create_if_absent) { - assert(the_stack.depth != 0); - DOTAILS(rest, LISP_STACK_TOP()->lexenv) { - if (EQ(XCAR(rest), name)) { - RPLACA(XCDR(rest), value); - return true; - } - } - if (create_if_absent) { - new_lexical_variable(name, value); - } - return create_if_absent; -} - -void copy_parent_lexenv(void) { - assert(the_stack.depth != 0); - if (the_stack.depth > 1) { - LISP_STACK_TOP()->lexenv = the_stack.frames[the_stack.depth - 2].lexenv; - } +void set_lexical_variable(LispVal *name, LispVal *value) { + assert(SYMBOLP(name)); + Vlexical_environment = Fplist_put(Vlexical_environment, name, value); } diff --git a/src/stack.h b/src/stack.h index 74cb7af..6d0f0bf 100644 --- a/src/stack.h +++ b/src/stack.h @@ -4,9 +4,22 @@ #include "base.h" #include "list.h" -#define DEFAULT_MAX_LISP_EVAL_DEPTH 1000 +#include +#include + +enum StackFrameKind { + STACK_FRAME_LOCAL_REFERENCES, + STACK_FRAME_CALL, + STACK_FRAME_UNWIND_PROTECT, + STACK_FRAME_CONDITION_CASE, + STACK_FRAME_DYNAMIC_BINDING, +}; + +#define LISP_STACK_MAX_DEPTH 4096 #define LOCAL_REFERENCES_BLOCK_LENGTH 64 +#define LISP_LONGJMP_FOR_UNWIND 1 + struct LocalReferencesBlock { LispVal *refs[LOCAL_REFERENCES_BLOCK_LENGTH]; }; @@ -17,68 +30,109 @@ struct LocalReferences { struct LocalReferencesBlock **blocks; }; -struct StackFrame { - LispVal *name; // name of function call - LispVal *fobj; // the function object - bool evaled_args; // whether args have been evaluated yet - LispVal *args; // arguments of the function call - LispVal *lexenv; // lexical environment (plist) - struct LocalReferences local_refs; - +typedef struct _StackFrame StackFrame; +struct _StackFrame { + enum StackFrameKind kind; bool marked; // whether we have GC'ed this frame + StackFrame *last_references; + union { + struct LocalReferences local_references; + struct { + LispVal *name; // name of function call + LispVal *fobj; // the function object + bool evaled_args; // whether args have been evaluated yet + LispVal *args; // arguments of the function call + } call; + struct { + jmp_buf *target; + StackFrame **unwind_target; + } unwind_protect; + struct { + jmp_buf *target; + LispVal **variable; + LispVal *exceptions; // list of exception symbols to catch + } condition_case; + struct { + LispVal *symbol; + LispVal *old_value; + } dynamic_binding; + }; +}; + +enum UnwindCause { + UNWIND_NORMAL, + UNWIND_EXCEPTION, +}; + +struct UnwindInformation { + bool set; + enum UnwindCause cause; + union { + StackFrame *target; + struct { + LispVal *name; + LispVal *data; + } exception; + }; }; struct LispStack { size_t max_depth; size_t depth; - size_t first_clear_local_refs; // index of the first frame that has local - // refs that has not been grown - struct StackFrame *frames; + StackFrame *frames; LispVal *nogc_retval; + struct UnwindInformation unwind_info; }; extern struct LispStack the_stack; -static ALWAYS_INLINE struct StackFrame *LISP_STACK_TOP(void) { - return the_stack.depth ? &the_stack.frames[the_stack.depth - 1] : NULL; -} - -static ALWAYS_INLINE LispVal *TOP_LEXENV(void) { - return the_stack.depth ? LISP_STACK_TOP()->lexenv : Qnil; -} - -static ALWAYS_INLINE LispVal *PARENT_LEXENV(void) { - return the_stack.depth > 1 ? the_stack.frames[the_stack.depth - 2].lexenv - : Qnil; -} - void lisp_init_stack(void); void lisp_teardown_stack(void); -void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args); -void pop_stack_frame(void); -void add_local_reference_no_recurse(LispVal *obj); -void add_local_reference(LispVal *obj); -// replace the args in the top stack frame with ARGS and mark them as evaluted +static ALWAYS_INLINE StackFrame *LISP_STACK_REF(void) { + if (!the_stack.depth) { + return NULL; + } + return &the_stack.frames[the_stack.depth - 1]; +} +void unwind_to(StackFrame *frame); +noreturn void continue_unwinding(void); + +// functions +void push_call_frame(LispVal *name, LispVal *fobj, LispVal *args); +// replace the args in the top stack frame with ARGS and mark them as evaluated // (this is for backtraces) -void set_stack_evaluated_args(LispVal *args); +void set_stack_evaluated_args(StackFrame *restrict ref, LispVal *args); -// Return true if successful, false if not found and not created -bool set_lexical_variable(LispVal *name, LispVal *value, bool create_if_absent); -// Just add a new lexical variable without any checking -static inline void new_lexical_variable(LispVal *name, LispVal *value) { - assert(the_stack.depth != 0); - LISP_STACK_TOP()->lexenv = - CONS(name, CONS(value, LISP_STACK_TOP()->lexenv)); - LISP_STACK_TOP()->marked = false; - gc_mark_stack_for_rescan(); +// unwind protect +void push_unwind_protect_frame(jmp_buf *buf); + +// condition case +void push_condition_case_frame(jmp_buf *buf, LispVal **variable, + LispVal *exceptions); + +// local references +void push_local_reference_frame(void); +void add_local_reference_no_recurse(StackFrame *restrict frame, LispVal *obj); +void add_local_reference(StackFrame *restrict frame, LispVal *obj); + +static ALWAYS_INLINE struct LocalReferences *TOP_LOCAL_REFERENCES(void) { + assert(the_stack.depth > 0); + return &the_stack.frames[the_stack.depth - 1].local_references; } -// Copy the previous frame's lexenv to the top of the stack. -void copy_parent_lexenv(void); +// dynamic binding +void push_dynamic_binding(LispVal *name, LispVal *new_value); +static ALWAYS_INLINE void push_copy_lexenv(void) { + push_dynamic_binding(Qlexical_environment, Vlexical_environment); +} -// used by the GC -void compact_stack_frame(struct StackFrame *restrict frame); +void set_lexical_variable(LispVal *name, LispVal *value); +// Just add a new lexical variable without any checking +static inline void new_lexical_variable(LispVal *name, LispVal *value) { + LispSymbol *lexenv = (LispSymbol *) Qlexical_environment; + lexenv->value = CONS(name, CONS(value, lexenv->value)); +} #endif