Garbage collect strings and symbols
diff --git a/src/lisp/compiler.dasc b/src/lisp/compiler.dasc
index ec14078..8c876d3 100644
--- a/src/lisp/compiler.dasc
+++ b/src/lisp/compiler.dasc
@@ -87,6 +87,84 @@
local->stack_slots[slot] = false;
}
+struct dasm_State *compile_function(value_t args, enum namespace namespace,
+ struct environment *env,
+ struct local *local_out, int *nargs)
+{
+ dasm_State *d;
+ dasm_State **Dst = &d;
+
+ |.section code;
+ dasm_init(&d, DASM_MAXSECTION);
+
+ |.globals lbl_;
+ void *labels[lbl__MAX];
+ dasm_setupglobal(&d, labels, lbl__MAX);
+
+ |.actionlist lisp_actions;
+ dasm_setup(&d, lisp_actions);
+
+ struct local local;
+ local.parent = NULL;
+ local.first = NULL;
+ local.num_vars = 0;
+ local.npc = 8;
+ local.nextpc = 0;
+ local.stack_slots = malloc(sizeof(bool) * 4);
+ memset(local.stack_slots, 0, sizeof(bool) * 4);
+ local.num_stack_slots = 4;
+ local.num_stack_entries = 0;
+
+ dasm_growpc(&d, local.npc);
+
+ // Generate code
+ // TODO: first pass, extract bound and free variables
+
+ value_t name = car(args);
+ args = cdr(args);
+ value_t arglist = car(args);
+ value_t body = cdr(args);
+
+ if ((name & HEAP_MASK) != SYMBOL_TAG)
+ err("function name must be a symbol");
+
+ value_t a = arglist;
+ for (int i = 0; !nilp(a); a = cdr(a), i++)
+ {
+ if (!symbolp(car(a)))
+ {
+ err("defun argument must be a symbol");
+ }
+
+ add_variable(&local, V_ARGUMENT, (char *)(car(a) ^ SYMBOL_TAG), i);
+ }
+
+ for (value_t body_ = body; !nilp(body_); body_ = cdr(body_))
+ {
+ walk_and_alloc(&local, car(body_));
+ }
+
+ | setup (local.num_stack_entries);
+
+ memset(local.stack_slots, 0, local.num_stack_slots * sizeof(bool));
+ local.num_stack_entries = 0;
+
+ for (; !nilp(body); body = cdr(body))
+ {
+ compile_expression(env, &local, car(body), Dst);
+ }
+
+ | cleanup;
+
+ if (local_out)
+ *local_out = local;
+
+ if (nargs)
+ *nargs = length(arglist);
+
+ return d;
+}
+
void compile_tl(value_t val, struct environment *env)
{
if (!listp(val))
@@ -95,6 +173,8 @@
value_t form = car(val);
value_t args = cdr(val);
+ printf("Compiling function %s in %s\n", (char *)(car(args) ^ SYMBOL_TAG), (char *)(form ^ SYMBOL_TAG));
+
if (symstreq(form, "defun") || symstreq(form, "defmacro"))
{
enum namespace namespace = NS_FUNCTION;
@@ -102,72 +182,13 @@
if (symstreq(form, "defmacro"))
namespace = NS_MACRO;
- dasm_State *d;
- dasm_State **Dst = &d;
-
- |.section code;
- dasm_init(&d, DASM_MAXSECTION);
-
- |.globals lbl_;
- void *labels[lbl__MAX];
- dasm_setupglobal(&d, labels, lbl__MAX);
-
- |.actionlist lisp_actions;
- dasm_setup(&d, lisp_actions);
struct local local;
- local.first = NULL;
- local.num_vars = 0;
- local.npc = 8;
- local.nextpc = 0;
- local.stack_slots = malloc(sizeof(bool) * 4);
- memset(local.stack_slots, 0, sizeof(bool) * 4);
- local.num_stack_slots = 4;
- local.num_stack_entries = 0;
+ int nargs;
+ dasm_State *d = compile_function(args, namespace, env, &local, &nargs);
- dasm_growpc(&d, local.npc);
-
- // Generate code
- // TODO: first pass, extract bound and free variables
-
- value_t name = car(args);
- args = cdr(args);
- value_t arglist = car(args);
- value_t body = cdr(args);
-
- if ((name & HEAP_MASK) != SYMBOL_TAG)
- err("function name must be a symbol");
-
- value_t a = arglist;
- for (int i = 0; !nilp(a); a = cdr(a), i++)
- {
- if (!symbolp(car(a)))
- {
- err("defun argument must be a symbol");
- }
-
- add_variable(&local, V_ARGUMENT, (char *)(car(a) ^ SYMBOL_TAG), i);
- }
-
- for (value_t body_ = body; !nilp(body_); body_ = cdr(body_))
- {
- walk_and_alloc(&local, car(body_));
- }
-
- | setup (local.num_stack_entries);
-
- memset(local.stack_slots, 0, local.num_stack_slots * sizeof(bool));
- local.num_stack_entries = 0;
-
- for (; !nilp(body); body = cdr(body))
- {
- compile_expression(env, &local, car(body), Dst);
- }
-
- | cleanup;
-
- add_function(env, (char *)(name ^ SYMBOL_TAG), link(Dst),
- length(arglist), namespace);
+ add_function(env, (char *)(car(args) ^ SYMBOL_TAG), link(&d),
+ nargs, namespace);
dasm_free(&d);
free(local.stack_slots);
@@ -186,9 +207,19 @@
int slot = local_alloc(local);
value_t expr = cdr(args);
+ for (; !nilp(expr); expr = cdr(expr))
+ {
+ walk_and_alloc(local, expr);
+ }
local_free(local, slot);
}
+ else if (symstreq(car(body), "lambda"))
+ {
+ // We don't want to walk the lambda because it's another function. When
+ // the lambda is compiled it will be walked.
+ return;
+ }
else
{
for (; !nilp(args); args = cdr(args))
@@ -210,6 +241,7 @@
while (read1(is, &val))
{
+ printval(val, 0);
compile_tl(val, &env);
}
@@ -378,7 +410,10 @@
err("Function undefined");
if (nargs != func->nargs)
+ {
+ fprintf(stderr, "Function: %s at %s:%d\n", func->name, cons_file(val), cons_line(val));
err("wrong number of args");
+ }
if (func->namespace == NS_FUNCTION)
{
diff --git a/src/lisp/compiler.h b/src/lisp/compiler.h
index ddf7ea0..0b61c14 100644
--- a/src/lisp/compiler.h
+++ b/src/lisp/compiler.h
@@ -51,10 +51,14 @@
struct variable *prev;
};
-// local environment
+/// Local environment
struct local
{
+ /// Parent environment, NULL if none (root).
+ struct local *parent;
+
int num_vars;
+ /// Most recently defined variable
struct variable *first;
int npc;
int nextpc;
@@ -80,6 +84,9 @@
unsigned int local_alloc(struct local *local);
void local_free(struct local *local, unsigned int slot);
+/**
+ * Walk `body` and reserve space in `local` for any variable declarations.
+ */
void walk_and_alloc(struct local *local, value_t body);
// Compile top-level declaration
void compile_tl(value_t val, struct environment *env);
diff --git a/src/lisp/lisp.c b/src/lisp/lisp.c
index 0d305f2..1056db7 100644
--- a/src/lisp/lisp.c
+++ b/src/lisp/lisp.c
@@ -27,6 +27,25 @@
return i;
}
+void add_this_alloc(struct alloc *a, int tag)
+{
+ a->type_tag = tag;
+ a->pool = current_pool;
+
+ if (last_a)
+ {
+ a->prev = last_a;
+ last_a->next = a;
+ a->next = NULL;
+ last_a = a;
+ }
+ else
+ {
+ a->prev = a->next = NULL;
+ first_a = last_a = a;
+ }
+}
+
value_t cons(value_t car, value_t cdr)
{
struct cons_alloc *item = malloc_aligned(sizeof(struct cons_alloc));
@@ -37,25 +56,11 @@
c->line = 0;
c->name = NULL;
- item->alloc.type_tag = CONS_TAG;
- item->alloc.pool = current_pool;
-
- if (last_a)
- {
- item->alloc.prev = last_a;
- last_a->next = item;
- item->alloc.next = NULL;
- last_a = item;
- }
- else
- {
- item->alloc.prev = item->alloc.next = NULL;
- first_a = last_a = item;
- }
-
value_t v = (value_t)c;
v |= CONS_TAG;
+ add_this_alloc(&item->alloc, CONS_TAG);
+
return v;
}
@@ -101,7 +106,10 @@
return false;
int size = 8;
- char *s = malloc_aligned(size);
+ struct alloc *a = malloc_aligned(size + sizeof(struct alloc));
+ add_this_alloc(a, SYMBOL_TAG);
+
+ char *s = (char *)(a + 1);
s[0] = is->get(is);
@@ -112,7 +120,8 @@
if (i >= size)
{
size *= 2;
- s = realloc_aligned(s, size);
+ a = realloc_aligned(a, size + sizeof(struct alloc));
+ s = (char *)(a + 1);
}
s[i] = is->get(is);
@@ -137,7 +146,11 @@
bool escape = false;
int size = 8;
- char *s = malloc_aligned(size);
+
+ struct alloc *a = malloc_aligned(size + sizeof(struct alloc));
+ add_this_alloc(a, STRING_TAG);
+
+ char *s = (char *)(a + 1);
(void)is->get(is);
@@ -148,7 +161,8 @@
if (i >= size)
{
size *= 2;
- s = realloc_aligned(s, size);
+ a = realloc_aligned(a, size + sizeof(struct alloc));
+ s = (char *)(a + 1);
}
char c = is->get(is);
@@ -390,28 +404,30 @@
return res;
}
-value_t strval(char *str)
+static value_t strptrval(char *str, int tag)
{
value_t v;
- char *a = malloc_aligned(strlen(str) + 1);
+ struct alloc *al = malloc_aligned(strlen(str) + 1 + sizeof(struct alloc));
+ add_this_alloc(al, SYMBOL_TAG);
+
+ char *a = (char *)(al + 1);
+
strcpy(a, str);
v = (value_t)a;
- v |= STRING_TAG;
+ v |= tag;
return v;
}
+value_t strval(char *str)
+{
+ return strptrval(str, STRING_TAG);
+}
+
value_t symval(char *str)
{
- value_t v;
-
- char *a = malloc_aligned(strlen(str) + 1);
- strcpy(a, str);
- v = (value_t)a;
- v |= SYMBOL_TAG;
-
- return v;
+ return strptrval(str, SYMBOL_TAG);
}
bool integerp(value_t v)
@@ -539,3 +555,23 @@
{
return pool != 0;
}
+
+int cons_line(value_t val)
+{
+ if (!consp(val))
+ return 0;
+
+ struct cons *c = (void *)(val ^ CONS_TAG);
+
+ return c->line;
+}
+
+char *cons_file(value_t val)
+{
+ if (!consp(val))
+ return NULL;
+
+ struct cons *c = (void *)(val ^ CONS_TAG);
+
+ return c->name;
+}
diff --git a/src/lisp/lisp.h b/src/lisp/lisp.h
index eb9e5f6..675cc96 100644
--- a/src/lisp/lisp.h
+++ b/src/lisp/lisp.h
@@ -39,6 +39,15 @@
char *name;
};
+struct closure
+{
+ int num_args;
+ void *function;
+
+ /// This will be passed in edi.
+ value_t data[];
+};
+
/// Default pool (no pool)
#define NO_POOL 0
@@ -81,6 +90,12 @@
struct cons cons;
};
+struct closure_alloc
+{
+ struct alloc alloc;
+ struct closure closure;
+};
+
/**
* Create a new allocation pool.
*/
@@ -128,6 +143,9 @@
value_t *carref(value_t v);
value_t *cdrref(value_t v);
+int cons_line(value_t val);
+char *cons_file(value_t val);
+
bool integerp(value_t v);
bool symbolp(value_t v);
bool stringp(value_t v);