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

Compare commits

base: Zander671:1a0906206a4459da8bf40308aff6e7274e50cc7f
Branches Tags
Zander671:main
...
compare: Zander671:main
Branches Tags
Zander671:main

14 Commits
1a0906206a ... main

Author SHA1 Message Date
Alexander Rosenberg
d21a5726e0 Fix gc bug and add condition classes 2026-02-28 13:22:34 -08:00
Alexander Rosenberg
45f6d7a53d Change to incremental GC 2026-02-28 09:11:21 -08:00
Alexander Rosenberg
a76e6a335d Clean some stuff up 2026-01-29 21:42:47 -08:00
Alexander Rosenberg
e5def8a0ad Fix leak 2026-01-29 00:20:17 -08:00
Alexander Rosenberg
a64051403a Allow calling lambdas directly 2026-01-29 00:15:18 -08:00
Alexander Rosenberg
a469e137b4 Fix double free 2026-01-29 00:05:02 -08:00
Alexander Rosenberg
5029405a70 Work on functions 2026-01-29 00:00:05 -08:00
Alexander Rosenberg
22ffac9321 Add basic lexenv support 2026-01-28 16:07:48 -08:00
Alexander Rosenberg
76b28c1dc0 Fix some memory leaks 2026-01-28 14:54:15 -08:00
Alexander Rosenberg
de43dfcda2 Remove bytecomp stuff (for now) 2026-01-28 14:29:01 -08:00
Alexander Rosenberg
05bcb77f24 Work on GC 2026-01-24 22:37:14 -08:00
Alexander Rosenberg
f67ed56d52 Some work 2026-01-22 21:08:02 -08:00
Alexander Rosenberg
eca8ae3d3e Better gc stats 2026-01-22 07:51:22 -08:00
Alexander Rosenberg
6cc85491cf Initial tricolor implementation 2026-01-22 07:49:47 -08:00
20 changed files with 1038 additions and 436 deletions
Expand all files Collapse all files

14
.clangd
View File

@@ -1,13 +1,21 @@
CompileFlags:
Add: [-std=c11, -Wall, -Wpedantic, -xc, -D_POSIX_C_SOURCE=199309L]
Add:
[
-std=c11,
-Wall,
-Wpedantic,
-xc,
-D_POSIX_C_SOURCE=200112L,
"-Isrc",
"-I../",
]
Compiler: gcc
---
If:
PathMatch: .*\.h
CompileFlags:
Remove: -xc
Add: [-std=c11, -Wall, -Wpedantic, -xc-header]
Compiler: gcc
Add: -xc-header
---
If:
PathMatch: bin/.*\.c

17
Makefile
View File

@@ -1,4 +1,5 @@
DEBUG=1
LLVM_SAN=1
ifeq ($(DEBUG),1)
DEBUG_CFLAGS=-g
@@ -6,10 +7,17 @@ else
DEBUG_CFLAGS=-D_NDEBUG
endif
ifeq ($(LLVM_SAN),1)
LLVM_SAN_FLAGS=-fsanitize=address,undefined
else
LLVM_SAN_FLAGS=
endif
CC=gcc
CFLAGS=$(DEBUG_CFLAGS) -std=c11 -Wall -Wpedantic -D_POSIX_C_SOURCE=199309L
CFLAGS=$(DEBUG_CFLAGS) $(LLVM_SAN_FLAGS) -std=c11 -Wall -Wpedantic $\
-D_POSIX_C_SOURCE=200112L
LD=gcc
LDFLAGS=
LDFLAGS=$(LLVM_SAN_FLAGS)
SRCS:=$(wildcard src/*.c)
OBJS:=$(SRCS:src/%.c=bin/%.o)
@@ -26,12 +34,11 @@ glisp: $(OBJS)
$(LD) $(LDFLAGS) -o $@ $^
bin/init_globals.c: $(filter-out bin/init_globals.c,$(SRCS_WITH_HEADERS)) src/gen-init-globals.awk
@mkdir -p bin/
awk -f src/gen-init-globals.awk $(filter-out src/gen-init-globals.awk,$^) >$@
bin/%.o: src/%.c
@mkdir -p bin/deps
$(CC) $(CFLAGS) -c -MMD -MF $(<:src/%.c=bin/deps/%.d) -o $@ $<
@mkdir -p $(dir $(<:src/%.c=bin/deps/%.d) $(<:src/%.c=bin/%))
$(CC) $(CFLAGS) -c -MMD -MF $(<:src/%.c=bin/deps/%.d) -I src/ -o $@ $<
bin/init_globals.o: bin/init_globals.c
@mkdir -p bin/deps

14
lisp/kernel.gl Normal file
View File

@@ -0,0 +1,14 @@
;; -*- 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))

55
src/base.c
View File

@@ -3,6 +3,7 @@
#include "gc.h"
#include "hashtable.h"
#include "lisp.h"
#include "list.h"
#include "stack.h"
#include <stdio.h>
@@ -19,6 +20,8 @@ const char *LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_FUNCTION] = "function",
};
bool lisp_gc_on_alloc;
void *lisp_alloc_object_no_gc(size_t size, LispValType type) {
assert(size >= sizeof(LispObject));
LispObject *obj = lisp_aligned_alloc(LISP_OBJECT_ALIGNMENT, size);
@@ -30,6 +33,9 @@ void *lisp_alloc_object_no_gc(size_t size, LispValType type) {
void *lisp_alloc_object(size_t size, LispValType type) {
LispObject *obj = lisp_alloc_object_no_gc(size, type);
if (lisp_gc_on_alloc && the_stack.depth) {
lisp_gc_yield(NULL, false);
}
if (the_stack.depth > 0) {
add_local_reference_no_recurse(obj);
}
@@ -50,7 +56,7 @@ void internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
fprintf(stderr, "Type error! Got: %s | Expected: (or ",
LISP_TYPE_NAMES[TYPE_OF(obj)]);
for (size_t i = 0; i < count; ++i) {
fprintf(stderr, "%s%s", LISP_TYPE_NAMES[i],
fprintf(stderr, "%s%s", LISP_TYPE_NAMES[types[i]],
i < count - 1 ? " " : ")\n");
}
abort();
@@ -75,7 +81,7 @@ DEFUN(id, "id", (LispVal * obj), "(id)", "") {
}
DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
return obj1 == obj2 ? Qt : Qnil;
return EQ(obj1, obj2) ? Qt : Qnil;
}
DEFSPECIAL(quote, "quote", (LispVal * form), "(form)", "") {
@@ -134,6 +140,51 @@ DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve),
return sym;
}
DEFUN(symbol_plist, "symbol-plist", (LispVal * sym), "(sym)", "") {
CHECK_TYPE(sym, TYPE_SYMBOL);
return ((LispSymbol *) sym)->plist;
}
DEFUN(setplist, "setplist", (LispVal * sym, LispVal *plist), "(sym plist)",
"") {
CHECK_TYPE(sym, TYPE_SYMBOL);
return ((LispSymbol *) sym)->plist = plist;
}
DEFUN(get, "get", (LispVal * sym, LispVal *key, LispVal *def),
"(sym key &optional def)", "") {
return Fplist_get(Fsymbol_plist(sym), key, def);
}
DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)",
"") {
return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val));
}
DEFINE_SYMBOL(condition_class, "condition-class");
DEFUN(condition_class_p, "condition-class-p", (LispVal * val), "(val)", "") {
if (!SYMBOLP(val)) {
return Qnil;
}
LispVal *class = Fget(val, Qcondition_class, Qnil);
return !NILP(class) && SYMBOLP(class) ? class : Qnil;
}
DEFUN(condition_subclass_p, "condition-subclass-p",
(LispVal * child, LispVal *parent), "(child parent)", "") {
if (parent == child || (parent == Qt && SYMBOLP(child))) {
return Qt;
}
LispVal *cur = child;
while (!NILP((cur = Fcondition_class_p(cur))) && cur != Qt) {
if (cur == parent) {
return Qt;
}
}
return Qnil;
}
DEFINE_SYMBOL(backquote, "`");
DEFINE_SYMBOL(comma, ",");
DEFINE_SYMBOL(comma_at, ",@");

44
src/base.h
View File

@@ -37,8 +37,8 @@ static ALWAYS_INLINE uintptr_t EXTRACT_TAG(LispVal *val) {
#define LISP_OBJECT_TAG ((uintptr_t) 0)
// 0b01
#define FIXNUM_TAG ((uintptr_t) 1)
// 0b11
#define LISP_FLOAT_TAG ((uintptr_t) 3)
// 0b10
#define LISP_FLOAT_TAG ((uintptr_t) 2)
static ALWAYS_INLINE bool LISP_OBJECT_P(LispVal *val) {
return EXTRACT_TAG(val) == LISP_OBJECT_TAG;
@@ -54,7 +54,7 @@ static ALWAYS_INLINE fixnum_t XFIXNUM(LispVal *val) {
}
static ALWAYS_INLINE LispVal *MAKE_FIXNUM(fixnum_t fn) {
return (LispVal *) ((fn << 2) | FIXNUM_TAG);
return (LispVal *) ((((uintptr_t) fn) << 2) | FIXNUM_TAG);
}
static ALWAYS_INLINE bool LISP_FLOAT_P(LispVal *val) {
@@ -77,14 +77,14 @@ static ALWAYS_INLINE LispVal *MAKE_LISP_FLOAT(lisp_float_t flt) {
// # Other types #
// ###############
typedef enum {
TYPE_FIXNUM,
TYPE_FLOAT,
TYPE_CONS,
TYPE_STRING,
TYPE_SYMBOL,
TYPE_VECTOR,
TYPE_HASH_TABLE,
TYPE_FUNCTION,
TYPE_FIXNUM = 0,
TYPE_FLOAT = 1,
TYPE_CONS = 2,
TYPE_STRING = 3,
TYPE_SYMBOL = 4,
TYPE_VECTOR = 5,
TYPE_HASH_TABLE = 6,
TYPE_FUNCTION = 7,
N_LISP_TYPES,
} LispValType;
extern const char *LISP_TYPE_NAMES[N_LISP_TYPES];
@@ -94,6 +94,8 @@ typedef struct {
ObjectGCInfo gc;
} LispObject;
extern bool lisp_gc_on_alloc;
#define LISP_OBJECT_ALIGNMENT (1 << LISP_TAG_BITS)
LispVal *lisp_alloc_object_no_gc(size_t size, LispValType type);
LispVal *lisp_alloc_object(size_t size, LispValType type);
@@ -133,9 +135,8 @@ static ALWAYS_INLINE bool OBJECT_STATIC_P(LispVal *val) {
}
static inline void MARK_OBJECT_ADDED(LispVal *val, LispVal *into) {
ObjectGCSet val_set = OBJECT_GET_GC_SET(val);
ObjectGCSet into_set = OBJECT_GET_GC_SET(into);
if (into_set == GC_BLACK && val_set == GC_WHITE) {
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);
}
}
@@ -271,7 +272,7 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
REGISTER_GLOBAL_SYMBOL(cname); \
((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
((LispFunction *) ((LispSymbol *) Q##cname)->function) \
->flags.no_eval_args = true; \
->impl.native.no_eval_args = true; \
}
DECLARE_SYMBOL(nil);
@@ -282,6 +283,10 @@ static ALWAYS_INLINE bool NILP(LispVal *val) {
return val == Qnil;
}
static ALWAYS_INLINE bool EQ(LispVal *val1, LispVal *val2) {
return val1 == val2;
}
// Some core functions
DECLARE_FUNCTION(id, (LispVal * obj));
DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
@@ -292,6 +297,15 @@ LispVal *make_vector(LispVal **data, size_t length, bool take);
DECLARE_FUNCTION(make_symbol, (LispVal * name));
DECLARE_FUNCTION(intern, (LispVal * name));
DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve));
DECLARE_FUNCTION(symbol_plist, (LispVal * sym));
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));
// condition stuff
DECLARE_SYMBOL(condition_class);
DECLARE_FUNCTION(condition_class_p, (LispVal * val));
DECLARE_FUNCTION(condition_subclass_p, (LispVal * child, LispVal *parent));
// Defined in lisp code (eventually) but used in read.c
DECLARE_SYMBOL(backquote);

298
src/function.c
View File

@@ -46,15 +46,19 @@ static LispVal *intern_as_keyword(LispVal *name) {
}
// on error, put the object that caused the problem in entry
static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
LispVal *entry) {
static LambdaListParseStatus
parse_optional_arg_spec(LispVal *used_names, LispVal **out, LispVal *entry) {
// single symbol
if (SYMBOLP(entry)) {
if (!is_valid_variable_name(entry)) {
*out = entry;
return LLPS_BAD_NAME;
} else if (!NILP(Fgethash(used_names, entry, Qnil))) {
*out = entry;
return LLPS_REPEAT_NAME;
}
*out = LIST(entry, Qnil, Qnil);
Fputhash(used_names, entry, Qt);
return LLPS_OK;
} else if (!CONSP(entry)) {
*out = entry;
@@ -65,7 +69,11 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
if (!is_valid_variable_name(name)) {
*out = name;
return LLPS_BAD_NAME;
} else if (!NILP(Fgethash(used_names, name, Qnil))) {
*out = name;
return LLPS_REPEAT_NAME;
}
Fputhash(used_names, name, Qt);
if (list_length_eq(entry, 1)) {
*out = LIST(XCAR(entry), Qnil, Qnil);
return LLPS_OK;
@@ -75,8 +83,13 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
} else if (list_length_eq(entry, 3)) {
LispVal *pvar = XCAR(XCDR(XCDR(entry)));
if (!is_valid_variable_name(pvar)) {
*out = pvar;
return LLPS_BAD_NAME;
} else if (!NILP(Fgethash(used_names, pvar, Qnil))) {
*out = pvar;
return LLPS_REPEAT_NAME;
}
Fputhash(used_names, pvar, Qt);
*out = LIST(XCAR(entry), XCAR(XCDR(entry)), pvar);
return LLPS_OK;
} else {
@@ -87,6 +100,7 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
#define RETURN_ERROR(err, obj) \
{ \
release_hash_table_no_gc(used_names); \
result->status = err; \
result->err_obj = (obj); \
return; \
@@ -97,6 +111,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
result->err_obj = Qnil;
result->status = LLPS_OK;
struct LambdaList *out = &result->lambda_list;
LispVal *used_names = make_hash_table_no_gc(Qnil, Qnil);
// TODO check for repeat names
out->n_req = 0;
out->n_opt = 0;
@@ -106,7 +121,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
out->kw = Qnil;
out->rest = Qnil;
size_t cur_idx = 0; // for keyword args
FOREACH_TAIL(list, tail) {
DOTAILS(tail, list) {
if (!LISTP(tail)) {
RETURN_ERROR(LLPS_DOTTED, list);
} else if (out->allow_other_keys) {
@@ -148,12 +163,16 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
RETURN_ERROR(LLPS_REPEAT_REST, cur);
} else if (!is_valid_variable_name(cur)) {
RETURN_ERROR(LLPS_BAD_NAME, cur)
} else if (!NILP(Fgethash(used_names, cur, Qnil))) {
RETURN_ERROR(LLPS_REPEAT_NAME, cur);
}
Fputhash(used_names, cur, Qt);
out->rest = cur;
++cur_idx;
} else if (mode == OPT || mode == KEY) {
LispVal *entry;
LambdaListParseStatus status = parse_optional_arg_spec(&entry, cur);
LambdaListParseStatus status =
parse_optional_arg_spec(used_names, &entry, cur);
if (status != LLPS_OK) {
RETURN_ERROR(status, entry)
}
@@ -167,7 +186,10 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
++cur_idx;
} else if (!is_valid_variable_name(cur)) {
RETURN_ERROR(LLPS_BAD_NAME, cur);
} else if (!NILP(Fgethash(used_names, cur, Qnil))) {
RETURN_ERROR(LLPS_REPEAT_NAME, cur);
} else {
Fputhash(used_names, cur, Qt);
out->req = CONS(cur, out->req);
++out->n_req;
++cur_idx;
@@ -175,18 +197,19 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
}
out->req = Fnreverse(out->req);
out->opt = Fnreverse(out->opt);
release_hash_table_no_gc(used_names);
}
#undef RETURN_ERROR
LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(),
LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void),
const char *lisp_args, size_t args_len,
LispVal *docstr) {
LispFunction *obj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION);
obj->name = name;
obj->flags.type = FUNCTION_NATIVE;
obj->flags.no_eval_args = false;
obj->type = FUNCTION_NATIVE;
obj->docstr = docstr;
obj->impl.native.zero = cfunc;
obj->impl.native.no_eval_args = false;
obj->impl.native.addr.zero = cfunc;
ReadStream stream;
read_stream_init(&stream, lisp_args, args_len);
LispVal *args_form = read(&stream);
@@ -212,61 +235,19 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(),
}
// Calling functions
// A simple function has only required args
static ALWAYS_INLINE bool SIMPLE_FUNCTION_P(LispFunction *fobj) {
return !fobj->args.n_opt
&& (NILP(fobj->args.kw) || !HASH_TABLE_COUNT(fobj->args.kw))
&& NILP(fobj->args.rest);
}
static ALWAYS_INLINE LispVal *
call_simple_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
assert(fobj->args.n_req <= MAX_NATIVE_FUNCTION_ARGS);
push_stack_frame(orig_func, fobj, args);
if (!list_length_eq(args, fobj->args.n_req)) {
// TODO incorrect arg count
fprintf(stderr, "Wrong arg count!!\n");
abort();
}
LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS];
size_t acount = 0;
FOREACH(args, arg) {
if (fobj->flags.no_eval_args) {
arg_arr[acount] = arg;
static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) {
LispVal *start = Qnil;
LispVal *end;
DOLIST(arg, args) {
if (NILP(start)) {
start = CONS(Feval(arg, PARENT_LEXENV()), Qnil);
end = start;
} else {
arg_arr[acount] = Feval(arg);
RPLACD(end, CONS(Feval(arg, PARENT_LEXENV()), Qnil));
end = XCDR(end);
}
add_local_reference(arg_arr[acount++]);
}
LispVal *retval;
switch (acount) {
case 0:
retval = fobj->impl.native.zero();
break;
case 1:
retval = fobj->impl.native.one(arg_arr[0]);
break;
case 2:
retval = fobj->impl.native.two(arg_arr[0], arg_arr[1]);
break;
case 3:
retval = fobj->impl.native.three(arg_arr[0], arg_arr[1], arg_arr[2]);
break;
case 4:
retval = fobj->impl.native.four(arg_arr[0], arg_arr[1], arg_arr[2],
arg_arr[3]);
break;
case 5:
retval = fobj->impl.native.five(arg_arr[0], arg_arr[1], arg_arr[2],
arg_arr[3], arg_arr[4]);
break;
default:
abort();
}
the_stack.nogc_retval = retval;
pop_stack_frame();
add_local_reference(the_stack.nogc_retval);
return retval;
return start;
}
enum ProcessArgsResult {
@@ -298,7 +279,8 @@ static ALWAYS_INLINE size_t NATIVE_FUNCTION_TOTAL_ARG_COUNT(LispVal *val) {
static ALWAYS_INLINE enum ProcessArgsResult
process_complex_native_args(LispFunction *fobj, LispVal *args,
LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS]) {
LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS],
intptr_t *rest_idx) {
size_t rem_req = fobj->args.n_req;
size_t rem_opt = fobj->args.n_opt;
size_t idx = 0;
@@ -320,7 +302,10 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
return PROCESS_ARGS_TOO_MANY;
}
if (!NILP(fobj->args.rest)) {
*rest_idx = idx;
out[idx++] = args;
} else {
*rest_idx = -1;
}
if (NILP(fobj->args.kw)) { // we are not a keyword function
return PROCESS_ARGS_OK;
@@ -343,12 +328,18 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
return PROCESS_ARGS_OK;
}
static ALWAYS_INLINE LispVal *
call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
LispFunction *fobj, LispVal *args) {
push_stack_frame(orig_func, fobj, args);
if (!fobj->impl.native.no_eval_args) {
args = evaluate_function_arguments(args);
}
set_stack_evaluated_args(args);
LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL};
size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj);
intptr_t rest_idx;
enum ProcessArgsResult res =
process_complex_native_args(fobj, args, arg_arr);
process_complex_native_args(fobj, args, arg_arr, &rest_idx);
if (res != PROCESS_ARGS_OK) {
// TODO better errors
printf("Bad arguments to builtin \"");
@@ -356,35 +347,33 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
printf("\": %s\n", process_args_strerror(res));
abort();
}
push_stack_frame(orig_func, fobj, args);
for (intptr_t i = 0; i < count; ++i) {
if (!arg_arr[i]) {
arg_arr[i] = Qnil;
} else if (!fobj->flags.no_eval_args) {
arg_arr[i] = Feval(arg_arr[i]);
}
add_local_reference(arg_arr[i]);
}
LispVal *retval;
switch (count) {
case 0:
retval = fobj->impl.native.zero();
retval = fobj->impl.native.addr.zero();
break;
case 1:
retval = fobj->impl.native.one(arg_arr[0]);
retval = fobj->impl.native.addr.one(arg_arr[0]);
break;
case 2:
retval = fobj->impl.native.two(arg_arr[0], arg_arr[1]);
retval = fobj->impl.native.addr.two(arg_arr[0], arg_arr[1]);
break;
case 3:
retval = fobj->impl.native.three(arg_arr[0], arg_arr[1], arg_arr[2]);
retval =
fobj->impl.native.addr.three(arg_arr[0], arg_arr[1], arg_arr[2]);
break;
case 4:
retval = fobj->impl.native.four(arg_arr[0], arg_arr[1], arg_arr[2],
retval = fobj->impl.native.addr.four(arg_arr[0], arg_arr[1], arg_arr[2],
arg_arr[3]);
break;
case 5:
retval = fobj->impl.native.five(arg_arr[0], arg_arr[1], arg_arr[2],
retval = fobj->impl.native.addr.five(arg_arr[0], arg_arr[1], arg_arr[2],
arg_arr[3], arg_arr[4]);
break;
default:
@@ -396,35 +385,166 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
return retval;
}
static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
LispFunction *fobj, LispVal *args) {
if (SIMPLE_FUNCTION_P(fobj)) {
return call_simple_native(orig_func, fobj, args);
static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec,
LispVal *value) {
new_lexical_variable(XCAR(spec), value);
if (!NILP(THIRD(spec))) {
new_lexical_variable(THIRD(spec), Qt);
}
return call_complex_native(orig_func, fobj, args);
}
static ALWAYS_INLINE void
push_missing_optional_argument_to_lexenv(LispVal *spec) {
new_lexical_variable(XCAR(spec), Feval(SECOND(spec), TOP_LEXENV()));
if (!NILP(THIRD(spec))) {
new_lexical_variable(THIRD(spec), Qnil);
}
}
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)) {
if (NILP(args)) {
return PROCESS_ARGS_TOO_FEW;
}
new_lexical_variable(XCAR(rem_req), XCAR(args));
args = XCDR(args);
rem_req = XCDR(rem_req);
}
while (!NILP(rem_opt) && !NILP(args)) {
push_optional_argument_to_lexenv(XCAR(rem_opt), XCAR(args));
args = XCDR(args);
rem_opt = XCDR(rem_opt);
}
while (!NILP(rem_opt)) {
push_missing_optional_argument_to_lexenv(XCAR(rem_opt));
rem_opt = XCDR(rem_opt);
}
if (!NILP(fobj->args.rest)) {
new_lexical_variable(fobj->args.rest, args);
}
if (NILP(fobj->args.kw)) {
return !NILP(args) && NILP(fobj->args.rest) ? PROCESS_ARGS_TOO_MANY
: PROCESS_ARGS_OK;
}
LispVal *seen_kw = make_hash_table_no_gc(Qnil, Qnil);
while (!NILP(args)) {
if (NILP(XCDR(args))) {
release_hash_table_no_gc(seen_kw);
return PROCESS_ARGS_NO_KEY_VALUE;
}
// has index in front
LispVal *i_spec = Fgethash(fobj->args.kw, XCAR(args), Qnil);
if (!NILP(i_spec)) {
Fputhash(seen_kw, XCAR(args), Qt);
push_optional_argument_to_lexenv(XCDR(i_spec), SECOND(args));
} else if (!fobj->args.allow_other_keys) {
release_hash_table_no_gc(seen_kw);
return PROCESS_ARGS_BAD_KEY;
}
args = XCDR(XCDR(args));
}
HT_FOREACH_INDEX(fobj->args.kw, i) {
if (NILP(Fgethash(seen_kw, HASH_KEY(fobj->args.kw, i), Qnil))) {
push_missing_optional_argument_to_lexenv(
XCDR(HASH_VALUE(fobj->args.kw, i)));
}
}
release_hash_table_no_gc(seen_kw);
return PROCESS_ARGS_OK;
}
static ALWAYS_INLINE LispVal *
call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
push_stack_frame(orig_func, fobj, args);
LispVal *evaled_args = evaluate_function_arguments(args);
set_stack_evaluated_args(evaled_args);
enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, args);
if (par != PROCESS_ARGS_OK) {
// TODO better error handling
fprintf(stderr, "Bad args to interp func: %s\n",
process_args_strerror(par));
abort();
}
LispVal *rval = Fprogn(fobj->impl.interp.body);
the_stack.nogc_retval = rval;
pop_stack_frame();
add_local_reference(rval);
return rval;
}
DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
"") {
CHECK_TYPE(func, TYPE_FUNCTION, TYPE_SYMBOL);
LispFunction *fobj = func;
if (SYMBOLP(func)) {
fobj = Fsymbol_function(func, Qt);
} else if (CONSP(func) && EQ(XCAR(func), Qlambda)) {
fobj = Feval(func, TOP_LEXENV());
}
if (!FUNCTIONP(fobj)) {
// TODO error
abort();
}
if (!fobj->flags.no_eval_args) {
// TODO evaluate arguments
}
switch (fobj->flags.type) {
// include symbol here for the error message
CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL);
switch (fobj->type) {
case FUNCTION_NATIVE:
return call_native(func, fobj, args);
case FUNCTION_INTERP:
case FUNCTION_BYTECOMP:
return call_interpreted(func, fobj, args);
default:
// TODO implement
abort();
}
}
static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) {
while (CONSP(body) && CONSP(XCAR(body)) && EQ(XCAR(XCAR(body)), Qdeclare)) {
LispVal *decls = XCDR(XCAR(body));
DOLIST(decl, decls) {
if (EQ(XCAR(decl), Qname)) {
CHECK_TYPE(SECOND(decl), TYPE_SYMBOL);
if (!list_length_eq(decl, 2)) {
// TODO better error
fprintf(stderr, "Invalid (declare (name ...)) form!\n");
abort();
}
fobj->name = SECOND(decl);
}
}
body = XCDR(body);
}
return body;
}
DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body),
"(args &rest body)", "") {
LambdaListParseResult llpr;
parse_lambda_list(&llpr, args);
if (llpr.status != LLPS_OK) {
// TODO better handling
fprintf(stderr,
"Lambda list parse error: %s: ", llps_strerror(llpr.status));
debug_print(stderr, args);
fputc('\n', stderr);
abort();
}
CHECK_LISTP(body);
LispFunction *fobj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION);
fobj->name = Qnil;
fobj->args = llpr.lambda_list;
fobj->type = FUNCTION_INTERP;
if (STRINGP(XCAR(body))) {
fobj->docstr = XCAR(body);
if (CONSP(XCDR(body))) {
body = XCDR(body);
}
} else {
fobj->docstr = Qnil;
}
body = parse_lambda_declare_form(fobj, body);
fobj->impl.interp.body = body;
fobj->impl.interp.lexenv = PARENT_LEXENV();
return fobj;
}
DEFINE_SYMBOL(declare, "declare");
DEFINE_SYMBOL(name, "name");

27
src/function.h
View File

@@ -2,7 +2,6 @@
#define INCLUDED_FUNCTION_H
#include "base.h"
#include "lisp_string.h"
DECLARE_SYMBOL(and_optional);
DECLARE_SYMBOL(and_rest);
@@ -22,33 +21,36 @@ struct LambdaList {
};
#define MAX_NATIVE_FUNCTION_ARGS 5
union native_function {
struct native_function {
bool no_eval_args;
union {
LispVal *(*zero)(void);
LispVal *(*one)(LispVal *);
LispVal *(*two)(LispVal *, LispVal *);
LispVal *(*three)(LispVal *, LispVal *, LispVal *);
LispVal *(*four)(LispVal *, LispVal *, LispVal *, LispVal *);
LispVal *(*five)(LispVal *, LispVal *, LispVal *, LispVal *, LispVal *);
} addr;
};
struct interp_function {
LispVal *body; // list of forms
LispVal *lexenv;
};
typedef enum {
FUNCTION_NATIVE,
FUNCTION_INTERP,
FUNCTION_BYTECOMP,
} LispFunctionType;
struct function_flags {
LispFunctionType type : 2;
unsigned int no_eval_args : 1;
};
DEFOBJTYPE(Function, FUNCTION, FUNCTIONP, {
LispVal *name; // symbol (or nil for a lambda)
struct function_flags flags;
LispFunctionType type;
struct LambdaList args;
LispVal *docstr;
union {
union native_function native;
struct native_function native;
struct interp_function interp;
} impl;
});
@@ -90,4 +92,9 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(void),
DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args));
#define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__)))
DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
DECLARE_SYMBOL(declare);
DECLARE_SYMBOL(name);
#endif

428
src/gc.c
View File

@@ -8,122 +8,9 @@
#include <stdlib.h>
void free_object_process_stack(ObjectProcessStack *restrict stack) {
for (size_t i = 0; i < stack->num_blocks; ++i) {
lisp_free(stack->blocks[i]);
}
lisp_free(stack->blocks);
}
// Ensure STACK can hold at least NEW_ENTS more entries
static void ensure_object_process_stack_size(ObjectProcessStack *restrict stack,
size_t new_ents) {
size_t total_spaces = stack->num_blocks * OBJECT_PROCESS_STACK_BLOCK_SIZE;
size_t ents_left = total_spaces - stack->num_objs;
if (ents_left < new_ents) {
// grow the stack
size_t need_to_alloc =
(new_ents - ents_left) / OBJECT_PROCESS_STACK_BLOCK_SIZE;
if ((new_ents - ents_left) % OBJECT_PROCESS_STACK_BLOCK_SIZE != 0) {
++need_to_alloc;
}
stack->blocks = lisp_realloc(stack->blocks,
sizeof(struct ObjectProcessStackBlock *)
* (stack->num_blocks + need_to_alloc));
for (size_t i = 0; i < need_to_alloc; ++i) {
stack->blocks[i + stack->num_blocks] =
lisp_malloc(sizeof(struct ObjectProcessStackBlock));
}
stack->num_blocks += need_to_alloc;
}
}
// this does NOT check if there is actually space to push the object, so make
// sure to expand the stack with the above function before pushing
static ALWAYS_INLINE void
add_to_object_process_stack(ObjectProcessStack *restrict stack, void *obj) {
if (OBJECTP(obj)) {
size_t block_idx = stack->num_objs / OBJECT_PROCESS_STACK_BLOCK_SIZE;
size_t small_idx = stack->num_objs % OBJECT_PROCESS_STACK_BLOCK_SIZE;
stack->blocks[block_idx]->objs[small_idx] = obj;
++stack->num_objs;
}
}
void object_process_stack_push_held_objects(ObjectProcessStack *restrict stack,
void *obj) {
if (!OBJECTP(obj)) {
return;
}
switch (((LispObject *) obj)->type) {
case TYPE_CONS:
ensure_object_process_stack_size(stack, 2);
add_to_object_process_stack(stack, XCAR(obj));
add_to_object_process_stack(stack, XCDR(obj));
break;
case TYPE_SYMBOL: {
LispSymbol *sym = obj;
ensure_object_process_stack_size(stack, 4);
add_to_object_process_stack(stack, sym->name);
add_to_object_process_stack(stack, sym->value);
add_to_object_process_stack(stack, sym->function);
add_to_object_process_stack(stack, sym->plist);
break;
}
case TYPE_VECTOR: {
LispVector *vec = obj;
for (size_t i = 0; i < vec->length; ++i) {
if (OBJECTP(vec->data[i])) {
ensure_object_process_stack_size(stack, 1);
}
add_to_object_process_stack(stack, vec->data[i]);
}
break;
}
case TYPE_FUNCTION: {
LispFunction *fobj = obj;
ensure_object_process_stack_size(stack, 6);
add_to_object_process_stack(stack, fobj->name);
add_to_object_process_stack(stack, fobj->docstr);
add_to_object_process_stack(stack, fobj->args.req);
add_to_object_process_stack(stack, fobj->args.opt);
add_to_object_process_stack(stack, fobj->args.kw);
add_to_object_process_stack(stack, fobj->args.rest);
// TODO when other function types are added, record their held
// references
break;
}
case TYPE_HASH_TABLE: {
HT_FOREACH_INDEX(obj, i) {
if (OBJECTP(HASH_KEY(obj, i)) || OBJECTP(HASH_VALUE(obj, i))) {
ensure_object_process_stack_size(stack, 2);
}
add_to_object_process_stack(stack, HASH_KEY(obj, i));
add_to_object_process_stack(stack, HASH_VALUE(obj, i));
}
break;
}
case TYPE_STRING:
// holds no references break;
break;
case TYPE_FIXNUM:
case TYPE_FLOAT:
default:
abort();
}
}
void *object_process_stack_pop(ObjectProcessStack *restrict stack) {
assert(stack->num_objs > 0);
--stack->num_objs;
size_t block_idx = stack->num_objs / OBJECT_PROCESS_STACK_BLOCK_SIZE;
size_t small_idx = stack->num_objs % OBJECT_PROCESS_STACK_BLOCK_SIZE;
return stack->blocks[block_idx]->objs[small_idx];
}
bool lisp_doing_gc;
struct timespec total_gc_time;
size_t total_gc_count;
size_t lisp_gc_count;
struct GCObjectList {
LispVal *obj;
@@ -144,13 +31,32 @@ ObjectGCSet GC_BLACK = 0;
ObjectGCSet GC_GREY = 1;
ObjectGCSet GC_WHITE = 2;
enum IncrementalGCSetp {
GC_STEP_STATICS,
GC_STEP_STACK,
GC_STEP_HEAP,
GC_STEP_FREE,
};
struct IncrementalGCState {
enum IncrementalGCSetp step;
struct GCObjectList *next_static;
};
static struct IncrementalGCState incremental_state = {
.step = GC_STEP_STATICS,
.next_static = NULL,
};
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 {
} else if (set == GC_WHITE) {
return &white_objects;
} else {
abort();
}
}
@@ -181,21 +87,31 @@ void lisp_gc_register_object(void *val) {
struct GCObjectList *node = alloc_gc_objects_list_node();
obj->gc.gc_node = node;
node->prev = NULL;
node->next = black_objects;
node->next = white_objects;
if (node->next) {
node->next->prev = node;
}
node->obj = val;
white_objects = node;
}
void lisp_gc_register_static_object(void *val) {
if (!OBJECTP(val)) {
return;
}
lisp_gc_register_object(val);
LispObject *obj = val;
obj->gc.is_static = true;
struct GCObjectList *node = alloc_gc_objects_list_node();
node->prev = NULL;
node->next = static_objects;
if (node->next) {
node->next->prev = node;
}
node->obj = obj;
static_objects = node;
// reset incremental GC to ensure we scan the new static
incremental_state.step = GC_STEP_STATICS;
incremental_state.next_static = static_objects;
}
static void unregister_object_node(LispObject *obj) {
@@ -215,21 +131,28 @@ void gc_move_to_set(void *val, ObjectGCSet new_set) {
return;
}
LispObject *obj = val;
if (OBJECT_STATIC_P(obj) && new_set == GC_WHITE) {
// static objects are always reachable. do this to optimize the macros
// in base.h
new_set = GC_GREY;
}
if (obj->gc.set != new_set) {
struct GCObjectList *node = obj->gc.gc_node;
unregister_object_node(obj);
obj->gc.set = new_set;
node->prev = NULL;
node->next = *HEAD_FOR_SET(new_set);
if (node->next) {
node->next->prev = node;
}
*HEAD_FOR_SET(new_set) = node;
}
}
void gc_mark_stack_for_rescan(void) {
if (incremental_state.step > GC_STEP_STACK) {
incremental_state.step = GC_STEP_STACK;
}
}
static void free_object(LispVal *val) {
assert(OBJECT_GC_SET_P(val, GC_WHITE));
assert(!OBJECT_HAS_LOCAL_REFERENCE_P(val));
switch (((LispObject *) val)->type) {
case TYPE_HASH_TABLE: {
LispHashTable *ht = val;
@@ -263,80 +186,146 @@ static void free_object(LispVal *val) {
lisp_release_object(val);
}
static void mark_object_recurse(LispGCStats *restrict stats, LispVal *val) {
if (!OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
static inline void make_grey_if_white(LispVal *val) {
if (OBJECTP(val) && OBJECT_GC_SET_P(val, GC_WHITE)) {
gc_move_to_set(val, GC_GREY);
}
}
static void mark_object(LispVal *val) {
// check for null for newly constructed objects
if (!val || !OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
return;
}
ObjectProcessStack stack;
init_object_process_stack(&stack);
switch (((LispObject *) val)->type) {
case TYPE_CONS:
make_grey_if_white(((LispCons *) val)->car);
make_grey_if_white(((LispCons *) val)->cdr);
break;
case TYPE_SYMBOL: {
LispSymbol *sym = val;
make_grey_if_white(sym->name);
make_grey_if_white(sym->value);
make_grey_if_white(sym->function);
make_grey_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]);
}
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));
}
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);
break;
}
case TYPE_STRING:
// no held refs
break;
case TYPE_FIXNUM:
case TYPE_FLOAT:
default:
abort();
}
gc_move_to_set(val, GC_BLACK);
object_process_stack_push_held_objects(&stack, val);
++stats->total_objects_searched;
while (!OBJECT_PROCESS_STACK_EMPTY_P(&stack)) {
LispVal *cur = object_process_stack_pop(&stack);
if (!OBJECT_GC_SET_P(cur, GC_BLACK)) {
++stats->total_objects_searched;
gc_move_to_set(cur, GC_BLACK);
object_process_stack_push_held_objects(&stack, cur);
}
}
free_object_process_stack(&stack);
}
static void mark_statics(LispGCStats *restrict stats) {
for (struct GCObjectList *node = static_objects; node; node = node->next) {
mark_object_recurse(stats, node->obj);
static inline size_t saturating_dec(size_t *restrict limit, size_t amount) {
if (amount >= *limit) {
*limit = 0;
} else {
*limit -= amount;
}
return *limit;
}
static void mark_statics(size_t *restrict limit) {
struct GCObjectList *node = incremental_state.next_static;
while (node && saturating_dec(limit, 1)) {
mark_object(node->obj);
node = node->next;
}
// we processed the whole list, move to the next step
if (!node) {
incremental_state.next_static = static_objects;
incremental_state.step = GC_STEP_STACK;
}
}
static void mark_stack_local_refs(LispGCStats *restrict stats,
struct LocalReferences *restrict refs) {
// This mark_stack_local_refs and mark_stack_frame mark the whole frame,
// ignoring limit. However, they update limit with how many objects the marked.
static void mark_stack_local_refs(struct LocalReferences *restrict refs,
size_t *restrict limit) {
size_t full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH;
size_t last_block_len = refs->num_refs % LOCAL_REFERENCES_BLOCK_LENGTH;
for (size_t i = 0; i < full_blocks; ++i) {
for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) {
mark_object_recurse(stats, refs->blocks[i]->refs[j]);
mark_object(refs->blocks[i]->refs[j]);
}
}
for (size_t i = 0; i < last_block_len; ++i) {
mark_object_recurse(stats, refs->blocks[full_blocks]->refs[i]);
mark_object(refs->blocks[full_blocks]->refs[i]);
}
saturating_dec(limit, refs->num_refs);
}
static void mark_stack_frame(LispGCStats *restrict stats,
struct StackFrame *frame) {
mark_object_recurse(stats, frame->name);
mark_object_recurse(stats, frame->args);
mark_object_recurse(stats, frame->fobj);
mark_object_recurse(stats, frame->lexenv);
mark_stack_local_refs(stats, &frame->local_refs);
static void mark_stack_frame(struct StackFrame *frame, size_t *restrict limit) {
mark_object(frame->name);
mark_object(frame->args);
mark_object(frame->fobj);
mark_object(frame->lexenv);
saturating_dec(limit, 4);
mark_stack_local_refs(&frame->local_refs, limit);
}
static void mark_and_compact_the_stack(LispGCStats *restrict stats) {
mark_object_recurse(stats, the_stack.nogc_retval);
static void mark_and_compact_the_stack(size_t *restrict limit) {
if ((*limit)--) {
mark_object(the_stack.nogc_retval);
}
size_t i;
for (i = 0; i < the_stack.depth; ++i) {
mark_stack_frame(stats, &the_stack.frames[i]);
for (i = 0; i < the_stack.depth && *limit; ++i) {
if (!the_stack.frames[i].marked) {
mark_stack_frame(&the_stack.frames[i], limit);
the_stack.frames[i].marked = true;
}
}
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;
}
static void gc_sweep_objects(LispGCStats *restrict stats) {
while (black_objects) {
++stats->total_objects_cleaned;
free_object(black_objects->obj);
// move to the next step
incremental_state.step = GC_STEP_HEAP;
}
}
static void maybe_free_some_object_list_nodes(void) {
while (free_objects_list_count > FREE_OBJECTS_LIST_LIMIT) {
struct GCObjectList *to_free = free_objects_list;
free_objects_list = free_objects_list->next;
lisp_free(to_free);
--free_objects_list_count;
static void unmark_the_stack(void) {
for (size_t i = 0; i < the_stack.depth; ++i) {
the_stack.frames[i].marked = false;
}
}
static void mark_grey_objects(size_t *restrict limit) {
while (grey_objects && saturating_dec(limit, 1)) {
mark_object(grey_objects->obj);
}
if (!grey_objects) {
incremental_state.step = GC_STEP_FREE;
}
}
@@ -349,33 +338,86 @@ static void swap_white_black_sets(void) {
GC_BLACK = tmp_id;
}
void lisp_gc_now(LispGCStats *restrict stats) {
lisp_doing_gc = true;
LispGCStats backup_stats;
if (!stats) {
stats = &backup_stats;
static void maybe_free_some_object_list_nodes(void) {
while (free_objects_list_count > FREE_OBJECTS_LIST_LIMIT) {
struct GCObjectList *to_free = free_objects_list;
free_objects_list = free_objects_list->next;
lisp_free(to_free);
--free_objects_list_count;
}
stats->total_objects_cleaned = 0;
struct timespec start_time;
clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &start_time);
mark_statics(stats);
mark_object_recurse(stats, obarray);
mark_and_compact_the_stack(stats);
gc_sweep_objects(stats);
maybe_free_some_object_list_nodes();
swap_white_black_sets();
struct timespec end_time;
clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &end_time);
sub_timespecs(&end_time, &start_time, &stats->ellapsed_time);
add_timespecs(&stats->ellapsed_time, &total_gc_time, &total_gc_time);
++total_gc_count;
lisp_doing_gc = false;
}
void debug_print_gc_stats(FILE *stream, const LispGCStats *stats) {
fprintf(stream, "Objects Searched: %zu\n", stats->total_objects_searched);
fprintf(stream, "Objects Cleaned: %zu\n", stats->total_objects_cleaned);
double time = stats->ellapsed_time.tv_sec * 1000
+ (stats->ellapsed_time.tv_nsec / 1000000.0);
fprintf(stream, "Time Ellapsed (ms): %f\n", time);
static void gc_sweep_objects(size_t *restrict limit) {
while (white_objects && saturating_dec(limit, 1)) {
free_object(white_objects->obj);
}
// reset the gc
if (!white_objects) {
swap_white_black_sets();
maybe_free_some_object_list_nodes();
unmark_the_stack();
incremental_state.step = GC_STEP_STATICS;
}
}
void lisp_gc_yield(struct timespec *restrict time_took, bool full) {
lisp_doing_gc = true;
struct timespec start_time;
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) {
incremental_state.step = GC_STEP_HEAP;
}
switch (incremental_state.step) {
case GC_STEP_STATICS:
mark_statics(&limit);
break;
case GC_STEP_STACK:
mark_and_compact_the_stack(&limit);
break;
case GC_STEP_HEAP:
mark_grey_objects(&limit);
break;
case GC_STEP_FREE:
gc_sweep_objects(&limit);
// force being done
limit = 0;
break;
}
}
struct timespec end_time;
clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &end_time);
struct timespec backup_time_took;
if (!time_took) {
time_took = &backup_time_took;
}
sub_timespecs(&end_time, &start_time, time_took);
add_timespecs(time_took, &total_gc_time, &total_gc_time);
lisp_doing_gc = false;
++lisp_gc_count;
}
void lisp_gc_teardown(void) {
assert(the_stack.depth == 0);
while (white_objects) {
free_object(white_objects->obj);
}
while (grey_objects) {
free_object(grey_objects->obj);
}
while (black_objects) {
free_object(black_objects->obj);
}
while (static_objects) {
struct GCObjectList *next = static_objects->next;
free(static_objects);
static_objects = next;
}
while (free_objects_list) {
struct GCObjectList *next = free_objects_list->next;
free(free_objects_list);
free_objects_list = next;
}
}

54
src/gc.h
View File

@@ -1,49 +1,17 @@
#ifndef INCLUDED_GC_H
#define INCLUDED_GC_H
#include "memory.h"
#include <stdbool.h>
#include <stddef.h>
#include <stdio.h>
#include <stdint.h>
#include <threads.h>
#define OBJECT_PROCESS_STACK_BLOCK_SIZE 64
struct ObjectProcessStackBlock {
void *objs[OBJECT_PROCESS_STACK_BLOCK_SIZE];
};
typedef struct {
size_t num_blocks;
size_t num_objs;
struct ObjectProcessStackBlock **blocks;
} ObjectProcessStack;
static ALWAYS_INLINE bool
OBJECT_PROCESS_STACK_EMPTY_P(ObjectProcessStack *restrict stack) {
return !stack->num_objs;
}
static ALWAYS_INLINE void
init_object_process_stack(ObjectProcessStack *restrict stack) {
stack->num_blocks = 0;
stack->num_objs = 0;
stack->blocks = NULL;
}
void free_object_process_stack(ObjectProcessStack *restrict stack);
void object_process_stack_push_held_objects(ObjectProcessStack *restrict stack,
void *obj);
void *object_process_stack_pop(ObjectProcessStack *restrict stack);
// number of objects to process each time we do incremental GC
#define LISP_GC_INCREMENTAL_COUNT 128
extern bool lisp_doing_gc;
extern struct timespec total_gc_time;
extern size_t total_gc_count;
typedef struct {
size_t total_objects_searched;
size_t total_objects_cleaned;
struct timespec ellapsed_time;
} LispGCStats;
extern size_t lisp_gc_count;
typedef uint8_t ObjectGCSet;
@@ -65,10 +33,14 @@ void lisp_gc_register_object(void *val);
void lisp_gc_register_static_object(void *val);
void gc_move_to_set(void *val, ObjectGCSet new_set);
// note that the argument is restrict!
void lisp_gc_now(LispGCStats *restrict status);
// notify the GC that the stack's referenced objects have changed.
void gc_mark_stack_for_rescan(void);
// Debug
void debug_print_gc_stats(FILE *stream, const LispGCStats *stats);
// do some incremental GC, with FULL, do full gc
void lisp_gc_yield(struct timespec *restrict time_took, bool full);
// Unregister all static objects and prepare for shutdown
// The stack MUST be empty when this is called
void lisp_gc_teardown(void);
#endif

4
src/gen-init-globals.awk
View File

@@ -6,6 +6,10 @@ BEGIN {
special_syms["unbound"] = 1
special_syms["hash_string"] = 1
special_syms["strings_equal"] = 1
special_syms["and_rest"] = 1
special_syms["and_key"] = 1
special_syms["and_optional"] = 1
special_syms["and_allow_other_keys"] = 1
FS = "[,(]"

3
src/hashtable.c
View File

@@ -56,7 +56,7 @@ static uintptr_t hash_key_for_table(LispHashTable *ht, LispVal *key) {
static bool compare_keys(LispHashTable *ht, LispVal *key1, LispVal *key2) {
if (NILP(ht->eq_fn) || ht->eq_fn == Qeq) {
return key1 == key2;
return EQ(key1, key2);
} else if (ht->eq_fn == Qstrings_equal) { // needed for initialization
return !NILP(Fstrings_equal(key1, key2));
}
@@ -92,6 +92,7 @@ static void rehash(LispHashTable *ht, size_t new_size) {
nb->value = cob->value;
}
}
lisp_free(old_data);
}
static void maybe_rehash(LispHashTable *ht) {

87
src/lisp.c
View File

@@ -10,6 +10,7 @@ static void construct_manual_symbols(void) {
// IMPORTANT: the symbols listed here need to also be set as special in
// gen-init-globals.awk
Qnil = Fmake_symbol(LISP_LITSTR("nil"));
((LispSymbol *) Qnil)->value = Qnil;
((LispSymbol *) Qnil)->function = Qnil;
((LispSymbol *) Qnil)->plist = Qnil;
lisp_gc_register_static_object(Qnil);
@@ -18,7 +19,7 @@ static void construct_manual_symbols(void) {
lisp_gc_register_static_object(Qt);
Qunbound = Fmake_symbol(LISP_LITSTR("unbound"));
((LispSymbol *) Qunbound)->value = Qunbound;
((LispSymbol *) Qnil)->value = Qunbound;
((LispSymbol *) Qunbound)->value = Qunbound;
lisp_gc_register_static_object(Qunbound);
Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string"));
@@ -41,6 +42,14 @@ static void register_manual_symbols(void) {
void lisp_init(void) {
construct_manual_symbols();
obarray = Fmake_hash_table(Qhash_string, Qstrings_equal);
lisp_gc_register_static_object(obarray);
// Needed to register functions
REGISTER_GLOBAL_SYMBOL(and_allow_other_keys);
REGISTER_GLOBAL_SYMBOL(and_optional);
REGISTER_GLOBAL_SYMBOL(and_key);
REGISTER_GLOBAL_SYMBOL(and_rest);
// these call Fintern, so they need to have obarray constructed
((LispSymbol *) Qhash_string)->function = BUILTIN_FUNCTION_OBJ(hash_string);
((LispSymbol *) Qstrings_equal)->function =
@@ -50,11 +59,31 @@ void lisp_init(void) {
register_globals();
lisp_init_stack();
lisp_gc_on_alloc = true;
}
void lisp_shutdown(void) {}
void lisp_shutdown(void) {
lisp_gc_teardown();
lisp_teardown_stack();
}
DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) {
LispVal *lexval = Fplist_get(lexenv, name, Qunbound);
if (lexval != Qunbound) {
return lexval;
}
if (name->value == Qunbound) {
// TODO better error
printf("Unbound symbol: ");
debug_print(stdout, name);
fputc('\n', stdout);
abort();
}
return name->value;
}
DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
"(form &optional lexenv)", "") {
if (!OBJECTP(form)) {
// fixnum or float
return form;
@@ -72,21 +101,12 @@ DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
out_data[i] = Qnil;
}
for (size_t i = 0; i < vec->length; ++i) {
out_data[i] = Feval(vec->data[i]);
out_data[i] = Feval(vec->data[i], lexenv);
}
return newvec;
}
case TYPE_SYMBOL: {
// TODO local bindings
LispSymbol *sym = form;
if (sym->value == Qunbound) {
printf("Unbound symbol: ");
debug_print(stdout, form);
fputc('\n', stdout);
abort();
}
return sym->value;
}
case TYPE_SYMBOL:
return lookup_variable(form, lexenv);
case TYPE_CONS: {
return Ffuncall(XCAR(form), XCDR(form));
}
@@ -97,6 +117,32 @@ DEFUN(eval, "eval", (LispVal * form), "(form)", "") {
}
}
DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
LispVal *rval = Qnil;
DOLIST(form, forms) {
rval = Feval(form, TOP_LEXENV());
}
return rval;
}
DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
"(bindings &rest body)", "") {
CHECK_LISTP(bindings);
copy_parent_lexenv();
DOLIST(binding, bindings) {
if (SYMBOLP(binding)) {
new_lexical_variable(binding, Qnil);
} else if (CONSP(binding) && list_length_eq(binding, 2)) {
new_lexical_variable(FIRST(binding),
Feval(SECOND(binding), TOP_LEXENV()));
} else {
// TODO better error
abort();
}
}
return Fprogn(body);
}
void debug_print(FILE *file, LispVal *obj) {
switch (TYPE_OF(obj)) {
case TYPE_FIXNUM:
@@ -123,12 +169,19 @@ void debug_print(FILE *file, LispVal *obj) {
break;
}
case TYPE_FUNCTION: {
fprintf(file, "<function at 0x%jx>", (uintmax_t) obj);
LispFunction *fobj = obj;
if (NILP(fobj->name)) {
fprintf(file, "<lambda at 0x%jx>", (uintmax_t) obj);
} else {
fprintf(file, "<function ");
debug_print(file, fobj->name);
fprintf(file, " at 0x%jx>", (uintmax_t) obj);
}
break;
}
case TYPE_CONS: {
fputc('(', file);
FOREACH_TAIL(obj, tail) {
DOTAILS(tail, obj) {
if (CONSP(tail)) {
debug_print(file, XCAR(tail));
if (!NILP(XCDR(tail))) {

11
src/lisp.h
View File

@@ -16,9 +16,14 @@ void lisp_init(void);
void lisp_shutdown(void);
DECLARE_FUNCTION(eval, (LispVal * form));
DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv));
DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body));
void debug_print(FILE *file, LispVal *obj);
void debug_obj_info(FILE *file, LispVal *obj);
__attribute__((no_sanitize("address"))) void debug_print(FILE *file,
LispVal *obj);
__attribute__((no_sanitize("address"))) void debug_obj_info(FILE *file,
LispVal *obj);
#endif

45
src/list.c
View File

@@ -1,5 +1,7 @@
#include "list.h"
#include "function.h"
intptr_t list_length(LispVal *list) {
assert(LISTP(list));
LispVal *tortise = list;
@@ -31,6 +33,7 @@ DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)",
DEFUN(length, "length", (LispVal * list), "(list)", "") {
// TODO type check
// TODO list may be circular
return MAKE_FIXNUM(list_length(list));
}
@@ -59,3 +62,45 @@ DEFUN(listp, "listp", (LispVal * obj), "(obj)", "") {
DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
return args;
}
DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
"(elt list &optional pred)", "") {
if (NILP(pred) || pred == Qeq) {
// fast case
DOTAILS(rest, list) {
if (elt == XCAR(rest)) {
return rest;
}
}
} else {
DOTAILS(rest, list) {
if (CALL(pred, elt, XCAR(rest))) {
return rest;
}
}
}
return Qnil;
}
DEFUN(plist_put, "plist-put", (LispVal * plist, LispVal *prop, LispVal *value),
"(plist prop value)", "") {
CHECK_LISTP(plist);
DOTAILS(rest, plist) {
if (EQ(XCAR(rest), prop)) {
RPLACA(XCDR(rest), value);
return plist;
}
}
return CONS(prop, CONS(value, plist));
}
DEFUN(plist_get, "plist-get", (LispVal * plist, LispVal *prop, LispVal *def),
"(plist prop &optional default)", "") {
CHECK_LISTP(plist);
DOTAILS(rest, plist) {
if (EQ(XCAR(rest), prop)) {
return SECOND(rest);
}
}
return def;
}

10
src/list.h
View File

@@ -99,11 +99,11 @@ static ALWAYS_INLINE LispVal *LIST_N(int count, ...) {
#define FOURTH(x) XCAR(XCDR(XCDR(XCDR(x))))
#define FIFTH(x) XCAR(XCDR(XCDR(XCDR(XCDR(x)))))
#define FOREACH(l, v) \
#define DOLIST(v, l) \
for (LispVal *_tail = (l), *v = XCAR(_tail); !NILP(_tail); \
_tail = XCDR(_tail), v = XCAR(_tail))
#define FOREACH_TAIL(l, v) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
#define DOTAILS(v, l) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
// return -1 list is circular
intptr_t list_length(LispVal *list);
@@ -122,4 +122,10 @@ static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
}
}
// List utility functions
DECLARE_FUNCTION(member, (LispVal * elt, LispVal *list, LispVal *pred));
DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value));
DECLARE_FUNCTION(plist_get, (LispVal * plist, LispVal *prop, LispVal *def));
#endif

33
src/main.c
View File

@@ -3,33 +3,30 @@
#include <stdio.h>
DEFUN(cool_func, "cool-func", (LispVal * a, LispVal *b), "(a &optional b)",
"") {
printf("A: ");
debug_obj_info(stdout, a);
printf("B: ");
debug_obj_info(stdout, b);
DEFUN(print, "print", (LispVal * v), "(v)", "") {
debug_obj_info(stdout, v);
return Qnil;
}
int main(int argc, const char **argv) {
LispGCStats gc_stats;
FILE *in = fopen(argv[1], "r");
fseek(in, 0, SEEK_END);
off_t src_len = ftello(in);
char *src = malloc(src_len);
rewind(in);
fread(src, 1, src_len, in);
fclose(in);
lisp_init();
REGISTER_GLOBAL_FUNCTION(cool_func);
REGISTER_GLOBAL_FUNCTION(print);
push_stack_frame(Qnil, Qnil, Qnil);
ReadStream s;
const char BUF[] = "(cool-func 1 (cons 1 2))";
read_stream_init(&s, BUF, sizeof(BUF) - 1);
LispVal *l = read(&s);
Feval(l);
push_stack_frame(Qnil, Qnil, Qnil);
for (size_t i = 0; i < 100; ++i) {
Fcons(MAKE_FIXNUM(0x1234), LISP_LITSTR("a"));
read_stream_init(&s, src, src_len);
LispVal *r;
while ((r = read(&s))) {
Feval(r, Qnil);
}
pop_stack_frame();
lisp_gc_now(&gc_stats);
debug_print_gc_stats(stdout, &gc_stats);
pop_stack_frame();
lisp_shutdown();
free(src);
return 0;
}

66
src/memory.c
View File

@@ -36,3 +36,69 @@ void *lisp_aligned_alloc(size_t alignment, size_t size) {
}
return ptr;
}
#define STRING_STREAM_BLOCK_SIZE 32
static void ensure_string_stream_space(StringStream *restrict stream,
size_t space) {
size_t min_size = stream->nchars + space;
size_t new_size = stream->size;
while (new_size < min_size) {
new_size += STRING_STREAM_BLOCK_SIZE;
}
if (new_size != stream->size) {
stream->buffer = lisp_realloc(stream->buffer, new_size + 1);
}
}
int string_stream_printf(StringStream *restrict stream,
const char *restrict format, ...) {
va_list args;
va_start(args, format);
int rval = string_stream_vprintf(stream, format, args);
va_end(args);
return rval;
}
int string_stream_vprintf(StringStream *restrict stream,
const char *restrict format, va_list args) {
va_list args_copy;
va_copy(args_copy, args);
int space = vsnprintf(NULL, 0, format, args_copy);
if (space < 0) {
abort();
}
va_end(args_copy);
ensure_string_stream_space(stream, space);
int rval = vsnprintf(stream->buffer + stream->nchars,
stream->size + 1 - stream->nchars, format, args);
if (rval < 0) {
abort();
}
stream->nchars += rval;
return rval;
}
bool strgetline(const char *restrict buf, size_t buf_length,
const char **restrict start, size_t *restrict length) {
if (!*start) {
*start = buf;
if (!buf_length) {
*length = 0;
return true;
}
} else if (!buf_length) {
return false;
} else if (*start + *length >= buf + buf_length - 1) {
return false;
} else /* if (*start) */ {
*start += *length + 1;
}
size_t left = buf_length - (*start - buf);
char *found;
if ((found = memchr(*start, '\n', left))) {
*length = found - *start;
} else {
*length = left;
}
return true;
}

43
src/memory.h
View File

@@ -2,6 +2,7 @@
#define INCLUDED_MEMORY_H
#include <float.h>
#include <stdarg.h>
#include <stdbool.h>
#include <stdint.h>
#include <stdlib.h>
@@ -18,6 +19,12 @@
# define ALWAYS_INLINE inline
#endif
#if __has_attribute(format)
# define FORMAT(n, m) __attribute__((format(printf, n, m)))
#else
# define FORMAT(n, m)
#endif
// Byte order stuff
typedef enum {
ENDIAN_LITTLE,
@@ -123,4 +130,40 @@ static ALWAYS_INLINE void add_timespecs(const struct timespec *t1,
out->tv_nsec = nsec;
}
typedef struct {
// this is actually size + 1 bytes for the null byte
char *buffer;
size_t size;
size_t nchars;
} StringStream;
static inline void string_stream_init(StringStream *restrict stream) {
stream->buffer = lisp_malloc(1);
stream->size = 0;
stream->buffer[stream->size] = '\0';
stream->nchars = 0;
}
static inline void string_stream_free(StringStream *restrict stream) {
lisp_free(stream->buffer);
}
static inline void string_stream_steal(StringStream *restrict stream,
char **restrict out,
size_t *restrict out_length) {
*out = stream->buffer;
*out_length = stream->nchars;
}
int string_stream_printf(StringStream *restrict stream,
const char *restrict format, ...) FORMAT(2, 3);
int string_stream_vprintf(StringStream *restrict stream,
const char *restrict format, va_list args);
// Get the next line in BUF starting at *START (or &buf[0] if *START is
// NULL). Store the length of the line in LENGTH. BUF is BUF_LENGTH bytes
// long. Return true if we found another line and false otherwise.
bool strgetline(const char *restrict buf, size_t buf_length,
const char **restrict start, size_t *restrict length);
#endif

153
src/stack.c
View File

@@ -1,5 +1,6 @@
#include "stack.h"
#include "function.h"
#include "hashtable.h"
#include "memory.h"
@@ -14,29 +15,47 @@ void lisp_init_stack(void) {
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->local_refs.num_refs = 0;
the_stack.frames->local_refs.num_blocks = 1;
the_stack.frames->local_refs.blocks =
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->local_refs.blocks[0] =
the_stack.frames[i].local_refs.blocks[0] =
lisp_malloc(sizeof(struct LocalReferencesBlock));
}
the_stack.nogc_retval = Qnil;
}
static void teardown_stack_frame(struct StackFrame *restrict frame) {
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_blocks / 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]));
@@ -73,6 +92,10 @@ static void store_local_reference_in_frame(struct StackFrame *frame,
refs->blocks[num_full_blocks]
->refs[refs->num_refs++ % LOCAL_REFERENCES_BLOCK_LENGTH] = obj;
}
SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true);
// mark the frame for rescan
frame->marked = false;
gc_mark_stack_for_rescan();
}
void add_local_reference_no_recurse(LispVal *obj) {
@@ -82,33 +105,125 @@ void add_local_reference_no_recurse(LispVal *obj) {
}
}
static LispVal *next_local_reference(size_t *restrict i) {
if (*i >= LISP_STACK_TOP()->local_refs.num_refs) {
return NULL;
}
size_t block_idx = *i / LOCAL_REFERENCES_BLOCK_LENGTH;
size_t small_idx = *i % LOCAL_REFERENCES_BLOCK_LENGTH;
LispVal *obj =
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,
LispVal *obj) {
if (NILP(Fgethash(seen_objs, obj, Qnil))) {
add_local_reference_no_recurse(obj);
Fputhash(seen_objs, obj, Qt);
}
}
static inline void add_local_refs_for_object_sub_vals(LispVal *seen_objs,
LispVal *val) {
switch (((LispObject *) val)->type) {
case TYPE_CONS:
add_local_ref_if_not_seen_no_recurse(seen_objs,
((LispCons *) val)->car);
add_local_ref_if_not_seen_no_recurse(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(seen_objs, sym->value);
add_local_ref_if_not_seen_no_recurse(seen_objs, sym->function);
add_local_ref_if_not_seen_no_recurse(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]);
}
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(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(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(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(seen_objs, fobj->args.rest);
break;
}
case TYPE_STRING:
// no held refs
break;
case TYPE_FIXNUM:
case TYPE_FLOAT:
default:
abort();
}
}
void add_local_reference(LispVal *obj) {
add_local_reference_no_recurse(obj);
LispVal *seen_objs = make_hash_table_no_gc(Qnil, Qnil);
ObjectProcessStack stack;
init_object_process_stack(&stack);
object_process_stack_push_held_objects(&stack, obj);
while (!OBJECT_PROCESS_STACK_EMPTY_P(&stack)) {
LispVal *top = object_process_stack_pop(&stack);
assert(OBJECTP(top));
if (!OBJECT_HAS_LOCAL_REFERENCE_P(obj)) {
store_local_reference_in_frame(LISP_STACK_TOP(), top);
SET_OBJECT_HAS_LOCAL_REFERENCE(obj, true);
}
if (NILP(Fgethash(seen_objs, obj, Qnil))) {
object_process_stack_push_held_objects(&stack, top);
Fputhash(seen_objs, obj, Qt);
size_t i = LISP_STACK_TOP()->local_refs.num_refs - 1;
LispVal *cur;
while ((cur = next_local_reference(&i))) {
add_local_refs_for_object_sub_vals(seen_objs, cur);
}
}
free_object_process_stack(&stack);
release_hash_table_no_gc(seen_objs);
}
void set_stack_evaluated_args(LispVal *args) {
assert(the_stack.depth > 0);
LISP_STACK_TOP()->evaled_args = true;
LISP_STACK_TOP()->args = args;
LISP_STACK_TOP()->marked = false;
gc_mark_stack_for_rescan();
}
void compact_stack_frame(struct StackFrame *restrict frame) {
struct LocalReferences *restrict refs = &frame->local_refs;
for (size_t i = 1; i < refs->num_blocks; ++i) {
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;
}
}

32
src/stack.h
View File

@@ -2,6 +2,7 @@
#define INCLUDED_STACK_H
#include "base.h"
#include "list.h"
#define DEFAULT_MAX_LISP_EVAL_DEPTH 1000
#define LOCAL_REFERENCES_BLOCK_LENGTH 64
@@ -19,9 +20,12 @@ struct LocalReferences {
struct StackFrame {
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)
struct LocalReferences local_refs;
bool marked; // whether we have GC'ed this frame
};
struct LispStack {
@@ -40,12 +44,40 @@ 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
// (this is for backtraces)
void set_stack_evaluated_args(LispVal *args);
// Return true if successful, false if not found and not created
bool set_lexical_variable(LispVal *name, LispVal *value, bool create_if_absent);
// Just add a new lexical variable without any checking
static inline void new_lexical_variable(LispVal *name, LispVal *value) {
assert(the_stack.depth != 0);
LISP_STACK_TOP()->lexenv =
CONS(name, CONS(value, LISP_STACK_TOP()->lexenv));
LISP_STACK_TOP()->marked = false;
gc_mark_stack_for_rescan();
}
// Copy the previous frame's lexenv to the top of the stack.
void copy_parent_lexenv(void);
// used by the GC
void compact_stack_frame(struct StackFrame *restrict frame);