diff --git a/lisp/kernel.gl b/lisp/kernel.gl index 6037887..1e73ac6 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,14 +1,3 @@ ;; -*- mode: lisp-data -*- -(put 'x 'condition-class t) -(put 'y 'condition-class 'x) - -(print (condition-class-p 'x)) -(print (condition-class-p 'y)) -(print (condition-class-p 'z)) -(print (condition-subclass-p 'y 'x)) -(print (condition-subclass-p 'y t)) -(print (condition-subclass-p 'x t)) -(print (condition-subclass-p t t)) -(print (condition-subclass-p 'z 'x)) -(print (condition-subclass-p 'x 'y)) +(test a) diff --git a/src/base.c b/src/base.c index 84c260a..e537c9a 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.has_local_ref, NULL); + tss_create(&obj->gc.lowest_local_ref, NULL); return obj; } @@ -46,7 +46,7 @@ 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.has_local_ref); + tss_delete(obj->gc.lowest_local_ref); lisp_free(val); } @@ -131,6 +131,11 @@ DEFUN(intern, "intern", (LispVal * name), "(name)", "") { return newsym; } +DEFUN(symbol_value, "symbol-value", (LispVal * sym), "(sym)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + return SYMBOL_VALUE(sym); +} + DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve), "(sym &optional resolve)", "") { CHECK_TYPE(sym, TYPE_SYMBOL); @@ -148,6 +153,18 @@ DEFUN(symbol_plist, "symbol-plist", (LispVal * sym), "(sym)", "") { return ((LispSymbol *) sym)->plist; } +DEFUN(set, "set", (LispVal * sym, LispVal *value), "(sym value)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + SET_SYMBOL_VALUE(sym, value); + return value; +} + +DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + ((LispSymbol *) sym)->function = value; + return value; +} + DEFUN(setplist, "setplist", (LispVal * sym, LispVal *plist), "(sym plist)", "") { CHECK_TYPE(sym, TYPE_SYMBOL); diff --git a/src/base.h b/src/base.h index 51f99de..38e0402 100644 --- a/src/base.h +++ b/src/base.h @@ -105,21 +105,6 @@ static ALWAYS_INLINE bool OBJECTP(LispVal *val) { return EXTRACT_TAG(val) == LISP_OBJECT_TAG; } -// ONLY APPLIES TO THE CALLING THREAD -static ALWAYS_INLINE bool OBJECT_HAS_LOCAL_REFERENCE_P(LispVal *val) { - assert(OBJECTP(val)); - LispObject *obj = val; - return tss_get(obj->gc.has_local_ref); -} - -static ALWAYS_INLINE void SET_OBJECT_HAS_LOCAL_REFERENCE(LispVal *val, - bool has_local_ref) { - assert(OBJECTP(val)); - LispObject *obj = val; - tss_set(obj->gc.has_local_ref, - (void *) (uintptr_t) (has_local_ref ? 1 : 0)); -} - static ALWAYS_INLINE ObjectGCSet OBJECT_GET_GC_SET(LispVal *val) { assert(OBJECTP(val)); return ((LispObject *) val)->gc.set; @@ -299,8 +284,11 @@ DECLARE_FUNCTION(quote, (LispVal * form)); LispVal *make_vector(LispVal **data, size_t length, bool take); DECLARE_FUNCTION(make_symbol, (LispVal * name)); DECLARE_FUNCTION(intern, (LispVal * name)); +DECLARE_FUNCTION(symbol_value, (LispVal * sym)); DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve)); DECLARE_FUNCTION(symbol_plist, (LispVal * sym)); +DECLARE_FUNCTION(set, (LispVal * sym, LispVal *value)); +DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *value)); 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)); diff --git a/src/function.c b/src/function.c index 6720459..ef560a9 100644 --- a/src/function.c +++ b/src/function.c @@ -331,11 +331,10 @@ process_complex_native_args(LispFunction *fobj, LispVal *args, static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, LispFunction *fobj, LispVal *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(LISP_STACK_REF(), args); + set_stack_evaluated_args(LISP_STACK_REF(), fobj, args); LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL}; size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj); intptr_t rest_idx; @@ -380,10 +379,7 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, default: abort(); } - the_stack.nogc_retval = retval; - unwind_to(stack_ref); - add_local_reference(LISP_STACK_REF(), the_stack.nogc_retval); - return retval; + return UNWIND_AND_RETURN(stack_ref, retval); } static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec, @@ -460,9 +456,8 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) { static ALWAYS_INLINE LispVal * call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *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(LISP_STACK_REF(), evaled_args); + set_stack_evaluated_args(LISP_STACK_REF(), fobj, evaled_args); push_dynamic_binding(Qlexical_environment, fobj->impl.interp.lexenv); enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, evaled_args); @@ -472,29 +467,34 @@ call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) { process_args_strerror(par)); abort(); } - LispVal *rval = Fprogn(fobj->impl.interp.body); - the_stack.nogc_retval = rval; - unwind_to(stack_ref); - add_local_reference(LISP_STACK_REF(), rval); - return rval; + return UNWIND_AND_RETURN(stack_ref, Fprogn(fobj->impl.interp.body)); } DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", "") { + StackFrame *stack_ref = LISP_STACK_REF(); + push_call_frame(func, args); LispFunction *fobj = func; if (SYMBOLP(func)) { fobj = Fsymbol_function(func, Qt); } else if (CONSP(func) && EQ(XCAR(func), Qlambda)) { fobj = Feval(func, Vlexical_environment); } + if (NILP(fobj)) { + // TODO throw exception + fprintf(stderr, "Not a function: "); + debug_print(stderr, func); + fputc('\n', stderr); + abort(); + } // 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); + return UNWIND_AND_RETURN(stack_ref, call_native(func, fobj, args)); case FUNCTION_INTERP: - return call_interpreted(func, fobj, args); + return UNWIND_AND_RETURN(stack_ref, call_interpreted(func, fobj, args)); default: abort(); } diff --git a/src/gc.c b/src/gc.c index 9ccfa63..446c51e 100644 --- a/src/gc.c +++ b/src/gc.c @@ -153,7 +153,7 @@ void gc_mark_stack_for_rescan(void) { static void free_object(LispVal *val) { // This is called on non-white objects during cleanup! Don't assert // OBJECT_GC_SET_P! - assert(!OBJECT_HAS_LOCAL_REFERENCE_P(val)); + assert(!OBJECT_LOWEST_LOCAL_REFERENCE(val)); switch (((LispObject *) val)->type) { case TYPE_HASH_TABLE: { LispHashTable *ht = val; @@ -311,10 +311,7 @@ static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) { } } -static void mark_and_compact_the_stack(size_t *restrict limit) { - if ((*limit)--) { - mark_object(the_stack.nogc_retval); - } +static void mark_the_stack(size_t *restrict limit) { size_t i; for (i = 0; i < the_stack.depth && *limit; ++i) { if (!the_stack.frames[i].marked) { @@ -389,7 +386,7 @@ void lisp_gc_yield(struct timespec *restrict time_took, bool full) { mark_statics(&limit); break; case GC_STEP_STACK: - mark_and_compact_the_stack(&limit); + mark_the_stack(&limit); break; case GC_STEP_HEAP: mark_grey_objects(&limit); diff --git a/src/gc.h b/src/gc.h index f832c71..5f1f97c 100644 --- a/src/gc.h +++ b/src/gc.h @@ -24,7 +24,7 @@ struct GCObjectList; typedef struct { unsigned int is_static : 1; ObjectGCSet set : 2; - tss_t has_local_ref; + tss_t lowest_local_ref; struct GCObjectList *gc_node; } ObjectGCInfo; diff --git a/src/lisp.c b/src/lisp.c index dec3897..cf24269 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -75,14 +75,14 @@ static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) { if (lexval != Qunbound) { return lexval; } - if (name->value == Qunbound) { + if (SYMBOL_VALUE(name) == Qunbound) { // TODO better error printf("Unbound symbol: "); debug_print(stdout, name); fputc('\n', stdout); abort(); } - return name->value; + return SYMBOL_VALUE(name); } DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), @@ -131,6 +131,7 @@ DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") { DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), "(bindings &rest body)", "") { CHECK_LISTP(bindings); + StackFrame *stack_ref = LISP_STACK_REF(); LispVal *lexenv = Vlexical_environment; DOLIST(binding, bindings) { if (SYMBOLP(binding)) { @@ -145,7 +146,43 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), } } push_dynamic_binding(Qlexical_environment, lexenv); - return Fprogn(body); + return UNWIND_AND_RETURN(stack_ref, Fprogn(body)); +} + +DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise), + "(cond then &rest else)", "") { + StackFrame *stack_ref = LISP_STACK_REF(); + LispVal *res = Feval(cond, Vlexical_environment); + if (!NILP(res)) { + return UNWIND_AND_RETURN(stack_ref, Feval(then, Vlexical_environment)); + } else { + return UNWIND_AND_RETURN(stack_ref, Fprogn(otherwise)); + } +} + +DEFSPECIAL(and, "and", (LispVal * forms), "(&rest forms)", "") { + LispVal *res = Qt; + DOLIST(form, forms) { + res = Feval(form, Vlexical_environment); + if (NILP(res)) { + return Qnil; + } + } + return res; +} + +DEFSPECIAL(or, "or", (LispVal * forms), "(&rest forms)", "") { + DOLIST(form, forms) { + LispVal *res = Feval(form, Vlexical_environment); + if (!NILP(res)) { + return res; + } + } + return Qnil; +} + +DEFUN(null, "null", (LispVal * datum), "(datum)", "") { + return NILP(datum) ? Qt : Qnil; } void debug_print(FILE *file, LispVal *obj) { diff --git a/src/lisp.h b/src/lisp.h index 7661845..8e63118 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -19,6 +19,10 @@ void lisp_shutdown(void); DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(progn, (LispVal * forms)); DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body)); +DECLARE_FUNCTION(if, (LispVal * cond, LispVal *then, LispVal *otherwise)); +DECLARE_FUNCTION(and, (LispVal * forms)); +DECLARE_FUNCTION(or, (LispVal * forms)); +DECLARE_FUNCTION(null, (LispVal * datum)); __attribute__((no_sanitize("address"))) void debug_print(FILE *file, LispVal *obj); diff --git a/src/stack.c b/src/stack.c index 408f268..e94de05 100644 --- a/src/stack.c +++ b/src/stack.c @@ -13,24 +13,32 @@ 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.nogc_retval = Qnil; the_stack.unwind_info.set = false; } -static void teardown_local_references(struct LocalReferences *restrict refs) { +static inline void +maybe_clear_object_local_reference(StackFrame *restrict frame, LispVal *obj) { + if (OBJECT_LOWEST_LOCAL_REFERENCE(obj) == frame) { + SET_OBJECT_LOWEST_LOCAL_REFERENCE(obj, NULL); + } +} + +static void teardown_local_references(StackFrame *restrict frame) { + assert(frame->kind == STACK_FRAME_LOCAL_REFERENCES); + struct LocalReferences *restrict refs = &frame->local_references; 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) { for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) { assert(OBJECTP(refs->blocks[i]->refs[j])); - SET_OBJECT_HAS_LOCAL_REFERENCE(refs->blocks[i]->refs[j], false); + maybe_clear_object_local_reference(frame, refs->blocks[i]->refs[j]); } 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); + maybe_clear_object_local_reference( + frame, refs->blocks[num_full_blocks]->refs[i]); } lisp_free(refs->blocks[num_full_blocks]); lisp_free(refs->blocks); @@ -39,54 +47,12 @@ static void teardown_local_references(struct LocalReferences *restrict 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); + teardown_local_references(&the_stack.frames[i]); } } lisp_free(the_stack.frames); } -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 @@ -103,15 +69,15 @@ static ALWAYS_INLINE StackFrame *PUSH_NEW_FRAME(enum StackFrameKind kind) { return frame; } -void push_call_frame(LispVal *name, LispVal *fobj, LispVal *args) { +void push_call_frame(LispVal *name, 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) { +void set_stack_evaluated_args(StackFrame *restrict frame, LispVal *fobj, + LispVal *args) { gc_mark_stack_for_rescan(); assert(frame->kind == STACK_FRAME_CALL); frame->call.args = args; @@ -142,7 +108,8 @@ void push_local_reference_frame(void) { frame->last_references = frame; } -static void store_local_reference_in_frame(StackFrame *frame, LispVal *obj) { +static void store_local_reference_in_frame(StackFrame *restrict 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) { @@ -157,7 +124,7 @@ static void store_local_reference_in_frame(StackFrame *frame, LispVal *obj) { refs->blocks[num_full_blocks] ->refs[refs->num_refs++ % LOCAL_REFERENCES_BLOCK_LENGTH] = obj; } - SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true); + SET_OBJECT_LOWEST_LOCAL_REFERENCE(obj, frame); // mark the frame for rescan frame->marked = false; gc_mark_stack_for_rescan(); @@ -166,7 +133,8 @@ static void store_local_reference_in_frame(StackFrame *frame, LispVal *obj) { 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)) { + StackFrame *current_frame = OBJECT_LOWEST_LOCAL_REFERENCE(obj); + if (OBJECTP(obj) && (!current_frame || current_frame > frame)) { store_local_reference_in_frame(frame, obj); } } @@ -278,3 +246,45 @@ void set_lexical_variable(LispVal *name, LispVal *value) { assert(SYMBOLP(name)); Vlexical_environment = Fplist_put(Vlexical_environment, name, value); } + +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); + 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(); + } +} diff --git a/src/stack.h b/src/stack.h index 6d0f0bf..06a3e8d 100644 --- a/src/stack.h +++ b/src/stack.h @@ -81,10 +81,23 @@ struct LispStack { size_t depth; StackFrame *frames; - LispVal *nogc_retval; 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); +} + +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); +} + extern struct LispStack the_stack; void lisp_init_stack(void); @@ -96,14 +109,13 @@ static ALWAYS_INLINE StackFrame *LISP_STACK_REF(void) { } 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); +void push_call_frame(LispVal *name, 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(StackFrame *restrict ref, LispVal *args); +void set_stack_evaluated_args(StackFrame *restrict ref, LispVal *fobj, + LispVal *args); // unwind protect void push_unwind_protect_frame(jmp_buf *buf); @@ -131,8 +143,16 @@ static ALWAYS_INLINE void push_copy_lexenv(void) { 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)); + Vlexical_environment = CONS(name, CONS(value, Vlexical_environment)); } +void unwind_to(StackFrame *frame); +static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame, + LispVal *val) { + add_local_reference(frame, val); + unwind_to(frame); + return val; +} +noreturn void continue_unwinding(void); + #endif