src/lisp/compiler.dasc - bluejay - Git - code.swisschili.sh

 /* -*- mode:c -*- */

 #include "compiler.h"
 #include "lib/std.h"
 #include "plat/plat.h"
 #include "gc.h"

 #include <dasm_proto.h>
 #include <dasm_x86.h>

 #include <stdlib.h>
 #include <string.h>

 #define value_size sizeof(value_t)

 |.arch x86;

 |.macro setup, nvars;
 |->function_start:
 | push ebp;
 | mov ebp, esp;
 | sub esp, (value_size * nvars);
 |.endmacro;

 |.macro cleanup;
 | mov esp, ebp;
 | pop ebp;
 | ret;
 |.endmacro;

 |.macro local_var, index;
 |.endmacro;

 dasm_State *d;
 unsigned int npc = 8;

 |.macro run_gc;
 | mov eax, esp;
 | push ebp;
 | push eax;
 | mov eax, _do_gc;
 | call eax;
 |.endmacro;

 struct function *find_function(struct environment *env, char *name)
 {
 	struct function *f = env->first;

 	while (strcmp(f->name, name) != 0)
 	{
 		if (f->prev)
 			f = f->prev;
 		else
 			return NULL;
 	}

 	return f;
 }

 unsigned int local_alloc(struct local *local)
 {
 	for (int i = 0; i < local->num_stack_slots; i++)
 	{
 		if (local->stack_slots[i] == false)
 		{
 			local->stack_slots[i] = true;

 			if (i >= local->num_stack_entries)
 				local->num_stack_entries++;

 			return i;
 		}
 	}

 	int old_size = local->num_stack_slots;
 	local->num_stack_slots += 4;
 	local->stack_slots = realloc(local->stack_slots, local->num_stack_slots * sizeof(bool));
 	// unreadable: set the remaining slots to unused
 	memset(local->stack_slots + old_size, 0, local->num_stack_slots - old_size);
 	local->stack_slots[old_size] = true;

 	return old_size;
 }

 void local_free(struct local *local, unsigned int slot)
 {
 	local->stack_slots[slot] = false;
 }

 struct dasm_State *compile_function(value_t args, enum namespace namespace,
                                     struct environment *env, struct local *local_out,
                                     struct local *local_parent, int *nargs, char *name)
 {
 	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;
 	local.num_closure_slots = 0;
 	local.parent = local_parent;
 	local.current_function_name = name;

 	dasm_growpc(&d, local.npc);

 	value_t arglist = car(args);
 	value_t body = cdr(args);

 	local.num_args = length(arglist);

 	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;

 	// TODO: local leaks memory! free variables too, not just stack slots (in
 	// two places). Add a free_local() function that does this.
 }

 void compile_tl(value_t val, struct environment *env)
 {
 	if (!listp(val))
 		err("Top level must be a list");

 	value_t form = car(val);
 	value_t args = cdr(val);

 	if (symstreq(form, "defun") || symstreq(form, "defmacro"))
 	{
 		enum namespace namespace = NS_FUNCTION;

 		if (symstreq(form, "defmacro"))
 			namespace = NS_MACRO;

 		struct local local;
 		int nargs;
 		char *name = (char *)(car(args) ^ SYMBOL_TAG);
 		dasm_State *d = compile_function(cdr(args), namespace, env, &local, NULL, &nargs, name);

 		add_function(env, name, link(&d),
 		             nargs, namespace);

 		dasm_free(&d);
 		free(local.stack_slots);
 	}
 }

 void walk_and_alloc(struct local *local, value_t body)
 {
 	if (!listp(body))
 		return;

 	value_t args = cdr(body);

 	if (symstreq(car(body), "let1"))
 	{
 		int slot = local_alloc(local);

 		value_t expr = cdr(args);
 		for (; !nilp(expr); expr = cdr(expr))
 		{
 			walk_and_alloc(local, car(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))
 		{
 			walk_and_alloc(local, car(args));
 		}
 	}
 }

 struct environment compile_all(struct istream *is)
 {
 	unsigned char pool = make_pool();
 	unsigned char pop = push_pool(pool);

 	value_t val;
 	struct environment env;
 	env.first = NULL;
 	load_std(&env);

 	while (read1(is, &val))
 	{
 		compile_tl(val, &env);
 	}

 	pop_pool(pop);

 	return env;
 }

 int nextpc(struct local *local, dasm_State **Dst)
 {
 	int n = local->nextpc++;
 	if (n > local->npc)
 	{
 		local->npc += 16;
 		dasm_growpc(Dst, local->npc);
 	}
 	return n;
 }

 void compile_backquote(struct environment *env, struct local *local,
                        value_t val, dasm_State **Dst)
 {
 	if (!listp(val))
 	{
 		| mov eax, (val);
 	}
 	else
 	{
 		value_t fsym = car(val),
 			args = cdr(val);
 		int nargs = length(args);

 		// TODO
 	}
 }

 void compile_variable(struct variable *v, dasm_State *Dst)
 {
 	switch (v->type)
 	{
 	case V_ARGUMENT:
 		| mov eax, dword [ebp + (value_size * (v->number + 2))];
 		break;
 	case V_BOUND:
 		| mov eax, dword [ebp - ((v->number + 1) * value_size)];
 		break;
 	case V_FREE:
 		// edi is the closure context pointer
 		| mov eax, dword [edi + (v->number * value_size)];
 		break;
 	default:
 		err("Sorry, can only access V_ARGUMENT, V_FREE and V_BOUND variables for now :(");
 	}
 }

 void compile_expression(struct environment *env, struct local *local,
                         value_t val, dasm_State **Dst)
 {
 	if (symstreq(val, "nil"))
 	{
 		| mov eax, (nil);
 	}
 	else if (symstreq(val, "t"))
 	{
 		| mov eax, (t);
 	}
 	else if (integerp(val) || stringp(val))
 	{
 		| mov eax, val;
 	}
 	else if (listp(val))
 	{
 		value_t fsym = car(val);
 		value_t args = cdr(val);
 		int nargs = length(args);

 		if (!symbolp(fsym))
 		{
 			err("function name must be a symbol");
 		}

 		if (symstreq(fsym, "if"))
 		{
 			if (nargs < 2 || nargs > 3)
 				err("Must give at least 2 arguments to if");

 			compile_expression(env, local, car(args), Dst);
 			int false_label = nextpc(local, Dst),
 			    after_label = nextpc(local, Dst);

 			// result is in eax
 			| cmp eax, (nil);
 			| je =>false_label;

 			compile_expression(env, local, elt(args, 1), Dst);
 			| jmp =>after_label;
 			|=>false_label:;
 			if (nargs == 3)
 			    compile_expression(env, local, elt(args, 2), Dst);
 			|=>after_label:
 		}
 		else if (symstreq(fsym, "let1"))
 		{
 			if (nargs < 2)
 			{
 				err("Must give at least 2 arguments to let1");
 			}
 			value_t binding = car(args);
 			value_t rest = cdr(args);

 			if (length(binding) != 2)
 			{
 				err("Binding list in let1 must contain exactly two entries");
 			}

 			value_t name = car(binding);
 			value_t value = car(cdr(binding));

 			compile_expression(env, local, value, Dst);

 			int i = local_alloc(local);

 			add_variable(local, V_BOUND, (char *)(name ^ SYMBOL_TAG), i);

 			| mov dword [ebp - ((i + 1) * value_size)], eax;

 			for (; !nilp(rest); rest = cdr(rest))
 			{
 				compile_expression(env, local, car(rest), Dst);
 			}

 			local_free(local, i);
 		}
 		else if (symstreq(fsym, "gc"))
 		{
 			if (nargs)
 			{
 				err("gc takes no arguments");
 			}

 			| run_gc;
 		}
 		else if (symstreq(fsym, "quote"))
 		{
 			if (nargs != 1)
 				err("quote should take exactly 1 argument");

 			// Simple!
 			| mov eax, (car(args));
 		}
 		else if (symstreq(fsym, "backquote"))
 		{
 			if (nargs != 1)
 				err("backquote should take exactly 1 argument");

 			compile_backquote(env, local, car(args), Dst);
 		}
 		else if (symstreq(fsym, "function"))
 		{
 			if (nargs != 1)
 			{
 				err("function should take exactly 1 argument");
 			}

 			if (!symbolp(car(args)))
 			{
 				err("argument to function should be a symbol resolvable at compile time");
 			}

 			struct function *f = find_function(env, (char *)(car(args) ^ SYMBOL_TAG));
 			value_t closure = create_closure(f->code_ptr, f->nargs, 0);

 			| mov eax, (closure);
 		}
 		else if (symstreq(fsym, "list"))
 		{
 			| push (nil);

 			for (int i = nargs - 1; i >= 0; i--)
 			{
 				compile_expression(env, local, elt(args, i), Dst);

 				// push the ith item
 				| push eax;
 				// cons the top two stack items
 				| mov ebx, (cons);
 				| call ebx;
 				// remove the stack items from use
 				| add esp, (2 * value_size);
 				// put the new thing on the stack
 				| push eax;
 			}

 			| pop eax;
 		}
 		else if (symstreq(fsym, "lambda"))
 		{
 			// Compile the function with this as the parent scope
 			struct local new_local;
 			int nargs_out;
 			dasm_State *d = compile_function(args, NS_ANONYMOUS, env, &new_local, local, &nargs_out, "recurse");

 			// Link the function
 			void *func_ptr = link(&d);

 			// Create a closure object with the correct number of captures at
 			// runtime
 			| push (new_local.num_closure_slots);
 			| push (nargs_out);
 			| push (func_ptr);
 			| mov ebx, (create_closure);
 			| call ebx;
 			| add esp, 12;

 			// Walk the generated local scope for V_FREE variables, since each
 			// of these exists in our scope (or higher), evaluate it and set it
 			// as a member of the lambda capture.

 			for (struct variable *var = new_local.first; var; var = var->prev)
 			{
 				if (var->type == V_FREE)
 				{
 					// Closure in eax
 					| push eax;
 					// Variable now in eax
 					compile_variable(find_variable(local, var->name), Dst);
 					| push eax;

 					// The capture offset
 					| push (var->number);
 					| mov ebx, (set_closure_capture_variable);
 					| call ebx;
 					// Skip the value and index
 					| add esp, 8;
 					// Pop the closure back in to eax
 					| pop eax;
 				}
 			}

 			// Closure is still in eax

 			dasm_free(&d);
 			free(new_local.stack_slots);
 		}
 		else
 		{
 			char *name = (char *)(fsym ^ SYMBOL_TAG);
 			struct function *func = find_function(env, name);

 			bool is_recursive = false;
 			int nargs_needed = 0;

 			if (symstreq(fsym, local->current_function_name))
 			{
 				is_recursive = true;
 				nargs_needed = local->num_args;
 			}
 			else
 			{
 				if (func == NULL)
 				{
 					fprintf(stderr, "Function call: %s at %s:%d\n", name, cons_file(val), cons_line(val));
 					err("Function undefined");
 				}

 				nargs_needed = func->nargs;
 			}

 			if (nargs != nargs_needed)
 			{
 				fprintf(stderr, "Function call: %s at %s:%d, want %d args but given %d\n",
 					name, cons_file(val), cons_line(val), nargs_needed, nargs);
 				err("wrong number of args");
 			}

 			if (is_recursive || func->namespace == NS_FUNCTION)
 			{
 				for (int i = length(args) - 1; i >= 0; i--)
 				{
 					compile_expression(env, local, elt(args, i), Dst);
 					| push eax;
 				}

 				if (is_recursive)
 				{
 					| call ->function_start;
 				}
 				else
 				{
 					| mov ebx, (func->code_addr);
 					| call ebx;
 				}
 				| add esp, (nargs * value_size);
 				// result in eax
 			}
 			else if (func->namespace == NS_MACRO)
 			{
 				value_t expanded_to = call_list(func, args);

 				compile_expression(env, local, expanded_to, Dst);
 			}
 		}
 	}
 	else if (symbolp(val))
 	{
 		struct variable *v = find_variable(local, (char *)(val ^ SYMBOL_TAG));

 		if (!v)
 		{
 			fprintf(stderr, "var: %s\n", (char *)(val ^ SYMBOL_TAG));
 			err("Variable unbound");
 		}

 		compile_variable(v, Dst);
 	}
 }

 void compile_expr_to_func(struct environment *env, char *name, value_t val,
                           dasm_State **Dst)
 {
 	| setup 0;

 	struct local local;
 	compile_expression(env, &local, val, Dst);

 	| cleanup;

 	add_function(env, name, link(Dst), 0, NS_FUNCTION);
 }

 struct variable *add_variable(struct local *local, enum var_type type,
                               char *name, int number)
 {
 	struct variable *var = malloc(sizeof(struct variable));
 	var->prev = local->first;
 	var->type = type;
 	var->name = name;
 	var->number = number;

 	local->first = var;

 	return var;
 }

 void destroy_local(struct local *local)
 {
 	for (struct variable *v = local->first; v;)
 	{
 		struct variable *t = v;
 		v = v->prev;
 		free(t);
 	}
 }

 struct variable *find_variable(struct local *local, char *name)
 {
 	struct variable *v = local->first;

 	for (; v && strcmp(v->name, name) != 0; v = v->prev)
 	{}

 	if (!v)
 	{
 		if (local->parent)
 		{
 			v = find_variable(local->parent, name);

 			if (v)
 			{
 				// We found this in a parent scope, add it as a V_FREE variable to skip the search.
 				v = add_variable(local, V_FREE, name, local->num_closure_slots++);
 			}
 		}
 	}
 	return v;
 }

 extern value_t _call_list(void *addr, value_t list, value_t *edi);

 value_t call_list(struct function *func, value_t list)
 {
 	return _call_list(func->code_ptr, list, NULL);
 }

 value_t call_list_closure(struct closure *c, value_t list)
 {
 	return _call_list(c->function, list, c->data);
 }
	/* -- mode:c -- */

	#include "compiler.h"
	#include "lib/std.h"
	#include "plat/plat.h"
	#include "gc.h"

	#include <dasm_proto.h>
	#include <dasm_x86.h>

	#include <stdlib.h>
	#include <string.h>

	#define value_size sizeof(value_t)

	\|.arch x86;

	\|.macro setup, nvars;
	\|->function_start:
	\| push ebp;
	\| mov ebp, esp;
	\| sub esp, (value_size * nvars);
	\|.endmacro;

	\|.macro cleanup;
	\| mov esp, ebp;
	\| pop ebp;
	\| ret;
	\|.endmacro;

	\|.macro local_var, index;
	\|.endmacro;

	dasm_State *d;
	unsigned int npc = 8;

	\|.macro run_gc;
	\| mov eax, esp;
	\| push ebp;
	\| push eax;
	\| mov eax, _do_gc;
	\| call eax;
	\|.endmacro;

	struct function find_function(struct environment env, char *name)
	{
	struct function *f = env->first;

	while (strcmp(f->name, name) != 0)
	{
	if (f->prev)
	f = f->prev;
	else
	return NULL;
	}

	return f;
	}

	unsigned int local_alloc(struct local *local)
	{
	for (int i = 0; i < local->num_stack_slots; i++)
	{
	if (local->stack_slots[i] == false)
	{
	local->stack_slots[i] = true;

	if (i >= local->num_stack_entries)
	local->num_stack_entries++;

	return i;
	}
	}

	int old_size = local->num_stack_slots;
	local->num_stack_slots += 4;
	local->stack_slots = realloc(local->stack_slots, local->num_stack_slots * sizeof(bool));
	// unreadable: set the remaining slots to unused
	memset(local->stack_slots + old_size, 0, local->num_stack_slots - old_size);
	local->stack_slots[old_size] = true;

	return old_size;
	}

	void local_free(struct local *local, unsigned int slot)
	{
	local->stack_slots[slot] = false;
	}

	struct dasm_State *compile_function(value_t args, enum namespace namespace,
	struct environment env, struct local local_out,
	struct local local_parent, int nargs, char *name)
	{
	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;
	local.num_closure_slots = 0;
	local.parent = local_parent;
	local.current_function_name = name;

	dasm_growpc(&d, local.npc);

	value_t arglist = car(args);
	value_t body = cdr(args);

	local.num_args = length(arglist);

	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;

	// TODO: local leaks memory! free variables too, not just stack slots (in
	// two places). Add a free_local() function that does this.
	}

	void compile_tl(value_t val, struct environment *env)
	{
	if (!listp(val))
	err("Top level must be a list");

	value_t form = car(val);
	value_t args = cdr(val);

	if (symstreq(form, "defun") \|\| symstreq(form, "defmacro"))
	{
	enum namespace namespace = NS_FUNCTION;

	if (symstreq(form, "defmacro"))
	namespace = NS_MACRO;

	struct local local;
	int nargs;
	char name = (char )(car(args) ^ SYMBOL_TAG);
	dasm_State *d = compile_function(cdr(args), namespace, env, &local, NULL, &nargs, name);

	add_function(env, name, link(&d),
	nargs, namespace);

	dasm_free(&d);
	free(local.stack_slots);
	}
	}

	void walk_and_alloc(struct local *local, value_t body)
	{
	if (!listp(body))
	return;

	value_t args = cdr(body);

	if (symstreq(car(body), "let1"))
	{
	int slot = local_alloc(local);

	value_t expr = cdr(args);
	for (; !nilp(expr); expr = cdr(expr))
	{
	walk_and_alloc(local, car(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))
	{
	walk_and_alloc(local, car(args));
	}
	}
	}

	struct environment compile_all(struct istream *is)
	{
	unsigned char pool = make_pool();
	unsigned char pop = push_pool(pool);

	value_t val;
	struct environment env;
	env.first = NULL;
	load_std(&env);

	while (read1(is, &val))
	{
	compile_tl(val, &env);
	}

	pop_pool(pop);

	return env;
	}

	int nextpc(struct local local, dasm_State *Dst)
	{
	int n = local->nextpc++;
	if (n > local->npc)
	{
	local->npc += 16;
	dasm_growpc(Dst, local->npc);
	}
	return n;
	}

	void compile_backquote(struct environment env, struct local local,
	value_t val, dasm_State **Dst)
	{
	if (!listp(val))
	{
	\| mov eax, (val);
	}
	else
	{
	value_t fsym = car(val),
	args = cdr(val);
	int nargs = length(args);

	// TODO
	}
	}

	void compile_variable(struct variable v, dasm_State Dst)
	{
	switch (v->type)
	{
	case V_ARGUMENT:
	\| mov eax, dword [ebp + (value_size * (v->number + 2))];
	break;
	case V_BOUND:
	\| mov eax, dword [ebp - ((v->number + 1) * value_size)];
	break;
	case V_FREE:
	// edi is the closure context pointer
	\| mov eax, dword [edi + (v->number * value_size)];
	break;
	default:
	err("Sorry, can only access V_ARGUMENT, V_FREE and V_BOUND variables for now :(");
	}
	}

	void compile_expression(struct environment env, struct local local,
	value_t val, dasm_State **Dst)
	{
	if (symstreq(val, "nil"))
	{
	\| mov eax, (nil);
	}
	else if (symstreq(val, "t"))
	{
	\| mov eax, (t);
	}
	else if (integerp(val) \|\| stringp(val))
	{
	\| mov eax, val;
	}
	else if (listp(val))
	{
	value_t fsym = car(val);
	value_t args = cdr(val);
	int nargs = length(args);

	if (!symbolp(fsym))
	{
	err("function name must be a symbol");
	}

	if (symstreq(fsym, "if"))
	{
	if (nargs < 2 \|\| nargs > 3)
	err("Must give at least 2 arguments to if");

	compile_expression(env, local, car(args), Dst);
	int false_label = nextpc(local, Dst),
	after_label = nextpc(local, Dst);

	// result is in eax
	\| cmp eax, (nil);
	\| je =>false_label;

	compile_expression(env, local, elt(args, 1), Dst);
	\| jmp =>after_label;
	\|=>false_label:;
	if (nargs == 3)
	compile_expression(env, local, elt(args, 2), Dst);
	\|=>after_label:
	}
	else if (symstreq(fsym, "let1"))
	{
	if (nargs < 2)
	{
	err("Must give at least 2 arguments to let1");
	}
	value_t binding = car(args);
	value_t rest = cdr(args);

	if (length(binding) != 2)
	{
	err("Binding list in let1 must contain exactly two entries");
	}

	value_t name = car(binding);
	value_t value = car(cdr(binding));

	compile_expression(env, local, value, Dst);

	int i = local_alloc(local);

	add_variable(local, V_BOUND, (char *)(name ^ SYMBOL_TAG), i);

	\| mov dword [ebp - ((i + 1) * value_size)], eax;

	for (; !nilp(rest); rest = cdr(rest))
	{
	compile_expression(env, local, car(rest), Dst);
	}

	local_free(local, i);
	}
	else if (symstreq(fsym, "gc"))
	{
	if (nargs)
	{
	err("gc takes no arguments");
	}

	\| run_gc;
	}
	else if (symstreq(fsym, "quote"))
	{
	if (nargs != 1)
	err("quote should take exactly 1 argument");

	// Simple!
	\| mov eax, (car(args));
	}
	else if (symstreq(fsym, "backquote"))
	{
	if (nargs != 1)
	err("backquote should take exactly 1 argument");

	compile_backquote(env, local, car(args), Dst);
	}
	else if (symstreq(fsym, "function"))
	{
	if (nargs != 1)
	{
	err("function should take exactly 1 argument");
	}

	if (!symbolp(car(args)))
	{
	err("argument to function should be a symbol resolvable at compile time");
	}

	struct function f = find_function(env, (char )(car(args) ^ SYMBOL_TAG));
	value_t closure = create_closure(f->code_ptr, f->nargs, 0);

	\| mov eax, (closure);
	}
	else if (symstreq(fsym, "list"))
	{
	\| push (nil);

	for (int i = nargs - 1; i >= 0; i--)
	{
	compile_expression(env, local, elt(args, i), Dst);

	// push the ith item
	\| push eax;
	// cons the top two stack items
	\| mov ebx, (cons);
	\| call ebx;
	// remove the stack items from use
	\| add esp, (2 * value_size);
	// put the new thing on the stack
	\| push eax;
	}

	\| pop eax;
	}
	else if (symstreq(fsym, "lambda"))
	{
	// Compile the function with this as the parent scope
	struct local new_local;
	int nargs_out;
	dasm_State *d = compile_function(args, NS_ANONYMOUS, env, &new_local, local, &nargs_out, "recurse");

	// Link the function
	void *func_ptr = link(&d);

	// Create a closure object with the correct number of captures at
	// runtime
	\| push (new_local.num_closure_slots);
	\| push (nargs_out);
	\| push (func_ptr);
	\| mov ebx, (create_closure);
	\| call ebx;
	\| add esp, 12;

	// Walk the generated local scope for V_FREE variables, since each
	// of these exists in our scope (or higher), evaluate it and set it
	// as a member of the lambda capture.

	for (struct variable *var = new_local.first; var; var = var->prev)
	{
	if (var->type == V_FREE)
	{
	// Closure in eax
	\| push eax;
	// Variable now in eax
	compile_variable(find_variable(local, var->name), Dst);
	\| push eax;

	// The capture offset
	\| push (var->number);
	\| mov ebx, (set_closure_capture_variable);
	\| call ebx;
	// Skip the value and index
	\| add esp, 8;
	// Pop the closure back in to eax
	\| pop eax;
	}
	}

	// Closure is still in eax

	dasm_free(&d);
	free(new_local.stack_slots);
	}
	else
	{
	char name = (char )(fsym ^ SYMBOL_TAG);
	struct function *func = find_function(env, name);

	bool is_recursive = false;
	int nargs_needed = 0;

	if (symstreq(fsym, local->current_function_name))
	{
	is_recursive = true;
	nargs_needed = local->num_args;
	}
	else
	{
	if (func == NULL)
	{
	fprintf(stderr, "Function call: %s at %s:%d\n", name, cons_file(val), cons_line(val));
	err("Function undefined");
	}

	nargs_needed = func->nargs;
	}

	if (nargs != nargs_needed)
	{
	fprintf(stderr, "Function call: %s at %s:%d, want %d args but given %d\n",
	name, cons_file(val), cons_line(val), nargs_needed, nargs);
	err("wrong number of args");
	}

	if (is_recursive \|\| func->namespace == NS_FUNCTION)
	{
	for (int i = length(args) - 1; i >= 0; i--)
	{
	compile_expression(env, local, elt(args, i), Dst);
	\| push eax;
	}

	if (is_recursive)
	{
	\| call ->function_start;
	}
	else
	{
	\| mov ebx, (func->code_addr);
	\| call ebx;
	}
	\| add esp, (nargs * value_size);
	// result in eax
	}
	else if (func->namespace == NS_MACRO)
	{
	value_t expanded_to = call_list(func, args);

	compile_expression(env, local, expanded_to, Dst);
	}
	}
	}
	else if (symbolp(val))
	{
	struct variable v = find_variable(local, (char )(val ^ SYMBOL_TAG));

	if (!v)
	{
	fprintf(stderr, "var: %s\n", (char *)(val ^ SYMBOL_TAG));
	err("Variable unbound");
	}

	compile_variable(v, Dst);
	}
	}

	void compile_expr_to_func(struct environment env, char name, value_t val,
	dasm_State **Dst)
	{
	\| setup 0;

	struct local local;
	compile_expression(env, &local, val, Dst);

	\| cleanup;

	add_function(env, name, link(Dst), 0, NS_FUNCTION);
	}

	struct variable add_variable(struct local local, enum var_type type,
	char *name, int number)
	{
	struct variable *var = malloc(sizeof(struct variable));
	var->prev = local->first;
	var->type = type;
	var->name = name;
	var->number = number;

	local->first = var;

	return var;
	}

	void destroy_local(struct local *local)
	{
	for (struct variable *v = local->first; v;)
	{
	struct variable *t = v;
	v = v->prev;
	free(t);
	}
	}

	struct variable find_variable(struct local local, char *name)
	{
	struct variable *v = local->first;

	for (; v && strcmp(v->name, name) != 0; v = v->prev)
	{}

	if (!v)
	{
	if (local->parent)
	{
	v = find_variable(local->parent, name);

	if (v)
	{
	// We found this in a parent scope, add it as a V_FREE variable to skip the search.
	v = add_variable(local, V_FREE, name, local->num_closure_slots++);
	}
	}
	}
	return v;
	}

	extern value_t _call_list(void addr, value_t list, value_t edi);

	value_t call_list(struct function *func, value_t list)
	{
	return _call_list(func->code_ptr, list, NULL);
	}

	value_t call_list_closure(struct closure *c, value_t list)
	{
	return _call_list(c->function, list, c->data);
	}