Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix current memory issues

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-14 02:45:44 -07:00
parent eb8d54acb1
commit eb0737e83b
5 changed files with 235 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files

125
src/lisp.c
View File

@ -378,7 +378,7 @@ LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body,
self->oargs = Qnil;
self->rest_arg = Qnil;
self->kwargs = Qnil;
void *cl = register_cleanup(&free_double_ptr, &self);
void *cl = register_cleanup(&lisp_free, self);
set_function_args(self, args);
cancel_cleanup(cl);
@ -465,8 +465,8 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
return !NILP(Fstrings_equal(v1, v2));
} else {
LispVal *eq_obj;
LispVal *args = const_list(2, v1, v2);
WITH_CLEANUP(args, {
LispVal *args = const_list(true, 2, v1, v2);
WITH_CLEANUP_DOUBLE_PTR(args, {
eq_obj = Ffuncall(self->eq_fn, args); //
});
bool result = !NILP(eq_obj);
@ -486,12 +486,12 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
return hash;
} else {
LispVal *hash_obj;
LispVal *args = const_list(1, key);
WITH_CLEANUP(args, {
LispVal *args = const_list(true, 1, key);
WITH_CLEANUP_DOUBLE_PTR(args, {
hash_obj = Ffuncall(self->hash_fn, args); //
});
uint64_t hash;
WITH_CLEANUP(hash_obj, {
WITH_CLEANUP_DOUBLE_PTR(hash_obj, {
CHECK_TYPE(TYPE_INTEGER, hash_obj);
hash = ((LispInteger *) hash_obj)->value;
});
@ -684,16 +684,16 @@ DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv");
void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame));
frame->name = refcount_ref(name);
frame->name = (LispSymbol *) name;
frame->hidden = false;
frame->detail = refcount_ref(detail);
frame->lexenv = refcount_ref(make_lisp_hashtable(Qnil, Qnil));
frame->detail = detail;
frame->lexenv = make_lisp_hashtable(Qnil, Qnil);
if (inherit && the_stack) {
puthash(LISPVAL(frame->lexenv), Qparent_lexenv,
LISPVAL(the_stack->lexenv));
}
frame->enable_handlers = true;
frame->handlers = refcount_ref(make_lisp_hashtable(Qnil, Qnil));
frame->handlers = make_lisp_hashtable(Qnil, Qnil);
frame->unwind_forms = Qnil;
frame->cleanup_handlers = NULL;
@ -710,6 +710,7 @@ void stack_leave(void) {
refcount_unref(frame->handlers);
FOREACH(elt, frame->unwind_forms) {
WITH_PUSH_FRAME(Qnil, Qnil, false, {
the_stack->hidden = true;
refcount_unref(Feval(elt)); //
});
}
@ -786,6 +787,7 @@ DEFUN(backtrace, "backtrace", (void) ) {
Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
refcount_unref(HEAD(new_end));
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
}
@ -796,7 +798,8 @@ DEFUN(backtrace, "backtrace", (void) ) {
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
CHECK_TYPE(TYPE_SYMBOL, signal);
LispVal *error_arg = const_list(2, Fpair(signal, rest), Fbacktrace());
LispVal *error_arg =
const_list(false, 2, Fpair(signal, rest), Fbacktrace());
for (; the_stack; stack_leave()) {
if (!the_stack->enable_handlers) {
continue;
@ -809,30 +812,30 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
}
if (handler != Qunbound) {
the_stack->enable_handlers = false;
LispVal *var = Fhead(handler);
LispVal *form = Ftail(handler);
LispVal *var = HEAD(handler);
LispVal *form = TAIL(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
if (!NILP(var)) {
// TODO make sure this isn't constant
puthash(the_stack->lexenv, var, error_arg);
}
WITH_CLEANUP(error_arg, {
WITH_CLEANUP_DOUBLE_PTR(error_arg, {
refcount_unref(Feval(form)); //
});
});
longjmp(the_stack->start, 1); // return a nonzero value
}
}
// we never used it, so drop it
refcount_unref(error_arg);
fprintf(stderr,
"ERROR: An exception has propogated past the top of the stack!\n");
"ERROR: An exception has propagated past the top of the stack!\n");
fprintf(stderr, "Type: ");
debug_dump(stderr, signal, true);
fprintf(stderr, "Args: ");
debug_dump(stderr, rest, true);
fprintf(stderr, "Lisp will now exit...");
// we never used it, so drop it
refcount_unref(error_arg);
abort();
}
#pragma GCC diagnostic pop
@ -1103,7 +1106,7 @@ static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
while (HASHTABLEP(lexenv)) {
LispVal *value = gethash(lexenv, key, Qunbound);
if (value != Qunbound) {
return value;
return refcount_ref(value);
}
lexenv = gethash(lexenv, Qparent_lexenv, Qunbound);
}
@ -1122,7 +1125,7 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
return sym_val;
}
// TODO free args (not just this call, all calls to Fthrow)
Fthrow(Qvoid_variable_error, const_list(1, key));
Fthrow(Qvoid_variable_error, const_list(true, 1, key));
}
static void breakpoint(int64_t id) {}
@ -1157,22 +1160,26 @@ DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *final_args = Qnil;
void *cl_handle =
register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &final_args);
LispVal *end;
FOREACH(elt, args) {
if (NILP(final_args)) {
final_args = Fpair(Feval_in_env(elt, lexenv), Qnil);
refcount_unref(HEAD(final_args));
end = final_args;
} else {
LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil);
refcount_unref(HEAD(new_end));
Fsettail(end, new_end);
end = new_end;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &unref_double_ptr, &final_args);
LispVal *end;
FOREACH(elt, args) {
if (NILP(final_args)) {
final_args = Fpair(Feval_in_env(elt, lexenv), Qnil);
refcount_unref(HEAD(final_args));
end = final_args;
} else {
LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil);
refcount_unref(HEAD(new_end));
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
}
}
cancel_cleanup(cl_handle);
cancel_cleanup(cl_handle);
});
return final_args;
}
@ -1200,7 +1207,7 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
if (vec[oad->index]) {
goto multikey;
}
args = Ftail(args);
args = TAIL(args);
if (NILP(args)) {
goto key_no_val;
}
@ -1224,7 +1231,7 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
goto too_few;
}
if (!NILP(func->rest_arg)) {
vec[raw_count - 1] = refcount_ref(rest);
vec[raw_count - 1] = rest;
}
for (size_t i = 0; i < raw_count; ++i) {
if (!vec[i]) {
@ -1420,7 +1427,7 @@ static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
}
LispVal *expansion = Fprogn(func->body);
LispVal *retval = Qnil;
WITH_CLEANUP(expansion, {
WITH_CLEANUP_DOUBLE_PTR(expansion, {
// eval in the outer lexenv
retval = Feval_in_env(expansion, args_lexenv);
});
@ -1441,9 +1448,9 @@ static LispVal *call_function(LispVal *func, LispVal *args,
} else {
Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
}
void *cl_handle = register_cleanup(unref_double_ptr, &fobj);
void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj);
if (LISPVAL(fobj) == Qunbound) {
Fthrow(Qvoid_function_error, const_list(1, func));
Fthrow(Qvoid_function_error, const_list(true, 1, func));
} else if (!FUNCTIONP(fobj)) {
Fthrow(Qinvalid_function_error, Fpair(LISPVAL(fobj), Qnil));
} else if (!allow_macro && fobj->is_macro) {
@ -1454,18 +1461,18 @@ static LispVal *call_function(LispVal *func, LispVal *args,
}
LispVal *retval = Qnil;
// builtin macros inherit their parents lexenv
WITH_PUSH_FRAME(func, args, false, {
if (fobj->is_macro && fobj->is_builtin) {
puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv);
}
void *cl_handle =
register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &args);
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args);
} else {
retval = call_lisp_function(func, fobj, args, args_lexenv);
}
cancel_cleanup(cl_handle);
refcount_ref(args);
WITH_CLEANUP(args, {
WITH_PUSH_FRAME(func, args, false, {
if (fobj->is_macro && fobj->is_builtin) {
puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv);
}
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args);
} else {
retval = call_lisp_function(func, fobj, args, args_lexenv);
}
});
});
cancel_cleanup(cl_handle);
return retval;
@ -1522,7 +1529,7 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
return refcount_ref(form);
}
LispVal *expansion = Qnil;
WITH_CLEANUP(fobj, {
WITH_CLEANUP_DOUBLE_PTR(fobj, {
WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, {
puthash(the_stack->lexenv, Qparent_lexenv, fobj->lexenv);
process_lisp_args(Fhead(form), fobj, Ftail(form),
@ -1554,7 +1561,7 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
if (LISTP(HEAD(rest))) {
// ensure the list is not circular
refcount_ref(args);
WITH_CLEANUP(args, {
WITH_CLEANUP_DOUBLE_PTR(args, {
list_length(Fhead(rest)); //
});
if (NILP(args)) {
@ -1574,7 +1581,7 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
}
}
LispVal *retval;
WITH_CLEANUP(args, {
WITH_CLEANUP_DOUBLE_PTR(args, {
retval = Ffuncall(function, args); //
});
return retval;
@ -1592,7 +1599,7 @@ DEFUN(exit, "exit", (LispVal * code)) {
if (!NILP(code) && !INTEGERP(code)) {
Fthrow(Qtype_error, Qnil);
}
Fthrow(Qshutdown_signal, const_list(1, code));
Fthrow(Qshutdown_signal, const_list(true, 1, code));
}
DEFMACRO(quote, "'", (LispVal * form)) {
@ -1696,7 +1703,7 @@ DEFUN(add, "+", (LispVal * args)) {
LispVal *out = copy_number(Fhead(args));
FOREACH(arg, Ftail(args)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
WITH_CLEANUP_DOUBLE_PTR(old_out, {
ONE_MATH_OPERAION(+, out, out, arg); //
});
}
@ -1710,7 +1717,7 @@ DEFUN(sub, "-", (LispVal * args)) {
LispVal *out = copy_number(Fhead(args));
FOREACH(arg, Ftail(args)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
WITH_CLEANUP_DOUBLE_PTR(old_out, {
ONE_MATH_OPERAION(-, out, out, arg); //
});
}
@ -1740,7 +1747,7 @@ DEFMACRO(setq, "setq", (LispVal * args)) {
FOREACH_TAIL(tail, args) {
CHECK_TYPE(TYPE_SYMBOL, HEAD(tail));
LispVal *name = HEAD(tail);
tail = HEAD(tail);
tail = TAIL(tail);
retval = Feval(HEAD(tail));
set_symbol_in_lexenv(name, retval, the_stack->lexenv);
}
@ -1879,7 +1886,7 @@ DEFMACRO(and, "and", (LispVal * rest)) {
LispVal *retval = Qnil;
FOREACH(cond, rest) {
LispVal *nc;
WITH_CLEANUP(retval, {
WITH_CLEANUP_DOUBLE_PTR(retval, {
nc = Feval(cond); //
});
if (NILP(nc)) {