src/lisp/compiler.dasc

/* -*- 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;

	for (f = env->first; f && strcmp(f->name, name); f = f->prev)
	{
	}

	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;
}

void del_local(struct local *local)
{
	free(local->stack_slots);

	for (struct variable *next, *f = local->first; f; f = next)
	{
		next = f->prev;
		free(f);
	}
}

void del_env(struct environment *env)
{
	for (struct function *next, *f = env->first; f; f = next)
	{
		next = f->prev;
		// We're not gonna bother munmap()ing the function
		free(f);
	}

	for (struct loaded_file *next, *l = env->first_loaded; l; l = next)
	{
		next = l->previous;
		free(l->resolved_path);
		free(l);
	}
}

void add_load(struct environment *env, char *path)
{
	static char buffer[512];
	long size = readlink(path, buffer, 512);
	buffer[size] = '\0';
	char *resolved = strdup(buffer);

	struct loaded_file *f = malloc(sizeof(struct loaded_file));
	f->resolved_path = resolved;
	f->previous = env->first_loaded;
	env->first_loaded = f;
}

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;
}

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_program(&d),
		             nargs, namespace);

		dasm_free(&d);
		del_local(&local);
	}
	else if (symstreq(form, "progn"))
	{
		for (value_t val = args; !nilp(val); val = cdr(val))
		{
			compile_tl(car(val), env);
		}
	}
}

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));
		}
	}
}

bool load(struct environment *env, char *path)
{
	if (!file_exists(path))
		return false;

	add_load(env, path);

	unsigned char pool = make_pool();
	unsigned char pop = push_pool(pool);

	struct istream *is = new_fistream(path, false);
	if (!is)
		return false;

	value_t val;

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

	del_fistream(is);
	pop_pool(pop);

	return true;
}

struct environment compile_file(char *filename, bool *ok)
{
	value_t val;
	struct environment env;
	env.first = NULL;
	env.first_loaded = NULL;

	add_load(&env, filename);
	load_std(&env);

	bool ok_ = load(&env, filename);

	if (ok)
		*ok = ok_;

	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, "progn"))
		{
			for (value_t val = args; !nilp(val); val = cdr(val))
			{
				compile_expression(env, local, car(val), Dst);
			}
		}
		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_program(&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);
			del_local(&new_local);
		}
		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)
			{
				// Make sure that the stuff allocated by the macro isn't in a pool
				unsigned char pool = push_pool(0);

				value_t expanded_to = call_list(func, args);

				pop_pool(pool);

				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_program(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);
}