Zander671/glisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Update function call stuff

Browse Source
This commit is contained in:
Alexander Rosenberg
2026-07-19 00:14:16 -07:00
parent bd7ca2fa25
commit 67b68f8c61
10 changed files with 177 additions and 115 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lisp/kernel.gl
+1 -12
View File
@@ -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)
src/base.c
+19 -2
View File
@@ -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);
src/base.h
+3 -15
View File
@@ -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));
src/function.c
+15 -15
View File
@@ -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();
}
src/gc.c
+3 -6
View File
@@ -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);
src/gc.h
+1 -1
View File
@@ -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;
src/lisp.c
+40 -3
View File
@@ -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) {
src/lisp.h
+4
View File
@@ -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);
src/stack.c
+64 -54
View File
@@ -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();
}
}
src/stack.h
+27 -7
View File
@@ -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