Rewrite the stack

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

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));

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();
+    unwind_to(stack_ref);
-    add_local_reference(the_stack.nogc_retval);
+    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);
+    set_stack_evaluated_args(LISP_STACK_REF(), evaled_args);
-    enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, 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();
+    unwind_to(stack_ref);
-    add_local_reference(rval);
+    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;
 }
 

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) {
+static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) {
-    mark_object(frame->name);
+    switch (frame->kind) {
-    mark_object(frame->args);
+    case STACK_FRAME_LOCAL_REFERENCES:
-    mark_object(frame->fobj);
+        mark_stack_local_refs(&frame->local_references, limit);
-    mark_object(frame->lexenv);
+        break;
-    saturating_dec(limit, 4);
+    case STACK_FRAME_CALL:
-    mark_stack_local_refs(&frame->local_refs, limit);
+        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);
     }

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

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),
+            lexenv = CONS(
-                                 Feval(SECOND(binding), TOP_LEXENV()));
+                FIRST(binding),
+                CONS(Feval(SECOND(binding), Vlexical_environment), lexenv));
         } else {
             // TODO better error
             abort();
         }
     }
+    push_dynamic_binding(Qlexical_environment, lexenv);
     return Fprogn(body);
 }
 

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;

src/stack.c

@@ -2,6 +2,7 @@
 
 #include "function.h"
 #include "hashtable.h"
+#include "list.h"
 #include "memory.h"
 
 #include <assert.h>
@@ -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(StackFrame) * the_stack.max_depth);
-    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.nogc_retval = Qnil;
+    the_stack.unwind_info.set = false;
 }
 
-static void teardown_stack_frame(struct StackFrame *restrict frame) {
+static void teardown_local_references(struct LocalReferences *restrict refs) {
-    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) {
     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) {
+void lisp_teardown_stack(void) {
-    assert(the_stack.depth > 0);
+    for (size_t i = 0; i < the_stack.depth; ++i) {
-    struct StackFrame *frame = &the_stack.frames[--the_stack.depth];
+        if (the_stack.frames[i].kind == STACK_FRAME_LOCAL_REFERENCES) {
-    reset_local_refs(&frame->local_refs);
+            teardown_local_references(&the_stack.frames[i].local_references);
+        }
+    }
+    lisp_free(the_stack.frames);
 }
 
-static void store_local_reference_in_frame(struct StackFrame *frame,
+void unwind_to(StackFrame *frame) {
-                                           LispVal *obj) {
+    the_stack.unwind_info.set = true;
-    struct LocalReferences *refs = &frame->local_refs;
+    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) {
+void add_local_reference_no_recurse(StackFrame *restrict frame, LispVal *obj) {
-    assert(the_stack.depth > 0);
+    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) {
+static LispVal *next_local_reference(StackFrame *restrict frame,
-    if (*i >= LISP_STACK_TOP()->local_refs.num_refs) {
+                                     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 =
+    LispVal *obj = frame->local_references.blocks[block_idx]->refs[small_idx];
-        LISP_STACK_TOP()->local_refs.blocks[block_idx]->refs[small_idx];
     ++*i;
     return obj;
 }
 
-static inline void add_local_ref_if_not_seen_no_recurse(LispVal *seen_objs,
+static inline void
-                                                        LispVal *obj) {
+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,
+static inline void
-                                                      LispVal *val) {
+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(frame, seen_objs, sym->name);
-        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->value);
+        add_local_ref_if_not_seen_no_recurse(frame, seen_objs, sym->value);
-        add_local_ref_if_not_seen_no_recurse(seen_objs, sym->function);
+        add_local_ref_if_not_seen_no_recurse(frame, 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->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(frame, seen_objs,
-            add_local_ref_if_not_seen_no_recurse(seen_objs, HASH_VALUE(val, i));
+                                                 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(frame, seen_objs, fobj->name);
-        add_local_ref_if_not_seen_no_recurse(seen_objs, fobj->docstr);
+        add_local_ref_if_not_seen_no_recurse(frame, 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(frame, 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(frame, 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(frame, 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->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) {
+void add_local_reference(StackFrame *restrict frame, LispVal *obj) {
-    add_local_reference_no_recurse(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))) {
+    while ((cur = next_local_reference(frame, &i))) {
-        add_local_refs_for_object_sub_vals(seen_objs, cur);
+        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) {
+void push_dynamic_binding(LispVal *name, LispVal *new_value) {
-    assert(the_stack.depth > 0);
+    assert(SYMBOLP(name));
-    LISP_STACK_TOP()->evaled_args = true;
+    StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_DYNAMIC_BINDING);
-    LISP_STACK_TOP()->args = args;
+    frame->dynamic_binding.symbol = name;
-    LISP_STACK_TOP()->marked = false;
+    if (name == Qlexical_environment) {
-    gc_mark_stack_for_rescan();
+        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) {
+void set_lexical_variable(LispVal *name, LispVal *value) {
-    struct LocalReferences *restrict refs = &frame->local_refs;
+    assert(SYMBOLP(name));
-    for (size_t i = 1; i < refs->num_blocks; ++i) {
+    Vlexical_environment = Fplist_put(Vlexical_environment, name, value);
-        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;
-    }
 }

src/stack.h

@@ -4,9 +4,22 @@
 #include "base.h"
 #include "list.h"
 
-#define DEFAULT_MAX_LISP_EVAL_DEPTH   1000
+#include <setjmp.h>
+#include <stdnoreturn.h>
+
+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 {
+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
-    LispVal *lexenv; // lexical environment (plist)
+        } call;
-    struct LocalReferences local_refs;
+        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;
+    };
+};
 
-    bool marked; // whether we have GC'ed this frame
+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
+    StackFrame *frames;
-                                   // refs that has not been grown
-    struct 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
+// unwind protect
-bool set_lexical_variable(LispVal *name, LispVal *value, bool create_if_absent);
+void push_unwind_protect_frame(jmp_buf *buf);
-// Just add a new lexical variable without any checking
+
-static inline void new_lexical_variable(LispVal *name, LispVal *value) {
+// condition case
-    assert(the_stack.depth != 0);
+void push_condition_case_frame(jmp_buf *buf, LispVal **variable,
-    LISP_STACK_TOP()->lexenv =
+                               LispVal *exceptions);
-        CONS(name, CONS(value, LISP_STACK_TOP()->lexenv));
+
-    LISP_STACK_TOP()->marked = false;
+// local references
-    gc_mark_stack_for_rescan();
+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.
+// dynamic binding
-void copy_parent_lexenv(void);
+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 set_lexical_variable(LispVal *name, LispVal *value);
-void compact_stack_frame(struct StackFrame *restrict frame);
+// 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