From 3b2ecf2b168510d2568c1894c902b006ee1a8711 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Thu, 3 Sep 2026 21:04:46 -0700 Subject: [PATCH] Fix gc with exceptions --- Makefile | 10 +++-- src/base.c | 35 ++++----------- src/base.h | 2 +- src/function.c | 2 +- src/gc.c | 86 +++++++++++++---------------------- src/gc.h | 4 +- src/main.c | 66 +++++++++++++-------------- src/read.c | 2 +- src/stack.c | 89 ++++++++++++++++--------------------- src/stack.h | 118 +++++++------------------------------------------ 10 files changed, 139 insertions(+), 275 deletions(-) diff --git a/Makefile b/Makefile index 76dbe6e..363bec9 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,18 @@ -DEBUG=1 +DEBUG=2 LLVM_SAN=1 ifeq ($(DEBUG),1) -DEBUG_CFLAGS=-g +DEBUG_CFLAGS=-g -Og +else ifeq ($(DEBUG),2) +DEBUG_CFLAGS=-g -O0 else -DEBUG_CFLAGS=-D_NDEBUG +DEBUG_CFLAGS=-D_NDEBUG -O2 endif ifeq ($(LLVM_SAN),1) LLVM_SAN_FLAGS=-fsanitize=address,undefined +else ifeq ($(LLVM_SAN),2) +LLVM_SAN_FLAGS=-fsanitize=thread,undefined else LLVM_SAN_FLAGS= endif diff --git a/src/base.c b/src/base.c index 295f829..0a20fb0 100644 --- a/src/base.c +++ b/src/base.c @@ -27,7 +27,7 @@ void *lisp_alloc_object_no_gc(size_t size, LispValType type) { LispObject *obj = lisp_aligned_alloc(LISP_OBJECT_ALIGNMENT, size); memset(obj, 0, size); obj->type = type; - tss_create(&obj->gc.lowest_local_ref, NULL); + obj->gc.lowest_local_ref = NULL; return obj; } @@ -45,8 +45,6 @@ void *lisp_alloc_object(size_t size, LispValType type) { void lisp_release_object(LispVal *val) { assert(OBJECTP(val)); - LispObject *obj = val; - tss_delete(obj->gc.lowest_local_ref); lisp_free(val); } @@ -294,35 +292,20 @@ static void check_handler_bind_handlers(LispVal *handlers) { } } +static void lisp_handler_bind_handler(LispVal *name, LispVal *data, + LispVal *lisp_handler) { + CALL(lisp_handler, CONS(name, data)); +} + DEFUN(handler_bind, "handler-bind", (LispVal * thunk, LispVal *handlers), "(thunk &rest handlers)", "") { check_handler_bind_handlers(handlers); StackFrame *stack_ref = LISP_STACK_REF(); - jmp_buf jmp_target; - size_t nhandlers = list_length(handlers); - LispVal **handler_vec = lisp_malloc(sizeof(LispVal *) * nhandlers); - bool **enabled_vec = lisp_malloc(sizeof(bool *) * nhandlers); - size_t idx = 0; DOLIST(handler, handlers) { - handler_vec[idx] = XCDR(handler); - enabled_vec[idx] = - push_handler_bind_frame(&jmp_target, XCAR(handler), idx); - ++idx; - } - if (setjmp(jmp_target) == 0) { - return UNWIND_AND_RETURN(stack_ref, CALL0(thunk)); - } else { - size_t handler_idx = EXCEPTION_HANDLER_FRAME()->handler_bind.datum; - for (size_t i = 0; i < nhandlers; ++i) { - *enabled_vec[i] = false; - } - CALL(handler_vec[handler_idx], - CONS(EXCEPTION_NAME(), EXCEPTION_DATA())); - for (size_t i = 0; i < nhandlers; ++i) { - *enabled_vec[i] = true; - } - continue_unwinding(); + push_handler_bind_frame(FIRST(handler), lisp_handler_bind_handler, + SECOND(handler), NULL); } + return UNWIND_AND_RETURN(stack_ref, CALL0(thunk)); } DEFUN(error, "error", (LispVal * data), "(data)", "") { diff --git a/src/base.h b/src/base.h index c4a03cb..3a18b75 100644 --- a/src/base.h +++ b/src/base.h @@ -136,7 +136,7 @@ static ALWAYS_INLINE bool OBJECT_STATIC_P(LispVal *val) { static inline void MARK_OBJECT_ADDED(LispVal *val, LispVal *into) { if (OBJECTP(val) && OBJECTP(into) && OBJECT_GC_SET_P(into, GC_BLACK) && OBJECT_GC_SET_P(val, GC_WHITE)) { - gc_move_to_set(val, GC_GREY); + gc_move_to_set(val, GC_GRAY); } } diff --git a/src/function.c b/src/function.c index 6eeab55..10ce269 100644 --- a/src/function.c +++ b/src/function.c @@ -237,7 +237,7 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void), // Calling functions static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) { LispVal *start = Qnil; - LispVal *end; + LispVal *end = NULL; DOLIST(arg, args) { if (NILP(start)) { start = CONS(Feval(arg, Vlexical_environment), Qnil); diff --git a/src/gc.c b/src/gc.c index 18ff647..0396f1d 100644 --- a/src/gc.c +++ b/src/gc.c @@ -23,17 +23,16 @@ static size_t free_objects_list_count; static struct GCObjectList *free_objects_list; static struct GCObjectList *black_objects; -static struct GCObjectList *grey_objects; +static struct GCObjectList *GRAY_objects; static struct GCObjectList *white_objects; static struct GCObjectList *static_objects; ObjectGCSet GC_BLACK = 0; -ObjectGCSet GC_GREY = 1; +ObjectGCSet GC_GRAY = 1; ObjectGCSet GC_WHITE = 2; enum IncrementalGCSetp { GC_STEP_STATICS, - GC_STEP_UNWIND, GC_STEP_STACK, GC_STEP_HEAP, GC_STEP_FREE, @@ -52,8 +51,8 @@ static struct IncrementalGCState incremental_state = { static ALWAYS_INLINE struct GCObjectList **HEAD_FOR_SET(ObjectGCSet set) { if (set == GC_BLACK) { return &black_objects; - } else if (set == GC_GREY) { - return &grey_objects; + } else if (set == GC_GRAY) { + return &GRAY_objects; } else if (set == GC_WHITE) { return &white_objects; } else { @@ -188,9 +187,9 @@ static void free_object(LispVal *val) { lisp_release_object(val); } -static inline void make_grey_if_white(LispVal *val) { +static inline void make_GRAY_if_white(LispVal *val) { if (OBJECTP(val) && OBJECT_GC_SET_P(val, GC_WHITE)) { - gc_move_to_set(val, GC_GREY); + gc_move_to_set(val, GC_GRAY); } } @@ -201,39 +200,39 @@ static void mark_object(LispVal *val) { } switch (((LispObject *) val)->type) { case TYPE_CONS: - make_grey_if_white(((LispCons *) val)->car); - make_grey_if_white(((LispCons *) val)->cdr); + make_GRAY_if_white(((LispCons *) val)->car); + make_GRAY_if_white(((LispCons *) val)->cdr); break; case TYPE_SYMBOL: { LispSymbol *sym = val; - make_grey_if_white(sym->name); - make_grey_if_white(SYMBOL_VALUE(sym)); - make_grey_if_white(sym->function); - make_grey_if_white(sym->plist); + make_GRAY_if_white(sym->name); + make_GRAY_if_white(SYMBOL_VALUE(sym)); + make_GRAY_if_white(sym->function); + make_GRAY_if_white(sym->plist); break; } case TYPE_VECTOR: { LispVector *vec = val; for (size_t i = 0; i < vec->length; ++i) { - make_grey_if_white(vec->data[i]); + make_GRAY_if_white(vec->data[i]); } break; } case TYPE_HASH_TABLE: { HT_FOREACH_INDEX(val, i) { - make_grey_if_white(HASH_KEY(val, i)); - make_grey_if_white(HASH_VALUE(val, i)); + make_GRAY_if_white(HASH_KEY(val, i)); + make_GRAY_if_white(HASH_VALUE(val, i)); } break; } case TYPE_FUNCTION: { LispFunction *fobj = val; - make_grey_if_white(fobj->name); - make_grey_if_white(fobj->docstr); - make_grey_if_white(fobj->args.req); - make_grey_if_white(fobj->args.opt); - make_grey_if_white(fobj->args.kw); - make_grey_if_white(fobj->args.rest); + make_GRAY_if_white(fobj->name); + make_GRAY_if_white(fobj->docstr); + make_GRAY_if_white(fobj->args.req); + make_GRAY_if_white(fobj->args.opt); + make_GRAY_if_white(fobj->args.kw); + make_GRAY_if_white(fobj->args.rest); break; } case TYPE_STRING: @@ -265,7 +264,7 @@ static void mark_statics(size_t *restrict limit) { // we processed the whole list, move to the next step if (!node) { incremental_state.next_static = static_objects; - incremental_state.step = GC_STEP_UNWIND; + incremental_state.step = GC_STEP_STACK; } } @@ -312,26 +311,6 @@ static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) { } } -static void mark_unwind_info(size_t *restrict limit) { - if (the_stack.unwind_info.set) { - switch (the_stack.unwind_info.cause) { - case UNWIND_NORMAL: - mark_object(the_stack.unwind_info.target); - saturating_dec(limit, 1); - break; - case UNWIND_EXCEPTION: - mark_object(the_stack.unwind_info.exception.name); - mark_object(the_stack.unwind_info.exception.data); - saturating_dec(limit, 2); - break; - default: - abort(); - break; - } - } - incremental_state.step = GC_STEP_STACK; -} - static void mark_the_stack(size_t *restrict limit) { size_t i; for (i = 0; i < the_stack.depth && *limit; ++i) { @@ -351,11 +330,11 @@ static void unmark_the_stack(void) { } } -static void mark_grey_objects(size_t *restrict limit) { - while (grey_objects && saturating_dec(limit, 1)) { - mark_object(grey_objects->obj); +static void mark_GRAY_objects(size_t *restrict limit) { + while (GRAY_objects && saturating_dec(limit, 1)) { + mark_object(GRAY_objects->obj); } - if (!grey_objects) { + if (!GRAY_objects) { incremental_state.step = GC_STEP_FREE; } } @@ -398,22 +377,19 @@ void lisp_gc_yield(struct timespec *restrict time_took, bool full) { clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &start_time); size_t limit = full ? SIZE_MAX : LISP_GC_INCREMENTAL_COUNT; while (limit) { - // there are more grey objects, mark them before we sweep - if (incremental_state.step == GC_STEP_FREE && grey_objects) { + // there are more GRAY objects, mark them before we sweep + if (incremental_state.step == GC_STEP_FREE && GRAY_objects) { incremental_state.step = GC_STEP_HEAP; } switch (incremental_state.step) { case GC_STEP_STATICS: mark_statics(&limit); break; - case GC_STEP_UNWIND: - mark_unwind_info(&limit); - break; case GC_STEP_STACK: mark_the_stack(&limit); break; case GC_STEP_HEAP: - mark_grey_objects(&limit); + mark_GRAY_objects(&limit); break; case GC_STEP_FREE: gc_sweep_objects(&limit); @@ -438,8 +414,8 @@ void lisp_gc_teardown(void) { while (white_objects) { free_object(white_objects->obj); } - while (grey_objects) { - free_object(grey_objects->obj); + while (GRAY_objects) { + free_object(GRAY_objects->obj); } while (black_objects) { free_object(black_objects->obj); diff --git a/src/gc.h b/src/gc.h index 5f1f97c..1ce90de 100644 --- a/src/gc.h +++ b/src/gc.h @@ -16,7 +16,7 @@ extern size_t lisp_gc_count; typedef uint8_t ObjectGCSet; extern ObjectGCSet GC_BLACK; -extern ObjectGCSet GC_GREY; +extern ObjectGCSet GC_GRAY; extern ObjectGCSet GC_WHITE; struct GCObjectList; @@ -24,7 +24,7 @@ struct GCObjectList; typedef struct { unsigned int is_static : 1; ObjectGCSet set : 2; - tss_t lowest_local_ref; + void *lowest_local_ref; // Really a StackFrame * struct GCObjectList *gc_node; } ObjectGCInfo; diff --git a/src/main.c b/src/main.c index 7323f8f..1fa704e 100644 --- a/src/main.c +++ b/src/main.c @@ -1,8 +1,33 @@ #include "lisp.h" #include "read.h" +#include #include +static jmp_buf toplevel_error_jmp_buf; + +static void toplevel_error_handler(LispVal *name, LispVal *data, + void *ignored) { + fprintf(stderr, "Caught exception: "); + Fprint_condition(name, data, Qerror_write_byte); + fprintf(stderr, "\nBacktrace (toplevel comes last):\n"); + LispVal *backtrace = Fbacktrace(); + DOLIST(frame, backtrace) { + LispVal *name = FIRST(frame); + bool evaled = !NILP(THIRD(frame)); + LispVal *args = FOURTH(frame); + fprintf(stderr, " %c ", evaled ? '-' : '*'); + Fprinc(name, Qerror_write_byte); + if (NILP(args)) { + fprintf(stderr, "()\n"); + } else { + Fprinc(args, Qerror_write_byte); + fputc('\n', stderr); + } + } + longjmp(toplevel_error_jmp_buf, 1); +} + int main(int argc, const char **argv) { FILE *in = fopen(argv[1], "r"); fseek(in, 0, SEEK_END); @@ -17,38 +42,15 @@ int main(int argc, const char **argv) { ReadStream s; read_stream_init(&s, src, src_len); LispVal *r; - bool had_toplevel_error = false; - HANDLER_BIND1( - LIST(Qt), - { - while ((r = read(&s))) { - Feval(r, Qnil); - } - }, - { - fprintf(stderr, "Caught exception: "); - Fprint_condition(EXCEPTION_NAME(), EXCEPTION_DATA(), - Qerror_write_byte); // - fprintf(stderr, "\nBacktrace (toplevel comes last):\n"); - LispVal *backtrace = Fbacktrace(); - DOLIST(frame, backtrace) { - LispVal *name = FIRST(frame); - bool evaled = !NILP(THIRD(frame)); - LispVal *args = FOURTH(frame); - fprintf(stderr, " %c ", evaled ? '-' : '*'); - Fprinc(name, Qerror_write_byte); - if (NILP(args)) { - fprintf(stderr, "()\n"); - } else { - Fprinc(args, Qerror_write_byte); - fputc('\n', stderr); - } - } - CLEAR_EXCEPTION(); - had_toplevel_error = true; - goto toplevel_error; - }); -toplevel_error: + push_handler_bind_frame(LIST(Qt), toplevel_error_handler, NULL, NULL); + volatile bool had_toplevel_error = false; + if (setjmp(toplevel_error_jmp_buf) == 0) { + while ((r = read(&s))) { + Feval(r, Qnil); + } + } else { + had_toplevel_error = true; + } unwind_to(toplevel); lisp_shutdown(); free(src); diff --git a/src/read.c b/src/read.c index c14eaca..5b58d7e 100644 --- a/src/read.c +++ b/src/read.c @@ -89,7 +89,7 @@ LispVal *next_list(ReadStream *stream) { pop_char(stream); // the ( skip_whitespace(stream); LispVal *start = Qnil; - LispVal *end; + LispVal *end = NULL; bool dotted = false; while (peek_char(stream) != ')') { if (dotted) { diff --git a/src/stack.c b/src/stack.c index d597217..bd88f3e 100644 --- a/src/stack.c +++ b/src/stack.c @@ -15,7 +15,6 @@ void lisp_init_stack(void) { the_stack.max_depth = LISP_STACK_MAX_DEPTH; the_stack.depth = 0; the_stack.frames = lisp_malloc(sizeof(StackFrame) * the_stack.max_depth); - the_stack.unwind_info.set = false; } static inline void @@ -85,18 +84,24 @@ void set_stack_evaluated_args(StackFrame *restrict frame, LispVal *fobj, frame->call.evaled_args = true; } -void push_unwind_protect_frame(jmp_buf *buf) { +void push_unwind_protect_frame(void (*handler)(void *user_ptr), void *user_ptr, + void (*cleanup_user_ptr)(void *data)) { StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_UNWIND_PROTECT); - frame->unwind_protect.target = buf; + frame->unwind_protect.handler = handler; + frame->unwind_protect.user_ptr = user_ptr; + frame->unwind_protect.cleanup_user_ptr = cleanup_user_ptr; } -bool *push_handler_bind_frame(jmp_buf *buf, LispVal *exceptions, size_t datum) { +void push_handler_bind_frame(LispVal *exceptions, + void (*handler)(LispVal *name, LispVal *data, + void *user_ptr), + void *user_ptr, void (*cleanup_user_ptr)(void *)) { StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_HANDLER_BIND); - frame->handler_bind.target = buf; - frame->handler_bind.exceptions = exceptions; - frame->handler_bind.datum = datum; frame->handler_bind.enabled = true; - return &frame->handler_bind.enabled; + frame->handler_bind.exceptions = exceptions; + frame->handler_bind.handler = handler; + frame->handler_bind.user_ptr = user_ptr; + frame->handler_bind.cleanup_user_ptr = cleanup_user_ptr; } void push_local_reference_frame(void) { @@ -270,7 +275,7 @@ void new_lexical_variable(LispVal *name, LispVal *value) { } } -static void do_unwind_to(StackFrame *frame) { +void unwind_to(StackFrame *frame) { while (the_stack.depth && &the_stack.frames[the_stack.depth - 1] > frame) { StackFrame *restrict top = &the_stack.frames[--the_stack.depth]; switch (top->kind) { @@ -283,7 +288,12 @@ static void do_unwind_to(StackFrame *frame) { } break; case STACK_FRAME_UNWIND_PROTECT: - longjmp(*top->unwind_protect.target, LISP_LONGJMP_FOR_UNWIND); + top->unwind_protect.handler(top->unwind_protect.user_ptr); + if (top->unwind_protect.cleanup_user_ptr) { + top->unwind_protect.cleanup_user_ptr( + top->unwind_protect.user_ptr); + } + break; case STACK_FRAME_LOCAL_REFERENCES: teardown_local_references(top); break; @@ -295,14 +305,6 @@ static void do_unwind_to(StackFrame *frame) { } } -void unwind_to(StackFrame *frame) { - the_stack.unwind_info.set = true; - the_stack.unwind_info.cause = UNWIND_NORMAL; - the_stack.unwind_info.target = frame; - do_unwind_to(frame); - the_stack.unwind_info.set = false; -} - static bool frame_handles_exception(StackFrame *restrict frame, LispVal *exception_name) { assert(frame->kind == STACK_FRAME_HANDLER_BIND); @@ -326,55 +328,38 @@ static StackFrame *find_exception_handler(StackFrame *from, return NULL; } -static void do_run_handler_cases(LispVal *name, StackFrame *start) { +static void do_run_handler_cases(LispVal *name, LispVal *data, + StackFrame *start) { while ((start = find_exception_handler(start, name))) { - the_stack.unwind_info.exception.handler_frame = start; - longjmp(*start->handler_bind.target, LISP_LONGJMP_FOR_UNWIND); + start->handler_bind.enabled = false; + start->handler_bind.handler(name, data, start->handler_bind.user_ptr); + start->handler_bind.enabled = true; + if (start->handler_bind.cleanup_user_ptr) { + start->handler_bind.cleanup_user_ptr(start->handler_bind.user_ptr); + } } } -static noreturn void top_of_stack_exception_handler(void) { - assert(the_stack.unwind_info.set - && the_stack.unwind_info.cause == UNWIND_EXCEPTION); +static noreturn void top_of_stack_exception_handler(LispVal *name, + LispVal *data) { fprintf(stderr, "An exception has propagated to the top of the lisp stack!\n"); fprintf(stderr, "Name: "); - debug_print(stderr, the_stack.unwind_info.exception.name); + debug_print(stderr, name); fprintf(stderr, "\nData: "); - debug_print(stderr, the_stack.unwind_info.exception.data); + debug_print(stderr, data); fprintf(stderr, "\nLisp will now exit...\n"); abort(); } -noreturn void continue_unwinding(void) { - assert(the_stack.unwind_info.set); - switch (the_stack.unwind_info.cause) { - case UNWIND_NORMAL: - do_unwind_to(the_stack.unwind_info.target); - abort(); - case UNWIND_EXCEPTION: - do_run_handler_cases(the_stack.unwind_info.exception.name, - the_stack.unwind_info.exception.handler_frame - 1); - do_unwind_to(NULL); - top_of_stack_exception_handler(); - default: - abort(); - } -} - noreturn void lisp_signal(LispVal *name, LispVal *data) { - CHECK_LISTP(data); if (NILP(Fcondition_class_p(name))) { signal_type_error(name, LIST(Qcondition_class)); } CHECK_LISTP(data); - the_stack.unwind_info.set = true; - the_stack.unwind_info.cause = UNWIND_EXCEPTION; - the_stack.unwind_info.exception.name = name; - the_stack.unwind_info.exception.data = data; - do_run_handler_cases(name, LISP_STACK_REF()); - do_unwind_to(NULL); - top_of_stack_exception_handler(); + do_run_handler_cases(name, data, LISP_STACK_REF()); + unwind_to(NULL); + top_of_stack_exception_handler(name, data); } DEFUN(backtrace, "backtrace", (void), "()", "") { @@ -382,7 +367,9 @@ DEFUN(backtrace, "backtrace", (void), "()", "") { for (size_t i = 0; i < the_stack.depth; ++i) { StackFrame *restrict frame = &the_stack.frames[i]; if (frame->kind == STACK_FRAME_CALL) { - out = CONS(LIST(frame->call.name, frame->call.fobj, + // fobj is NULL (not Qnil) if the arguments haven't been evaluated + out = CONS(LIST(frame->call.name, + frame->call.fobj ? frame->call.fobj : Qnil, frame->call.evaled_args ? Qt : Qnil, frame->call.args), out); diff --git a/src/stack.h b/src/stack.h index aecdbf0..646ed11 100644 --- a/src/stack.h +++ b/src/stack.h @@ -3,7 +3,6 @@ #include "base.h" -#include #include enum StackFrameKind { @@ -44,13 +43,16 @@ struct _StackFrame { LispVal *args; // arguments of the function call } call; struct { - jmp_buf *target; + void (*handler)(void *user_ptr); + void *user_ptr; + void (*cleanup_user_ptr)(void *data); } unwind_protect; struct { - jmp_buf *target; LispVal *exceptions; // list of exception symbols to catch - size_t datum; // extra value to identify this case bool enabled; + void (*handler)(LispVal *name, LispVal *data, void *user_ptr); + void *user_ptr; + void (*cleanup_user_ptr)(void *data); } handler_bind; struct { LispVal *symbol; @@ -59,44 +61,22 @@ struct _StackFrame { }; }; -enum UnwindCause { - UNWIND_NORMAL, - UNWIND_EXCEPTION, -}; - -struct UnwindInformation { - bool set; - enum UnwindCause cause; - union { - StackFrame *target; - struct { - LispVal *name; - LispVal *data; - StackFrame *handler_frame; - } exception; - }; -}; - struct LispStack { size_t max_depth; size_t depth; StackFrame *frames; - - struct UnwindInformation unwind_info; }; // ONLY APPLIES TO THE CALLING THREAD static ALWAYS_INLINE StackFrame *OBJECT_LOWEST_LOCAL_REFERENCE(LispVal *val) { assert(OBJECTP(val)); - LispObject *obj = val; - return tss_get(obj->gc.lowest_local_ref); + return ((LispObject *) val)->gc.lowest_local_ref; } static ALWAYS_INLINE void SET_OBJECT_LOWEST_LOCAL_REFERENCE(LispVal *val, StackFrame *frame) { assert(OBJECTP(val)); - LispObject *obj = val; - tss_set(obj->gc.lowest_local_ref, frame); + ((LispObject *) val)->gc.lowest_local_ref = frame; } extern struct LispStack the_stack; @@ -111,32 +91,6 @@ static ALWAYS_INLINE StackFrame *LISP_STACK_REF(void) { return &the_stack.frames[the_stack.depth - 1]; } -static ALWAYS_INLINE void CLEAR_EXCEPTION(void) { - the_stack.unwind_info.set = false; -} - -static ALWAYS_INLINE bool EXCEPTION_SET_P(void) { - return the_stack.unwind_info.set; -} - -static ALWAYS_INLINE LispVal *EXCEPTION_NAME(void) { - assert(the_stack.unwind_info.set - && the_stack.unwind_info.cause == UNWIND_EXCEPTION); - return the_stack.unwind_info.exception.name; -} - -static ALWAYS_INLINE LispVal *EXCEPTION_DATA(void) { - assert(the_stack.unwind_info.set - && the_stack.unwind_info.cause == UNWIND_EXCEPTION); - return the_stack.unwind_info.exception.data; -} - -static ALWAYS_INLINE StackFrame *EXCEPTION_HANDLER_FRAME(void) { - assert(the_stack.unwind_info.set - && the_stack.unwind_info.cause == UNWIND_EXCEPTION); - return the_stack.unwind_info.exception.handler_frame; -} - // functions void push_call_frame(LispVal *name, LispVal *args); // replace the args in the top stack frame with ARGS and mark them as evaluated @@ -145,10 +99,15 @@ void set_stack_evaluated_args(StackFrame *restrict ref, LispVal *fobj, LispVal *args); // unwind protect -void push_unwind_protect_frame(jmp_buf *buf); +void push_unwind_protect_frame(void (*handler)(void *user_ptr), void *user_ptr, + void (*cleanup_user_ptr)(void *data)); // handler bind -bool *push_handler_bind_frame(jmp_buf *buf, LispVal *exceptions, size_t datum); +void push_handler_bind_frame(LispVal *exceptions, + void (*handler)(LispVal *name, LispVal *data, + void *user_ptr), + void *user_ptr, + void (*cleanup_user_ptr)(void *data)); // local references void push_local_reference_frame(void); @@ -177,7 +136,6 @@ static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame, unwind_to(frame); return val; } -noreturn void continue_unwinding(void); noreturn void lisp_signal(LispVal *name, LispVal *data); @@ -186,52 +144,6 @@ noreturn void lisp_signal(LispVal *name, LispVal *data); */ DECLARE_FUNCTION(backtrace, (void) ); -#define UNWIND_PROTECT(body, cleanup) \ - { \ - jmp_buf _internal_jb; \ - if (setjmp(_internal_jb) == 0) { \ - push_unwind_protect_frame(&_internal_jb); \ - StackFrame *_internal_target = LISP_STACK_REF(); \ - {body}; \ - unwind_to(_internal_target); \ - } else { \ - {cleanup}; \ - continue_unwinding(); \ - } \ - }; - -#define HANDLER_BIND1(exceptions, body, handler) \ - { \ - jmp_buf _internal_jb; \ - StackFrame *_internal_target = LISP_STACK_REF(); \ - bool *enabled; \ - if (setjmp(_internal_jb) == 0) { \ - enabled = push_handler_bind_frame(&_internal_jb, (exceptions), 0); \ - {body}; \ - unwind_to(_internal_target); \ - } else { \ - *enabled = false; \ - {handler}; \ - *enabled = true; \ - continue_unwinding(); \ - } \ - }; - -#define CONDITION_CASE1(exceptions, body, handler) \ - { \ - jmp_buf _internal_jb; \ - StackFrame *_internal_target = LISP_STACK_REF(); \ - if (setjmp(_internal_jb) == 0) { \ - push_handler_bind_frame(&_internal_jb, (exceptions), 0); \ - {body}; \ - unwind_to(_internal_target); \ - } else { \ - unwind_to(_internal_target); \ - {handler}; \ - CLEAR_EXCEPTION(); \ - } \ - }; - DECLARE_SYMBOL(excessive_lisp_nesting_error); MAKE_CONDITION_CLASS(excessive_lisp_nesting_error);