388 lines
12 KiB
C
388 lines
12 KiB
C
#include "compile.h"
|
|
#include "unit.h"
|
|
#include "node.h"
|
|
#include "op.h"
|
|
|
|
#include <string.h>
|
|
#include <stdio.h>
|
|
|
|
int emit_arg_list(struct function *fn, struct context *ctx, struct node *expr) {
|
|
if (!expr) {
|
|
return 0;
|
|
}
|
|
assert(expr->type == N_CONS);
|
|
int e = emit_arg_list(fn, ctx, expr->n_cons.cdr);
|
|
emit(fn, ctx, expr->n_cons.car);
|
|
return e + 1;
|
|
}
|
|
|
|
void emit_function(struct context *ctx, struct function *fn) {
|
|
struct node *body = fn->body;
|
|
struct unit *root = ctx->root;
|
|
assert(ctx->owner == fn);
|
|
|
|
// Pass 0 - extract global scope
|
|
for (struct node *node = body; node; node = cdr(node)) {
|
|
struct node *expr = car(node);
|
|
|
|
if (pair_q(expr)) {
|
|
struct node *v0;
|
|
struct node *op = car(expr);
|
|
if (ident_q(op)) {
|
|
if (!strcmp(op->n_ident, "define")) {
|
|
v0 = cadr(expr);
|
|
if (ident_q(v0)) {
|
|
hash_insert(&ctx->vars, v0->n_ident, (void *) ctx->var_counter++);
|
|
} else if (cons_q(v0)) {
|
|
v0 = car(v0);
|
|
assert(ident_q(v0));
|
|
hash_insert(&ctx->vars, v0->n_ident, (void *) ctx->var_counter++);
|
|
} else {
|
|
printf("Unexpected expression: ");
|
|
vm_print(expr, 0);
|
|
printf("\n");
|
|
abort();
|
|
}
|
|
} else if (!strcmp(op->n_ident, "use")) {
|
|
v0 = cadr(expr);
|
|
assert(ident_q(v0));
|
|
// TODO `use`s should be local to their contexts
|
|
if (unit_ext_load(root, v0->n_ident) != 0) {
|
|
assert(0 && "Failed to load external unit\n");
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
// Pass 1 - emit code
|
|
// Emit entry
|
|
for (struct node *node = body; node; node = cdr(node)) {
|
|
struct node *expr = car(node);
|
|
emit(fn, ctx, expr);
|
|
}
|
|
// Obligatory program return
|
|
emit_insn(fn, OP(OP_RET, 0));
|
|
|
|
if (ctx->parent) {
|
|
fn->local_count = ctx->var_counter;
|
|
} else {
|
|
// Root function
|
|
fn->local_count = 0;
|
|
}
|
|
}
|
|
|
|
static void emit_store(struct function *fn, int kind, size_t index) {
|
|
switch (kind) {
|
|
case NAME_LOCAL:
|
|
emit_insn(fn, OP(OP_STL, index));
|
|
break;
|
|
case NAME_GLOBAL:
|
|
emit_insn(fn, OP(OP_STG, index));
|
|
break;
|
|
case NAME_ARGUMENT:
|
|
emit_insn(fn, OP(OP_STARG, index));
|
|
break;
|
|
default:
|
|
abort();
|
|
}
|
|
}
|
|
|
|
void emit(struct function *fn, struct context *ctx, struct node *expr) {
|
|
if (!expr) {
|
|
return;
|
|
}
|
|
struct node *n0, *n1, *n2, *n3;
|
|
int c0;
|
|
|
|
switch (expr->type) {
|
|
case N_CONS:
|
|
// Cons chain root - function call
|
|
n0 = expr->n_cons.car;
|
|
|
|
if (!n0) {
|
|
fprintf(stderr, "Call to nil\n");
|
|
abort();
|
|
}
|
|
if (n0->type != N_IDENT) {
|
|
fprintf(stderr, "TODO non-identifier calls\n");
|
|
abort();
|
|
}
|
|
|
|
// Only setq/define use this instruction
|
|
// TODO your defmacro could be here...
|
|
if (!strcmp(n0->n_ident, "define")) {
|
|
n0 = cadr(expr);
|
|
if (ident_q(n0)) {
|
|
int kind;
|
|
size_t index;
|
|
|
|
if (ctx_lookup_name(ctx, n0->n_ident, &kind, &index) != 0) {
|
|
fprintf(stderr, "Unresolved reference to %s\n", n0->n_ident);
|
|
abort();
|
|
}
|
|
|
|
n1 = caddr(expr);
|
|
assert(null_q(cdr(cddr(expr))));
|
|
// (define ident value)
|
|
// Emit value for n1
|
|
emit(fn, ctx, n1);
|
|
emit_store(fn, kind, index);
|
|
} else if (cons_q(n0)) {
|
|
struct node *name = car(n0);
|
|
struct node *args = cdr(n0);
|
|
struct node *body = cddr(expr);
|
|
|
|
assert(ident_q(name));
|
|
|
|
int kind;
|
|
size_t index;
|
|
|
|
assert(ctx_lookup_name(ctx, name->n_ident, &kind, &index) == 0);
|
|
assert(kind == NAME_GLOBAL);
|
|
|
|
struct function *new_fn = unit_lambda(ctx->root);
|
|
struct context new_ctx;
|
|
new_fn->args = args;
|
|
new_fn->body = body;
|
|
new_fn->local_count = 0;
|
|
assert(!ctx->parent);
|
|
ctx_init(&new_ctx, ctx);
|
|
new_ctx.var_counter = 0;
|
|
new_ctx.owner = new_fn;
|
|
|
|
emit_function(&new_ctx, new_fn);
|
|
// TODO do this at compile time for named functions?
|
|
emit_insn(fn, OP(OP_LDF, new_fn->index));
|
|
emit_insn(fn, OP(OP_STG, index));
|
|
}
|
|
return;
|
|
} else if (!strcmp(n0->n_ident, "setq")) {
|
|
n0 = cadr(expr);
|
|
n1 = caddr(expr);
|
|
assert(null_q(cdr(cddr(expr))));
|
|
int kind;
|
|
size_t index;
|
|
|
|
assert(ctx_lookup_name(ctx, n0->n_ident, &kind, &index) == 0);
|
|
emit(fn, ctx, n1);
|
|
|
|
emit_store(fn, kind, index);
|
|
return;
|
|
} else if (!strcmp(n0->n_ident, "use") || !strcmp(n0->n_ident, "export")) {
|
|
// Ignore
|
|
return;
|
|
}
|
|
|
|
// Check for macros/builtin operators
|
|
if (!strcmp(n0->n_ident, "lambda")) {
|
|
// (lambda list body...)
|
|
n0 = cadr(expr);
|
|
n1 = cddr(expr);
|
|
assert(cons_q(n0));
|
|
assert(!null_q(n1));
|
|
|
|
struct function *new_fn = unit_lambda(ctx->root);
|
|
struct context new_ctx;
|
|
new_fn->args = n0;
|
|
new_fn->body = n1;
|
|
new_fn->local_count = 0;
|
|
assert(!ctx->parent);
|
|
ctx_init(&new_ctx, ctx);
|
|
new_ctx.var_counter = 0;
|
|
new_ctx.owner = new_fn;
|
|
|
|
emit_function(&new_ctx, new_fn);
|
|
emit_insn(fn, OP(OP_LDF, new_fn->index));
|
|
|
|
return;
|
|
} else if (!strcmp(n0->n_ident, "begin")) {
|
|
n1 = cdr(expr);
|
|
assert(!null_q(n1));
|
|
|
|
for (; n1; n1 = cdr(n1)) {
|
|
n2 = car(n1);
|
|
|
|
emit(fn, ctx, n2);
|
|
}
|
|
return;
|
|
} else if (!strcmp(n0->n_ident, "if")) {
|
|
n1 = cadr(expr); // condition
|
|
n2 = caddr(expr); // yes-expr
|
|
n3 = car(cdr(cddr(expr))); // no-expr
|
|
assert(null_q(cddr(cddr(expr))));
|
|
|
|
emit(fn, ctx, n1);
|
|
// Will hop back and modify an already emitted jump with a proper
|
|
// offset
|
|
size_t cond_jmp_loc = fn->bytecode.size;
|
|
emit_insn(fn, OP(OP_BF, 0));
|
|
|
|
// Emit "yes" branch
|
|
emit(fn, ctx, n2);
|
|
size_t yes_jmp_loc = fn->bytecode.size;
|
|
emit_insn(fn, OP(OP_JMP, 0));
|
|
|
|
// Emit "no" branch
|
|
size_t no_loc = fn->bytecode.size;
|
|
emit(fn, ctx, n3);
|
|
|
|
size_t end_loc = fn->bytecode.size;
|
|
|
|
// Fix up jumps
|
|
uint32_t *cond_jmp, *yes_jmp;
|
|
cond_jmp = vector_ref(&fn->bytecode, cond_jmp_loc);
|
|
yes_jmp = vector_ref(&fn->bytecode, yes_jmp_loc);
|
|
|
|
*cond_jmp |= (no_loc - cond_jmp_loc) & 0xFFFFFF;
|
|
*yes_jmp |= (end_loc - yes_jmp_loc) & 0xFFFFFF;
|
|
return;
|
|
} else if (!strcmp(n0->n_ident, "while")) {
|
|
n1 = cadr(expr); // condition
|
|
n2 = cddr(expr); // list of expressions
|
|
assert(!null_q(n2));
|
|
|
|
size_t begin_loc = fn->bytecode.size;
|
|
emit(fn, ctx, n1);
|
|
size_t cond_jmp_loc = fn->bytecode.size;
|
|
emit_insn(fn, OP(OP_BF, 0));
|
|
|
|
for (struct node *item = n2; item; item = cdr(item)) {
|
|
struct node *stmt = car(item);
|
|
emit(fn, ctx, stmt);
|
|
}
|
|
|
|
// Jump back to the beginning
|
|
size_t end_jmp_loc = fn->bytecode.size;
|
|
ssize_t diff = (ssize_t) begin_loc - (ssize_t) end_jmp_loc;
|
|
emit_insn(fn, OP(OP_JMP, diff));
|
|
|
|
size_t end_loc = fn->bytecode.size;
|
|
uint32_t *cond_jmp;
|
|
cond_jmp = vector_ref(&fn->bytecode, cond_jmp_loc);
|
|
*cond_jmp |= (end_loc - cond_jmp_loc) & 0xFFFFFF;
|
|
return;
|
|
}
|
|
|
|
c0 = emit_arg_list(fn, ctx, expr->n_cons.cdr);
|
|
|
|
if (!strcmp(n0->n_ident, "+")) {
|
|
for (int i = 1; i < c0; ++i) {
|
|
emit_insn(fn, OP(OP_ADD, 0));
|
|
}
|
|
} else if (!strcmp(n0->n_ident, "-")) {
|
|
for (int i = 1; i < c0; ++i) {
|
|
emit_insn(fn, OP(OP_SUB, 0));
|
|
}
|
|
} else if (!strcmp(n0->n_ident, "*")) {
|
|
for (int i = 1; i < c0; ++i) {
|
|
emit_insn(fn, OP(OP_MUL, 0));
|
|
}
|
|
} else if (!strcmp(n0->n_ident, "/") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_DIV, 0));
|
|
} else if (!strcmp(n0->n_ident, "%") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_MOD, 0));
|
|
} else if (!strcmp(n0->n_ident, "cons") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_CONS, 0));
|
|
} else if (!strcmp(n0->n_ident, "=") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_EQ, 0));
|
|
} else if (!strcmp(n0->n_ident, "/=") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_NEQ, 0));
|
|
} else if (!strcmp(n0->n_ident, ">") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_GT, 0));
|
|
} else if (!strcmp(n0->n_ident, ">=") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_GE, 0));
|
|
} else if (!strcmp(n0->n_ident, "<") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_LT, 0));
|
|
} else if (!strcmp(n0->n_ident, "<=") && c0 == 2) {
|
|
emit_insn(fn, OP(OP_LE, 0));
|
|
} else if (!strcmp(n0->n_ident, "null?") && c0 == 1) {
|
|
emit_insn(fn, OP(OP_ISZ, 0));
|
|
} else if (!strcmp(n0->n_ident, "not") && c0 == 1) {
|
|
emit_insn(fn, OP(OP_NOT, 0));
|
|
} else if (!strcmp(n0->n_ident, "car") && c0 == 1) {
|
|
emit_insn(fn, OP(OP_CAR, 0));
|
|
} else if (!strcmp(n0->n_ident, "cdr") && c0 == 1) {
|
|
emit_insn(fn, OP(OP_CDR, 0));
|
|
} else if (!strcmp(n0->n_ident, "debug/trace") && c0 == 1) {
|
|
emit_insn(fn, OP(OP_DEBUG, OP_DEBUG_TRACE));
|
|
} else if (!strcmp(n0->n_ident, "debug/break")) {
|
|
emit_insn(fn, OP(OP_DEBUG, OP_DEBUG_BREAKPOINT));
|
|
} else {
|
|
size_t index;
|
|
int kind;
|
|
|
|
if (ctx_lookup_name(ctx, n0->n_ident, &kind, &index) != 0) {
|
|
printf("Undefined reference to function ");
|
|
vm_print(n0, 0);
|
|
printf("\n");
|
|
abort();
|
|
}
|
|
|
|
switch (kind) {
|
|
case NAME_EXTERNAL:
|
|
emit_insn(fn, OP(OP_XCALL, index));
|
|
break;
|
|
case NAME_LOCAL:
|
|
emit_insn(fn, OP(OP_LCALL, index));
|
|
break;
|
|
case NAME_ARGUMENT:
|
|
emit_insn(fn, OP(OP_LDARG, index));
|
|
emit_insn(fn, OP(OP_CALL, 0));
|
|
break;
|
|
case NAME_GLOBAL:
|
|
emit_insn(fn, OP(OP_GCALL, index));
|
|
break;
|
|
default:
|
|
printf("Unknown %d\n", kind);
|
|
abort();
|
|
}
|
|
}
|
|
return;
|
|
case N_INTEGER:
|
|
if (expr->n_integer < 0x7FFFFF && expr->n_integer > -0x7FFFFF) {
|
|
emit_insn(fn, OP(OP_LDI, expr->n_integer));
|
|
} else {
|
|
printf("ldc ...\n");
|
|
}
|
|
return;
|
|
case N_IDENT:
|
|
if (!strcmp(expr->n_ident, "nil")) {
|
|
emit_insn(fn, OP(OP_LDNIL, 0));
|
|
} else if (!strcmp(expr->n_ident, "t")) {
|
|
emit_insn(fn, OP(OP_LDI, 1));
|
|
} else {
|
|
int kind;
|
|
size_t index;
|
|
|
|
if (ctx_lookup_name(ctx, expr->n_ident, &kind, &index) != 0) {
|
|
printf("Unresolved reference to: ");
|
|
vm_print(expr, 0);
|
|
printf("\n");
|
|
abort();
|
|
}
|
|
|
|
switch (kind) {
|
|
case NAME_GLOBAL:
|
|
emit_insn(fn, OP(OP_LDG, index));
|
|
break;
|
|
case NAME_ARGUMENT:
|
|
emit_insn(fn, OP(OP_LDARG, index));
|
|
break;
|
|
case NAME_LOCAL:
|
|
emit_insn(fn, OP(OP_LDL, index));
|
|
break;
|
|
default:
|
|
abort();
|
|
}
|
|
}
|
|
return;
|
|
default:
|
|
printf("Unexpected value: ");
|
|
vm_print(expr, 0);
|
|
printf("\n");
|
|
abort();
|
|
}
|
|
}
|
|
|