summaryrefslogtreecommitdiff
path: root/pit/src/runtime/compile.c
diff options
context:
space:
mode:
Diffstat (limited to 'pit/src/runtime/compile.c')
-rw-r--r--pit/src/runtime/compile.c372
1 files changed, 231 insertions, 141 deletions
diff --git a/pit/src/runtime/compile.c b/pit/src/runtime/compile.c
index a676a61..e7a4ab8 100644
--- a/pit/src/runtime/compile.c
+++ b/pit/src/runtime/compile.c
@@ -1,35 +1,30 @@
#include <lcq/pit/runtime/compile.h>
-#include <stdio.h>
-
-static void call_special_form(pit_runtime *rt, pit_value f, pit_value args) {
- char buf[256] = {0};
- switch (pit_value_sort(f)) {
- case PIT_VALUE_SORT_REF: {
- pit_value_heavy *h = pit_value_ref_deref(rt, pit_value_as_ref(rt, f));
- if (!h) { pit_error(rt, "bad ref for special form"); return; }
- switch (h->hsort) {
- case PIT_VALUE_HEAVY_SORT_NATIVEFUNC:
- h->in.nativefunc.f(rt, args, h->in.nativefunc.data);
- break;
- default: {
- i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true);
- buf[end] = 0;
- pit_error(rt, "attempted to apply non-nativefunc special form: %s", buf);
- return;
- }
- }
- break;
- }
- default: {
- i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true);
- buf[end] = 0;
- pit_error(rt, "attempted to apply non-function special form: %s", buf);
- return;
- }
- }
+/* helper functions for manipulating the compiler state */
+static void c_now(pit_runtime *rt, pit_value v) {
+ /* push a literal value to the traversal */
+ pit_traversal_push_value(rt, rt->traversal, v);
+}
+static void c_compile(pit_runtime *rt, pit_value e) {
+ /* schedule an expression to be compiled */
+ /* the resulting entries will be pushed to the traversal subsequently */
+ pit_compilation_push_value(rt, rt->compilation_stack, e);
+}
+static void c_drop(pit_runtime *rt) {
+ /* schedule a drop to be compiled */
+ pit_compilation_push_drop(rt, rt->compilation_stack);
+}
+static void c_code(pit_runtime *rt, pit_value e) {
+ /* schedule an expression to be compiled, and then captured as code */
+ /* this will result in a literal code value being included in the program, */
+ /* rather than the code itself (as in c_compile) */
+ pit_compilation_push_end_code(rt, rt->compilation_stack);
+ pit_compilation_push_value(rt, rt->compilation_stack, e);
+ pit_compilation_push_begin_code(rt, rt->compilation_stack);
}
+/* given an expression and some initially bound variables (e.g. arguments), */
+/* compute the free variables in the expression */
static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value body) {
i64 expr_stack_reset = rt->expr_stack->next;
pit_value ret = PIT_NIL;
@@ -46,38 +41,50 @@ static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value b
bound = pit_value_cons_car(rt, boundscur);
cur = pit_value_cons_cdr(rt, boundscur);
if (pit_value_is_cons(rt, cur)) {
+ /* if the expression is a list, determine if it is a normal application */
pit_value fsym = pit_value_cons_car(rt, cur);
bool is_symbol = pit_value_is_symbol(rt, fsym);
+ bool is_special_form = is_symbol && pit_symtab_is_symbol_special_form(rt, fsym);
pit_value fargs = pit_value_cons_cdr(rt, cur);
- if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) {
+ /* first, consider special forms that have special behavior with regard to binding */
+ if (is_special_form && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) {
+ /* don't look inside quote!
+ NOTICE if we add other special forms, make sure to consider them here if necessary! */
+ } else if (is_special_form && pit_symtab_symbol_name_match_cstr(rt, fsym, "lambda")) {
+ /* the variables from the lambda argument list are now bound */
pit_value new_bound = pit_value_list_append(rt, pit_value_cons_car(rt, fargs), bound);
fargs = pit_value_cons_cdr(rt, fargs);
+ /* consider all body forms within the lambda with these new bindings in mind */
while (fargs != PIT_NIL) {
- if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, new_bound, pit_value_cons_car(rt, fargs))) < 0) {
+ pit_value bindings_expr_pair = pit_value_cons(rt, new_bound, pit_value_cons_car(rt, fargs));
+ if (pit_vec_push(pit_value)(rt->expr_stack, bindings_expr_pair) < 0) {
pit_error(rt, "free variable search stack overflow");
return PIT_NIL;
}
fargs = pit_value_cons_cdr(rt, fargs);
}
- } else if (is_symbol && pit_symtab_symbol_name_match_cstr(rt, fsym, "quote")) {
- /* don't look inside quote!
- if we add other special forms, make sure to consider them here if necessary! */
} else {
+ /* otherwise, this is a normal application form */
+ /* first consider all arguments to the application */
while (fargs != PIT_NIL) {
- if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, pit_value_cons_car(rt, fargs))) < 0) {
+ pit_value bindings_expr_pair = pit_value_cons(rt, bound, pit_value_cons_car(rt, fargs));
+ if (pit_vec_push(pit_value)(rt->expr_stack, bindings_expr_pair) < 0) {
pit_error(rt, "free variable search stack overflow");
return PIT_NIL;
}
fargs = pit_value_cons_cdr(rt, fargs);
}
if (!is_symbol) {
- if (pit_vec_push(pit_value)(rt->expr_stack, pit_value_cons(rt, bound, fsym)) < 0) {
+ /* ... and then consider the function being applied, if it is not a symbol */
+ pit_value bindings_expr_pair = pit_value_cons(rt, bound, fsym);
+ if (pit_vec_push(pit_value)(rt->expr_stack, bindings_expr_pair) < 0) {
pit_error(rt, "free variable search stack overflow");
return PIT_NIL;
}
}
}
} else if (pit_value_is_symbol(rt, cur)) {
+ /* if the expression is a symbol, check if it's free! */
if (pit_value_list_contains_eq(rt, cur, bound) == PIT_NIL) {
ret = pit_value_cons(rt, cur, ret);
}
@@ -87,136 +94,219 @@ static pit_value free_vars(pit_runtime *rt, pit_value initial_bound, pit_value b
return ret;
}
-static pit_value lambda(pit_runtime *rt, pit_value args, pit_value body) {
- pit_value expanded = pit_macroexpand(rt, pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), body));
- fprintf(stderr, "lambda: "); pit_dump_to_file(rt, stderr, expanded, false); fprintf(stderr, "\n");
- return pit_value_list(rt, 4,
- pit_symtab_intern_cstr(rt, "lambda"),
- args,
- free_vars(rt, args, expanded),
- pit_compile(rt, expanded)
- );
+static void compile_special_form(pit_runtime *rt, pit_value f, pit_value args) {
+ char buf[256] = {0};
+ if (pit_symtab_symbol_name_match_cstr(rt, f, "quote")) {
+ /* quote compiles to a literal instruction */
+ c_now(rt,
+ pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), pit_value_cons_car(rt, args))
+ );
+ } else if (pit_symtab_symbol_name_match_cstr(rt, f, "if")) {
+ /* if compiles the condition, and then code for the branches, and then the if instruction */
+ pit_value c = pit_value_cons_car(rt, args);
+ args = pit_value_cons_cdr(rt, args);
+ pit_value t = pit_value_cons_car(rt, args);
+ args = pit_value_cons_cdr(rt, args);
+ pit_value e = pit_value_cons_car(rt, args);
+ c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "if")));
+ c_code(rt, e);
+ c_code(rt, t);
+ c_compile(rt, c);
+ } else if (pit_symtab_symbol_name_match_cstr(rt, f, "progn")) {
+ /* progn simply compiles each of its argument forms in order */
+ /* after every form but the final form, it inserts a drop to ignore the return value */
+ while (args != PIT_NIL) {
+ pit_value form = pit_value_cons_car(rt, args);
+ args = pit_value_cons_cdr(rt, args);
+ c_compile(rt, form);
+ if (args != PIT_NIL) {
+ c_drop(rt);
+ }
+ }
+ } else if (pit_symtab_symbol_name_match_cstr(rt, f, "lambda")) {
+ pit_value arglist = pit_value_cons_car(rt, args);
+ pit_value body = pit_value_cons(rt, pit_symtab_intern_cstr(rt, "progn"), pit_value_cons_cdr(rt, args));
+ c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "lambda")));
+ c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), arglist));
+ c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), free_vars(rt, arglist, body)));
+ c_code(rt, body);
+ } else {
+ i64 end = pit_dump(rt, buf, sizeof(buf) - 1, f, true);
+ buf[end] = 0;
+ pit_error(rt, "unknown special form: %s", buf);
+ }
}
-static void c_now(pit_runtime *rt, pit_value v) {
- pit_traversal_push_value(rt, rt->traversal, v);
+static void compile_output_instruction(pit_runtime *rt, pit_value ins) {
+ /* write an instruction to the code block at the top of the compilation stack */
+ pit_compilation_entry b;
+ if (pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &b) < 0) {
+ pit_error(rt, "compilation block stack underflow");
+ return;
+ }
+ pit_value new = pit_value_cons(rt, ins, b.in.value);
+ pit_compilation_push_value(rt, rt->compilation_stack, new);
}
-static void c_eval(pit_runtime *rt, pit_value e) {
- if (pit_vec_push(pit_value)(rt->expr_stack, e) < 0)
- pit_error(rt, "evaluation stack overflow");
+static void compile_interpret_traversal_entry(pit_runtime *rt, pit_traversal_entry *ent) {
+ if (ent == NULL) {
+ pit_error(rt, "evaluation traversal invalid");
+ return;
+ }
+ switch (ent->sort) {
+ case PIT_TRAVERSAL_ENTRY_VALUE: {
+ /* normal traversal entries just cons values to the code block at the top of the compilation stack */
+ compile_output_instruction(rt, ent->in.value);
+ return;
+ }
+ case PIT_TRAVERSAL_ENTRY_BEGIN_CODE: {
+ /* starting a new code block pushes a new list to the top of the compilation stack */
+ pit_compilation_push_value(rt, rt->compilation_stack, PIT_NIL);
+ return;
+ }
+ case PIT_TRAVERSAL_ENTRY_END_CODE: {
+ /* ending a code block pops a code block, and pushes it as a literal in the frame below */
+ pit_compilation_entry b;
+ if (pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &b) < 0) {
+ pit_error(rt, "compilation block stack underflow");
+ return;
+ }
+ compile_output_instruction(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), b.in.value));
+ return;
+ }
+ default:
+ pit_error(rt, "unknown traversal entry");
+ return;
+ }
}
pit_value pit_compile(pit_runtime *rt, pit_value top) {
+ /* compilation proceeds in a somewhat unintuitive manner */
+ /* typically, we would simply recursively traverse the tree, accumulating the output code */
+ /* (this also has the advantage of allowing the results of the recursive compilation call to */
+ /* be used in nonstandard contexts, such as compiling the body of lambdas. */
+ /* however, in pit we would like to avoid this sort of recursion, as we'd like to be able to */
+ /* make claims about the interpreter's C stack usage (and also, in general, it seems quite */
+ /* nice to avoid C stack usage growing with expression size!) */
+ /* as such, we must explicitly represent the control/data flow that would otherwise be handled */
+ /* implicitly by the recursion. we do this by breaking the compilation step into several steps. */
+ /* first, we traverse the expression using a stack (rt->compilation_stack). during this step, we */
+ /* push subexpression to be compiled to the stack, and append "generated code" to an intermediate */
+ /* structure (rt->traversal). this intermediate structure contains "operations" to later perform */
+ /* - think of it as the "continuation" of the code that produced it. finally, these intermediate */
+ /* operations are "interpreted" to generate the real compiled code, which is a Lisp list of instructions */
+ /* each instruction is itself a list of opcode and operands (see eval.c for more information on this) */
char buf[256] = {0};
- pit_value ret = PIT_NIL;
- i64 expr_stack_reset = rt->expr_stack->next;
+ i64 compilation_stack_reset = rt->compilation_stack->next;
i64 traversal_reset = rt->traversal->next;
- fprintf(stderr, "compile: "); pit_dump_to_file(rt, stderr, top, false); fprintf(stderr, "\n");
- c_eval(rt, top);
- /* convert the expression tree into "polish notation" in traversal */
- while (rt->expr_stack->next > expr_stack_reset) {
- pit_value cur = PIT_NIL;
- if (rt->error != PIT_NIL) goto end;
- if (pit_vec_pop(pit_value)(rt->expr_stack, &cur) < 0)
- pit_error(rt, "evaluation stack underflow");
- fprintf(stderr, "cur: "); pit_dump_to_file(rt, stderr, cur, false); fprintf(stderr, "\n");
- if (pit_value_is_cons(rt, cur)) {
- pit_value fsym = pit_value_cons_car(rt, cur);
- bool is_symbol = pit_value_is_symbol(rt, fsym);
- // pit_annotation *ann = pit_annotation_get(rt, pit_value_as_ref(rt, cur));
- if (is_symbol && pit_symtab_is_symbol_special_form(rt, fsym)) { /* special forms */
- pit_value f = pit_symtab_fget(rt, fsym);
- pit_value args = pit_value_cons_cdr(rt, cur);
- call_special_form(rt, f, args);
- } else if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { /* macros */
- i64 end = pit_dump(rt, buf, sizeof(buf) - 1, fsym, true);
- buf[end] = 0;
- pit_error(rt, "encountered an unexpanded macro while compiling: %s", buf);
- } else { /* normal functions */
- pit_value args = pit_value_cons_cdr(rt, cur);
- i64 argcount = 0;
- while (args != PIT_NIL) {
- // fprintf(stderr, "push1: "); pit_dump_to_file(rt, stderr, pit_value_cons_car(rt, args), false); fprintf(stderr, "\n");
- c_eval(rt, pit_value_cons_car(rt, args));
- args = pit_value_cons_cdr(rt, args);
- argcount += 1;
- }
- if (!is_symbol) {
- // fprintf(stderr, "push2: "); pit_dump_to_file(rt, stderr, fsym, false); fprintf(stderr, "\n");
- c_eval(rt, fsym);
+ /* before we do anything else, we fully macroexpand the input */
+ top = pit_macroexpand(rt, top);
+ c_compile(rt, top);
+ while (rt->compilation_stack->next > compilation_stack_reset) {
+ pit_compilation_entry curent;
+ if (rt->error != PIT_NIL) goto err;
+ if (pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &curent) < 0) {
+ pit_error(rt, "compilation stack underflow");
+ goto err;
+ }
+ switch (curent.sort) {
+ case PIT_COMPILATION_ENTRY_VALUE: {
+ pit_value cur = curent.in.value;
+ if (pit_value_is_cons(rt, cur)) {
+ pit_value fsym = pit_value_cons_car(rt, cur);
+ bool is_symbol = pit_value_is_symbol(rt, fsym);
+ if (is_symbol && pit_symtab_is_symbol_special_form(rt, fsym)) { /* special forms */
+ pit_value args = pit_value_cons_cdr(rt, cur);
+ compile_special_form(rt, fsym, args);
+ } else if (is_symbol && pit_symtab_is_symbol_macro(rt, fsym)) { /* macros */
+ i64 end = pit_dump(rt, buf, sizeof(buf) - 1, fsym, true);
+ buf[end] = 0;
+ pit_error(rt, "encountered an unexpanded macro while compiling: %s", buf);
+ } else { /* normal functions */
+ pit_value args = pit_value_cons_cdr(rt, cur);
+ i64 argcount = 0;
+ while (args != PIT_NIL) {
+ c_compile(rt, pit_value_cons_car(rt, args));
+ args = pit_value_cons_cdr(rt, args);
+ argcount += 1;
+ }
+ if (!is_symbol) {
+ c_compile(rt, fsym);
+ }
+ c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "apply"), pit_value_integer_new(rt, argcount)));
+ if (is_symbol) {
+ c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "fget")));
+ c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), fsym));
+ }
}
- c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "apply"), pit_value_integer_new(rt, argcount)));
- if (is_symbol) {
- c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "fget")));
- c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), fsym));
+ } else if (pit_value_is_symbol(rt, cur)) { /* unquoted symbols: variable lookup */
+ pit_symtab_entry *ent = pit_symtab_lookup(rt, cur);
+ if (ent->is_keyword) {
+ c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur));
+ } else {
+ c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "get")));
+ c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur));
}
- }
- } else if (pit_value_is_symbol(rt, cur)) { /* unquoted symbols: variable lookup */
- pit_symtab_entry *ent = pit_symtab_lookup(rt, cur);
- if (ent->is_keyword) {
- c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur));
- } else {
- c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "get")));
+ } else { /* other expressions evaluate to themselves! */
c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur));
}
- } else { /* other expressions evaluate to themselves! */
- c_now(rt, pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), cur));
+ break;
+ }
+ case PIT_COMPILATION_ENTRY_DROP: {
+ /* a BEGIN_CODE is a marker indicating that a new "block" of code has started */
+ c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "drop")));
+ break;
+ }
+ case PIT_COMPILATION_ENTRY_BEGIN_CODE: {
+ /* a BEGIN_CODE is a marker indicating that a new "block" of code has started */
+ pit_traversal_push_begin_code(rt, rt->traversal);
+ break;
+ }
+ case PIT_COMPILATION_ENTRY_END_CODE: {
+ /* an END_CODE is a marker indicating that the current "block" of code has finished */
+ pit_traversal_push_end_code(rt, rt->traversal);
+ break;
+ }
}
}
+ /* now that we've built up the traversal, we iterate over it to build up the final program */
+ /* the "current" code is at the top of the compilation stack (which we now repurpose to this end) */
+ /* (note that this usage of the compilation state is entirely separate from the previous usage!) */
+ rt->compilation_stack->next = compilation_stack_reset;
+ pit_compilation_push_value(rt, rt->compilation_stack, PIT_NIL);
for (i64 idx = traversal_reset; idx < rt->traversal->next; idx++) {
pit_traversal_entry *ent = pit_vec_get(pit_traversal_entry)(rt->traversal, idx);
- if (ent == NULL) pit_error(rt, "evaluation traversal invalid");
if (rt->error != PIT_NIL) goto end;
- switch (ent->sort) {
- case PIT_TRAVERSAL_ENTRY_VALUE: {
- ret = pit_value_cons(rt, ent->in.value, ret);
- break;
- }
- default:
- pit_error(rt, "unknown traversal entry");
- ret = PIT_NIL;
- goto end;
- }
+ compile_interpret_traversal_entry(rt, ent);
+ }
+ goto end;
+err: {
+ /* in case of error, we should always consider the stack empty, so we don't return something spurious */
+ rt->compilation_stack->next = compilation_stack_reset;
}
end: {
- rt->expr_stack->next = expr_stack_reset;
+ /* finally, we are done (possibly due to an error) */
+ pit_value ret = PIT_NIL;
+ if (rt->compilation_stack->next > compilation_stack_reset) {
+ /* if the compilation stack is not empty, the top is our compiled code! */
+ pit_compilation_entry ent;
+ pit_vec_pop(pit_compilation_entry)(rt->compilation_stack, &ent);
+ ret = ent.in.value;
+ }
+ if (rt->compilation_stack->next != compilation_stack_reset) {
+ /* if there was more than one entry on the compilation stack, this is a bug */
+ pit_error(rt, "compilation did not reduce stack to single code! this is a bug!");
+ }
+ rt->compilation_stack->next = compilation_stack_reset;
rt->traversal->next = traversal_reset;
- fprintf(stderr, "compiled: "); pit_dump_to_file(rt, stderr, ret, false); fprintf(stderr, "\n");
return ret;
}
}
-static pit_value impl_sf_quote(pit_runtime *rt, pit_value args, void *data) {
- (void) data;
- pit_traversal_push_value(rt, rt->traversal,
- pit_value_list(rt, 2, pit_symtab_intern_cstr(rt, "literal"), pit_value_cons_car(rt, args))
- );
- return PIT_NIL;
-}
-static pit_value impl_sf_if(pit_runtime *rt, pit_value args, void *data) {
- (void) data;
- pit_value c = pit_value_cons_car(rt, args);
- args = pit_value_cons_cdr(rt, args);
- pit_value t = pit_value_cons_car(rt, args);
- args = pit_value_cons_cdr(rt, args);
- pit_value e = pit_value_cons_car(rt, args);
- c_now(rt, pit_value_list(rt, 1, pit_symtab_intern_cstr(rt, "if")));
- c_now(rt, lambda(rt, PIT_NIL, pit_value_list(rt, 1, t)));
- c_now(rt, lambda(rt, PIT_NIL, pit_value_list(rt, 1, e)));
- c_eval(rt, c);
- return PIT_NIL;
-}
-static pit_value impl_sf_lambda(pit_runtime *rt, pit_value args, void *data) {
- (void) data;
- pit_value as = pit_value_cons_car(rt, args);
- pit_value body = pit_value_cons_cdr(rt, args);
- c_now(rt, lambda(rt, as, body));
- return PIT_NIL;
-}
-
+/* mark the symbols for the special forms as such */
void pit_compile_install_special_forms(pit_runtime *rt) {
- pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "quote"), pit_value_nativefunc_new(rt, impl_sf_quote));
- pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "if"), pit_value_nativefunc_new(rt, impl_sf_if));
- pit_symtab_sfset(rt, pit_symtab_intern_cstr(rt, "lambda"), pit_value_nativefunc_new(rt, impl_sf_lambda));
+ pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "quote"));
+ pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "if"));
+ pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "progn"));
+ pit_symtab_symbol_mark_special_form(rt, pit_symtab_intern_cstr(rt, "lambda"));
}
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-02 00:17:28 +0000