diff --git a/.gitignore b/.gitignore index 7dd96ee..206948b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,3 @@ -wscm -*.o -compile_commands.json -.cache -.envrc -test.lisp +/.cache +/build +/.envrc diff --git a/README.md b/README.md index 1288ea7..f05a6b1 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,5 @@ # wolflisp -a lisp but wolfy. right now it's very minimal... :^) \ No newline at end of file +a lisp but wolfy. right now it's very minimal... :^) + +## todo +- [ ] macros in the new bytecode interpreter/compiler diff --git a/include/wolflisp.h b/include/wolflisp.h index 4b77e53..1adae65 100644 --- a/include/wolflisp.h +++ b/include/wolflisp.h @@ -14,6 +14,7 @@ typedef intptr_t I; typedef uintptr_t U; typedef char C; typedef uint8_t U8; +typedef uint16_t U16; typedef uint32_t U32; typedef int32_t I32; typedef size_t Z; @@ -26,7 +27,7 @@ typedef U O; #define NUM(x) (((O)((I)(x) << 1)) | (O)1) #define ORD(x) ((I)(x) >> 1) -// Pair +// Cons pair typedef struct Pa { O head, tail; } Pa; @@ -48,11 +49,21 @@ typedef struct Cl { O args, body, env; } Cl; +// Bytecode +typedef struct Bc { + Z len; + U8 *data; + Z constant_count; + O *constants; +} Bc; + // Primitive typedef struct In In; typedef struct Pr { const char *name; - O (*fn)(In *, O, O); + O (*fn)(In *, O *, int, O); // fn(interp, args_array, argc, env) + int min_args; // Minimum number of arguments (-1 for no check) + int max_args; // Maximum number of arguments (-1 for variadic) } Pr; // Symbol table @@ -62,7 +73,7 @@ typedef struct St { Sy **data; } St; -#define HEAP_BYTES (1024 * 1024) +#define HEAP_BYTES (4 * 1024 * 1024) #define TYPE_MASK 7 enum { @@ -81,6 +92,7 @@ enum { TYPE_STR, TYPE_CLOS, TYPE_MAC, + TYPE_CODE, TYPE_FWD, TYPE__MAX, }; @@ -125,6 +137,14 @@ typedef struct Er { } stack; } Er; +// Call frame +typedef struct Fr { + U8 *ip; + O env; +} Fr; + +#define VM_STACK_SIZE 4096 + // Interpreter context typedef struct In { Gc gc; @@ -132,8 +152,64 @@ typedef struct In { O env; Er err; O t; // the T symbol + O stack[VM_STACK_SIZE]; + O *sp; } In; +// Opcodes +enum { + OP_HALT, + OP_CONST, + OP_GET, + OP_SET, + OP_JUMP, + OP_JUMP_IF_NIL, + OP_CALL, + OP_RET, + OP_POP, + OP_CLOS, + OP_TAIL_CALL, + OP_BIND, + OP_BIND_REST, + OP_PEEK, + OP_GET_LOCAL, // Get local variable from stack frame + OP_SET_LOCAL, // Set local variable in stack frame + OP_RESERVE, // Reserve space for local variables +}; + +// Local variable info +typedef struct Lv { + O name; // Symbol name + U16 index; // Stack slot index + int captured; // Is this variable captured by a closure? +} Lv; + +// Compiler context +typedef struct Cm { + In *in; + U8 *code; + Z count; + Z capacity; + struct { + O *data; + Z count; + Z capacity; + } constants; + struct { + O quote; + O iff; + O fn; + O progn; + O def; + } specials; + struct { + Lv *data; + Z count; + Z capacity; + } locals; + int use_stack_locals; // Use stack-based locals instead of env +} Cm; + enum { TOK_EOF = 0, TOK_COMMENT = ';', @@ -180,8 +256,6 @@ V gc_finalize(Gc *gc); void error_init(Er *err); void error_throw(In *in, const char *fmt, ...); -void error_push_frame(In *in, const char *frame); -void error_pop_frame(In *in); void error_print(In *in); // Initialize an interpreter context. @@ -189,12 +263,6 @@ V interp_init(In *in); // Finalize an interpreter context. V interp_finalize(In *in); -// Evaluate a list of values. -O interp_eval_list(In *in, O list, O env); - -// Evaluate an expression. -O interp_eval(In *in, O obj, O env); - // Intern a string Sy *intern(St *tab, const char *str, Z len); @@ -209,10 +277,15 @@ V print(O obj); V println(O obj); O symbol_make(In *in, const char *str); -O prim_make(In *in, const char *name, O (*fn)(In *, O, O)); +O prim_make(In *in, const char *name, O (*fn)(In *, O *, int, O), int min_args, int max_args); O list_assoc(In *in, O key, O alist); O list_reverse(In *in, O list); +O list_next(In *in, O *list); + +V compile(Cm *co, O expr, I toplevel); +V disassemble(Cm *co); +O vm_run(Cm *c); int nexttoken(Lx *lex); diff --git a/meson.build b/meson.build index f807883..c484dee 100644 --- a/meson.build +++ b/meson.build @@ -8,6 +8,8 @@ project( inc = include_directories('include', 'src') src = [ + 'src/compile.c', + 'src/disasm.c', 'src/error.c', 'src/gc.c', 'src/interp.c', @@ -21,6 +23,7 @@ src = [ 'src/string.c', 'src/symbol.c', 'src/type.c', + 'src/vm.c', ] exe = executable( diff --git a/shell.nix b/shell.nix index 372e8a2..4dd56cc 100644 --- a/shell.nix +++ b/shell.nix @@ -1,6 +1,8 @@ -{ pkgs ? import {} }: +{ + pkgs ? import { }, +}: pkgs.mkShell { - name = "rufus"; + name = "wl"; packages = with pkgs; [ rlwrap clang-tools diff --git a/src/compile.c b/src/compile.c new file mode 100644 index 0000000..b1aa8a8 --- /dev/null +++ b/src/compile.c @@ -0,0 +1,338 @@ +#include +#include +#include + +static int find_local(Cm *co, O sym) { + for (Z i = 0; i < co->locals.count; i++) { + if (co->locals.data[i].name == sym) { + return (int)i; + } + } + return -1; +} + +static void add_local(Cm *co, O sym) { + if (co->locals.count >= co->locals.capacity) { + Z newcap = co->locals.capacity == 0 ? 16 : co->locals.capacity * 2; + Lv *newdata = realloc(co->locals.data, newcap * sizeof(Lv)); + if (!newdata) + abort(); + co->locals.capacity = newcap; + co->locals.data = newdata; + } + co->locals.data[co->locals.count].name = sym; + co->locals.data[co->locals.count].index = (U16)co->locals.count; + co->locals.count++; +} + +static V emit(Cm *co, U8 byte) { + if (co->count >= co->capacity) { + Z newcap = co->capacity == 0 ? 16 : co->capacity * 2; + U8 *newdata = realloc(co->code, newcap); + if (!newdata) + abort(); + co->capacity = newcap; + co->code = newdata; + } + co->code[co->count++] = byte; +} + +static V emit16(Cm *co, U16 word) { + emit(co, word >> 8); + emit(co, word & 0xff); +} + +O code_make(In *in, const U8 *code, Z len, O *constants, Z clen) { + Z size = sizeof(Gh) + sizeof(Bc); + Gh *hdr = gc_alloc(&in->gc, size); + hdr->type = TYPE_CODE; + Bc *s = (Bc *)(hdr + 1); + s->len = len; + s->data = malloc(len + 1); + if (!s->data) + abort(); + s->constants = constants; + s->constant_count = clen; + memcpy(s->data, code, len); + s->data[len] = 0; + return BOX(hdr); +} + +static Z add_constant(Cm *co, O obj) { + for (Z i = 0; i < co->constants.count; i++) { + if (co->constants.data[i] == obj) + return i; + } + + if (co->constants.count >= co->constants.capacity) { + Z newcap = co->constants.capacity == 0 ? 16 : co->constants.capacity * 2; + O *newdata = realloc(co->constants.data, newcap * sizeof(O *)); + if (!newdata) + abort(); + co->constants.capacity = newcap; + co->constants.data = newdata; + } + co->constants.data[co->constants.count++] = obj; + return co->constants.count - 1; +} + +V compile(Cm *co, O expr, I tail); + +// Compile a (potentially tail-)call to `fn` with `args`. +static V compile_call(Cm *co, O fn, O args, I tail) { + I argc = 0; + + // Compile each argument expression for the function. + for (O next = list_next(co->in, &args); next != NIL; + next = list_next(co->in, &args)) { + compile(co, next, 0); + argc++; + } + + // Compile the function reference itself + compile(co, fn, 0); + + // Compile the call (opcode followed by number of arguments as a byte) + emit(co, tail ? OP_TAIL_CALL : OP_CALL); + emit(co, (U8)argc); +} + +// Compile the `(if cond then else?)` special form. +static V compile_if(Cm *c, O form, I tail) { + O cond_expr = list_next(c->in, &form); + O then_expr = list_next(c->in, &form); + O else_expr = list_next(c->in, &form); + + if (cond_expr == NIL || then_expr == NIL) + error_throw(c->in, "expected at least two arguments for if"); + + // Compile the condition expression + compile(c, cond_expr, 0); + + // Prepare the jump to the else-expression + emit(c, OP_JUMP_IF_NIL); + Z jump_else = c->count; + emit16(c, 0); + + // Compile the then-expression + compile(c, then_expr, tail); + Z jump_then = 0; + if (!tail) { + // If the expression is not on a tail-position, compile a jump to the code + // following the else-expression + emit(c, OP_JUMP); + jump_then = c->count; + emit16(c, 0); + } + + // Patch the first jump (to the else-expression) + Z else_offset = c->count; + c->code[jump_else] = (U8)(else_offset >> 8); + c->code[jump_else + 1] = (U8)(else_offset & 0xff); + + // Compile the else-expression + compile(c, else_expr, tail); + Z end = c->count; + + if (!tail) { + // Patch the second jump (to the end of the else-expression) if we're not + // on a tail-position + c->code[jump_then] = (U8)(end >> 8); + c->code[jump_then + 1] = (U8)(end & 0xff); + } +} + +// Compile the `(progn expr...)` special form. +static V compile_progn(Cm *co, O forms, I tail) { + // If there are no forms to compile, simply compile NIL. + if (forms == NIL) { + emit(co, OP_CONST); + emit16(co, add_constant(co, NIL)); + if (tail) + emit(co, OP_RET); + return; + } + + // Compile all forms, discarding intermediate results. + while (forms != NIL) { + O expr = list_next(co->in, &forms); + compile(co, expr, forms == NIL ? tail : 0); + if (forms != NIL) + emit(co, OP_POP); + } +} + +static int nested_p(Cm *c, O body) { + while (body != NIL) { + O expr = list_next(c->in, &body); + if (type(expr) == TYPE_PAIR) { + Pa *p = pair_unwrap(c->in, expr); + if (p->head == c->specials.fn) + return 1; + if (nested_p(c, expr)) + return 1; + } + } + return 0; +} + +// Compile a closure with `args` and `body`. +static V compile_fn(Cm *c, O args, O body) { + // Create an inner compiler context for compiling the closure's body. + Cm ic; + memset(&ic, 0, sizeof(Cm)); + ic.in = c->in; + ic.specials = c->specials; + + O curr = args; + O fixed[256]; + int fixed_count = 0; + O rest = NIL; + + // Count fixed arguments, and if the function has a rest argument + while (curr != NIL) { + if (type(curr) == TYPE_SYM) { + rest = curr; + break; + } + Pa *p = pair_unwrap(c->in, curr); + fixed[fixed_count++] = p->head; + curr = p->tail; + } + + int nested = nested_p(c, body); + if (rest == NIL && !nested) { + // If the function has no rest argument, and has no nested closures inside + // it, compile using stack locals as an optimization for tail-calls + ic.use_stack_locals = 1; + curr = args; + for (O next = list_next(c->in, &curr); next != NIL; + next = list_next(c->in, &curr)) + add_local(&ic, next); + } else { + // Otherwise, fallback to using environment bindings for locals + ic.use_stack_locals = 0; + if (rest != NIL) { + emit(&ic, OP_BIND_REST); + emit16(&ic, add_constant(&ic, rest)); + emit16(&ic, fixed_count); + } + for (int i = fixed_count - 1; i >= 0; i--) { + emit(&ic, OP_BIND); + emit16(&ic, add_constant(&ic, fixed[i])); + } + } + + // Compile the function's body (as a `progn` form) + compile_progn(&ic, body, 1); + O code = code_make(c->in, ic.code, ic.count, ic.constants.data, + ic.constants.count); + Z code_idx = add_constant(c, code); + Z args_idx = add_constant(c, args); + + // Compile pushing the closure to the stack. + emit(c, OP_CLOS); + emit16(c, code_idx); + emit16(c, args_idx); + + // Free the inner compiler context. + free(ic.code); + if (ic.locals.data) + free(ic.locals.data); +} + +// Compile the `(def name value)` special form +static V compile_def(Cm *c, O args, I tail) { + O sym = list_next(c->in, &args); + if (type(sym) != TYPE_SYM) + error_throw(c->in, "def: expected symbol"); + O val = list_next(c->in, &args); + compile(c, val, 0); + emit(c, OP_SET); + emit16(c, add_constant(c, sym)); + emit(c, OP_CONST); + emit16(c, add_constant(c, sym)); + if (tail) + emit(c, OP_RET); +} + +// Compile a function application/special form +static V compile_apply(Cm *co, O expr, I tail) { + Pa *p = pair_unwrap(co->in, expr); + O head = p->head; + + // Compile special forms + if (type(head) == TYPE_SYM) { + if (head == co->specials.quote) { + Pa *args = pair_unwrap(co->in, p->tail); + emit(co, OP_CONST); + emit16(co, add_constant(co, args->head)); + if (tail) + emit(co, OP_RET); + return; + } else if (head == co->specials.iff) { + compile_if(co, p->tail, tail); + return; + } else if (head == co->specials.progn) { + compile_progn(co, p->tail, tail); + return; + } else if (head == co->specials.fn) { + Pa *args = pair_unwrap(co->in, p->tail); + compile_fn(co, args->head, args->tail); + if (tail) + emit(co, OP_RET); + return; + } else if (head == co->specials.def) { + compile_def(co, p->tail, tail); + return; + } + } + compile_call(co, head, p->tail, tail); +} + +V compile(Cm *co, O expr, I tail) { + I ty = type(expr); + + if (co->specials.quote == NIL) + co->specials.quote = symbol_make(co->in, "quote"); + if (co->specials.iff == NIL) + co->specials.iff = symbol_make(co->in, "if"); + if (co->specials.progn == NIL) + co->specials.progn = symbol_make(co->in, "progn"); + if (co->specials.fn == NIL) + co->specials.fn = symbol_make(co->in, "fn"); + if (co->specials.def == NIL) + co->specials.def = symbol_make(co->in, "def"); + + switch (ty) { + case TYPE_NIL: + case TYPE_NUM: + case TYPE_STR: + emit(co, OP_CONST); + emit16(co, add_constant(co, expr)); + if (tail) + emit(co, OP_RET); + break; + case TYPE_SYM: + if (co->use_stack_locals) { + int idx = find_local(co, expr); + if (idx >= 0) { + emit(co, OP_GET_LOCAL); + emit16(co, idx); + if (tail) + emit(co, OP_RET); + return; + } + } + emit(co, OP_GET); + emit16(co, add_constant(co, expr)); + if (tail) + emit(co, OP_RET); + break; + case TYPE_PAIR: + compile_apply(co, expr, tail); + break; + default: + error_throw(co->in, "compile: cannot compile type %s", typename(ty)); + } +} diff --git a/src/disasm.c b/src/disasm.c new file mode 100644 index 0000000..a166437 --- /dev/null +++ b/src/disasm.c @@ -0,0 +1,109 @@ +#include + +V disassemble(Cm *co) { + for (Z ofs = 0; ofs < co->count; ofs++) { + printf("%04zx: ", ofs); + switch (co->code[ofs]) { + case OP_CONST: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("CONST %d (", idx); + print(co->constants.data[idx]); + printf(")\n"); + ofs += 2; + break; + } + case OP_GET: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("GET %d (", idx); + print(co->constants.data[idx]); + printf(")\n"); + ofs += 2; + break; + } + case OP_SET: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("SET %d (", idx); + print(co->constants.data[idx]); + printf(")\n"); + ofs += 2; + break; + } + case OP_CALL: { + U8 argc = co->code[ofs + 1]; + printf("CALL %d\n", argc); + ofs += 1; + break; + } + case OP_TAIL_CALL: { + U8 argc = co->code[ofs + 1]; + printf("TAIL_CALL %d\n", argc); + ofs += 1; + break; + } + case OP_JUMP: { + U16 o = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("JUMP %04x\n", o); + ofs += 2; + break; + } + case OP_JUMP_IF_NIL: { + U16 o = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("JUMP_IF_NIL %04x\n", o); + ofs += 2; + break; + } + case OP_RET: + printf("RET\n"); + break; + case OP_POP: + printf("POP\n"); + break; + case OP_CLOS: { + U16 b = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + U16 a = (co->code[ofs + 3] << 8) | co->code[ofs + 4]; + printf("CLOS %04x %04x\n", b, a); + ofs += 4; + break; + } + case OP_BIND: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("BIND %d\n", idx); + ofs += 2; + break; + } + case OP_BIND_REST: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + U16 cnt = (co->code[ofs + 3] << 8) | co->code[ofs + 4]; + printf("BIND_REST %d %d\n", idx, cnt); + ofs += 4; + break; + } + case OP_PEEK: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("PEEK %d\n", idx); + ofs += 2; + break; + } + case OP_GET_LOCAL: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("GET_LOCAL %d\n", idx); + ofs += 2; + break; + } + case OP_SET_LOCAL: { + U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("SET_LOCAL %d\n", idx); + ofs += 2; + break; + } + case OP_RESERVE: { + U16 cnt = (co->code[ofs + 1] << 8) | co->code[ofs + 2]; + printf("RESERVE %d\n", cnt); + ofs += 2; + break; + } + default: + printf("%02x\n", co->code[ofs]); + } + } +} diff --git a/src/error.c b/src/error.c index 9ab07b4..02c0f83 100644 --- a/src/error.c +++ b/src/error.c @@ -6,53 +6,23 @@ void error_init(Er *err) { err->active = 0; err->message[0] = '\0'; - err->stack.count = 0; } void error_throw(In *in, const char *fmt, ...) { if (!in->err.active) { - // No error handler active, fall back to abort - fprintf(stderr, "fatal error: "); + fprintf(stderr, "error: "); va_list args; va_start(args, fmt); vfprintf(stderr, fmt, args); va_end(args); fprintf(stderr, "\n"); - abort(); + exit(1); } - - // Format error message va_list args; va_start(args, fmt); vsnprintf(in->err.message, 512, fmt, args); va_end(args); - - // Jump back to error handler longjmp(in->err.handler, 1); } -void error_push_frame(In *in, const char *frame) { - if (in->err.stack.count < 32) { - in->err.stack.frames[in->err.stack.count++] = frame; - } -} - -void error_pop_frame(In *in) { - if (in->err.stack.count > 0) { - in->err.stack.count--; - } -} - -void error_print(In *in) { - fprintf(stderr, "error: %s\n", in->err.message); - - if (in->err.stack.count > 0) { - fprintf(stderr, "stack trace:\n"); - for (int i = in->err.stack.count - 1; i >= 0; i--) { - fprintf(stderr, " %s\n", in->err.stack.frames[i]); - } - } - - // Reset stack for next error - in->err.stack.count = 0; -} +void error_print(In *in) { fprintf(stderr, "error: %s\n", in->err.message); } diff --git a/src/gc.c b/src/gc.c index 57ea4d4..ff67f03 100644 --- a/src/gc.c +++ b/src/gc.c @@ -91,6 +91,11 @@ V gc_collect(Gc *gc) { // Scan to-space for objects to forward (breadth-first iteration) while (scan < gc->to.free) { + if (scan >= gc->to.end) { + fprintf(stderr, "fatal GC error: out of memory\n"); + abort(); + } + Gh *hdr = (Gh *)scan; switch (hdr->type) { case TYPE_PAIR: { @@ -107,8 +112,18 @@ V gc_collect(Gc *gc) { obj->env = forward(gc, obj->env); break; } - case TYPE_STR: + case TYPE_CODE: { + Bc *obj = (Bc *)(hdr + 1); + for (Z i = 0; i < obj->constant_count; i++) { + obj->constants[i] = forward(gc, obj->constants[i]); + } break; + } + case TYPE_STR: { + Ss *obj = (Ss *)(hdr + 1); + obj->data = (char *)(obj + 1); + break; + } case TYPE_FWD: fprintf(stderr, "fatal GC error: forwarding pointer in to-space\n"); abort(); diff --git a/src/interp.c b/src/interp.c index f84d6b5..dbac969 100644 --- a/src/interp.c +++ b/src/interp.c @@ -11,34 +11,34 @@ V interp_init(In *in) { in->t = symbol_make(in, "t"); in->env = NIL; + // Initialize and root the VM stack + for (int i = 0; i < VM_STACK_SIZE; i++) { + in->stack[i] = NIL; + gc_addroot(&in->gc, &in->stack[i]); + } + in->sp = in->stack; + // Add T symbol in->env = pair_make(in, pair_make(in, in->t, in->t), in->env); -#define PRIM(name, prim) \ - in->env = pair_make(in, prim_make(in, name, prim), in->env) +#define PRIM(name, prim, min, max) \ + in->env = pair_make(in, prim_make(in, name, prim, min, max), in->env) - PRIM("progn", prim_progn); - PRIM("def", prim_def); - PRIM("defn", prim_defn); - PRIM("cons", prim_cons); - PRIM("head", prim_head); - PRIM("tail", prim_tail); - PRIM("list", prim_list); - PRIM("quote", prim_quote); - PRIM("print", prim_print); - PRIM("println", prim_println); - PRIM("if", prim_if); - PRIM("+", prim_add); - PRIM("-", prim_sub); - PRIM("*", prim_mul); - PRIM("/", prim_div); - PRIM("<", prim_lt); - PRIM(">", prim_gt); - - PRIM("=", prim_equal); - PRIM("fn", prim_fn); - PRIM("mac", prim_mac); - PRIM("gc", prim_gc); + PRIM("cons", prim_cons, 2, 2); + PRIM("head", prim_head, 1, 1); + PRIM("tail", prim_tail, 1, 1); + PRIM("list", prim_list, 0, -1); // variadic + PRIM("print", prim_print, 1, 1); + PRIM("println", prim_println, 1, 1); + PRIM("write", prim_write, 1, 1); + PRIM("+", prim_add, 0, -1); // variadic + PRIM("-", prim_sub, 0, -1); // variadic + PRIM("*", prim_mul, 0, -1); // variadic + PRIM("/", prim_div, 0, -1); // variadic + PRIM("<", prim_lt, 2, 2); + PRIM(">", prim_gt, 2, 2); + PRIM("=", prim_equal, 0, -1); // variadic + PRIM("gc", prim_gc, 0, 0); #undef PRIM } @@ -46,157 +46,3 @@ V interp_finalize(In *in) { free(in->symtab.data); gc_finalize(&in->gc); } - -static O bind(In *in, O params, O args, O env) { - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, ¶ms); - gc_addroot(&in->gc, &args); - gc_addroot(&in->gc, &env); - - O res = env; - gc_addroot(&in->gc, &res); - - while (params != NIL) { - if (type(params) == TYPE_SYM) { - O pair = pair_make(in, params, args); - gc_addroot(&in->gc, &pair); - res = pair_make(in, pair, res); - break; - } - - if (type(params) != TYPE_PAIR) { - error_throw(in, "expected proper list or symbol for parameters"); - } - - Pa *p = pair_unwrap(in, params); - O sym = p->head; - - O val = NIL; - if (args != NIL) { - if (type(args) != TYPE_PAIR) { - error_throw(in, "too many parameters for arguments"); - } - Pa *a = pair_unwrap(in, args); - val = a->head; - args = a->tail; - } - - O pair = pair_make(in, sym, val); - gc_addroot(&in->gc, &pair); - res = pair_make(in, pair, res); - - params = p->tail; - } - - gc_rootreset(&in->gc, mark); - return res; -} - -static O eval(In *in, O obj, O env); - -static O eval_list(In *in, O list, O env) { - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, &list); - gc_addroot(&in->gc, &env); - - O head = NIL; - O curr = list; - - gc_addroot(&in->gc, &head); - gc_addroot(&in->gc, &curr); - - while (curr != NIL) { - Pa *p = pair_unwrap(in, curr); - O obj = eval(in, p->head, env); - head = pair_make(in, obj, head); - curr = p->tail; - } - - O result = list_reverse(in, head); - gc_rootreset(&in->gc, mark); - return result; -} - -static O apply(In *in, O fn, O args, O env) { - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, &fn); - gc_addroot(&in->gc, &args); - gc_addroot(&in->gc, &env); - - I ty = type(fn); - switch (ty) { - case TYPE_PRIM: { - Pr *pr = (Pr *)UNTAG(fn); - O res = pr->fn(in, args, env); - gc_rootreset(&in->gc, mark); - return res; - } - case TYPE_CLOS: { - args = eval_list(in, args, env); - Gh *hdr = UNBOX(fn); - Cl *cl = (Cl *)(hdr + 1); - O nenv = bind(in, cl->args, args, cl->env); - // `bind' may have moved the closure if a GC was triggered - cl = (Cl *)(UNBOX(fn) + 1); - O res = eval(in, cl->body, nenv); - gc_rootreset(&in->gc, mark); - return res; - } - case TYPE_MAC: { - Gh *hdr = UNBOX(fn); - Cl *cl = (Cl *)(hdr + 1); - O nenv = bind(in, cl->args, args, cl->env); - cl = (Cl *)(UNBOX(fn) + 1); - O exp = eval(in, cl->body, nenv); - gc_addroot(&in->gc, &exp); - O res = eval(in, exp, env); - gc_rootreset(&in->gc, mark); - return res; - } - default: - error_throw(in, "tried to call non-function value"); - return NIL; - } -} - -static O eval(In *in, O obj, O env) { - I ty = type(obj); - - if (ty == TYPE_SYM) { - O pair = list_assoc(in, obj, env); - if (pair == NIL) { - pair = list_assoc(in, obj, in->env); - } - if (pair == NIL) { - Sy *s = (Sy *)UNTAG(obj); - error_throw(in, "undefined symbol '%.*s'", (int)s->len, s->data); - } - return pair_unwrap(in, pair)->tail; - } else if (ty != TYPE_PAIR) { - return obj; - } - - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, &obj); - gc_addroot(&in->gc, &env); - - Pa *c = pair_unwrap(in, obj); - O fn = eval(in, c->head, env); - gc_addroot(&in->gc, &fn); - - O res = apply(in, fn, c->tail, env); - gc_rootreset(&in->gc, mark); - return res; -} - -O interp_eval_list(In *in, O list, O env) { - if (env == NIL) - env = in->env; - return eval_list(in, list, env); -} - -O interp_eval(In *in, O obj, O env) { - if (env == NIL) - env = in->env; - return eval(in, obj, env); -} diff --git a/src/list.c b/src/list.c index d3fb118..0fe2bfe 100644 --- a/src/list.c +++ b/src/list.c @@ -35,3 +35,11 @@ O list_reverse(In *in, O list) { return prev; } + +O list_next(In *in, O *list) { + if (*list == NIL) + return NIL; + O arg = pair_unwrap(in, *list)->head; + *list = pair_unwrap(in, *list)->tail; + return arg; +} diff --git a/src/main.c b/src/main.c index 0b26179..dbe3868 100644 --- a/src/main.c +++ b/src/main.c @@ -1,32 +1,87 @@ #include +#include +#include #include // TODO: here til I figure out a better interface for this int read_expr(In *in, Lx *lex, O *result); -int main(void) { - In interp; - interp_init(&interp); - +void repl(void) { + In in; + interp_init(&in); Lx lex = {0, 0, stdin, {0}}; + printf("λ> "); nexttoken(&lex); - + O result = NIL; + I mark = gc_rootmark(&in.gc); + gc_addroot(&in.gc, &result); while (lex.kind != TOK_EOF) { O expr = NIL; - I mark = gc_rootmark(&interp.gc); - gc_addroot(&interp.gc, &expr); - if (read_expr(&interp, &lex, &expr) == -1) + Cm compiler; + memset(&compiler, 0, sizeof(Cm)); + compiler.in = ∈ + + if (read_expr(&in, &lex, &expr) == -1) break; - if (setjmp(interp.err.handler) == 0) { - interp.err.active = 1; - (void)interp_eval(&interp, expr, NIL); + if (setjmp(in.err.handler) == 0) { + in.err.active = 1; + compile(&compiler, expr, 1); + disassemble(&compiler); + result = vm_run(&compiler); + println(result); } else { - error_print(&interp); + error_print(&in); + exit(1); } - gc_rootreset(&interp.gc, mark); - gc_collect(&interp.gc); + printf("λ> "); nexttoken(&lex); } - interp_finalize(&interp); + gc_rootreset(&in.gc, mark); + gc_collect(&in.gc); + + interp_finalize(&in); +} + +void load(char *fname) { + In in; + interp_init(&in); + + FILE *fp = fopen(fname, "r"); + if (!fp) { + perror("fopen"); + exit(1); + } + Lx lex = {0, 0, fp, {0}}; + + nexttoken(&lex); + O result = NIL; + I mark = gc_rootmark(&in.gc); + gc_addroot(&in.gc, &result); + while (lex.kind != TOK_EOF) { + O expr = NIL; + Cm compiler; + memset(&compiler, 0, sizeof(Cm)); + compiler.in = ∈ + if (read_expr(&in, &lex, &expr) == -1) + break; + in.err.active = 0; + compile(&compiler, expr, 1); + result = vm_run(&compiler); + nexttoken(&lex); + } + + gc_rootreset(&in.gc, mark); + gc_collect(&in.gc); + + interp_finalize(&in); + fclose(fp); +} + +int main(int argc, char *argv[]) { + if (argc == 1) { + repl(); + } else { + load(argv[1]); + } } diff --git a/src/pair.c b/src/pair.c index 147a071..ffab7bf 100644 --- a/src/pair.c +++ b/src/pair.c @@ -1,5 +1,3 @@ -#include "stdlib.h" -#include #include O pair_make(In *in, O head, O tail) { diff --git a/src/prim.c b/src/prim.c index 87f2645..1e08534 100644 --- a/src/prim.c +++ b/src/prim.c @@ -2,317 +2,176 @@ #include #include -static O nextarg(In *in, O *list) { - if (*list == NIL) - return NIL; - O arg = pair_unwrap(in, *list)->head; - *list = pair_unwrap(in, *list)->tail; - return arg; -} +#define BOOL(x) ((x) ? in->t : NIL) -static O bool(In *in, I i) { - if (i) - return in->t; - else - return NIL; -} - -O prim_make(In *in, const char *name, O (*fn)(In *, O, O)) { +O prim_make(In *in, const char *name, O (*fn)(In *, O *, int, O), int min_args, + int max_args) { Pr *pr = malloc(sizeof(Pr)); pr->name = name; pr->fn = fn; + pr->min_args = min_args; + pr->max_args = max_args; O sym = BOX(TAG(intern(&in->symtab, name, 0), TAG_SYM)); O prim = BOX(TAG(pr, TAG_PRIM)); return pair_make(in, sym, prim); } -O prim_cons(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - O head = nextarg(in, &args); - O tail = nextarg(in, &args); - return pair_make(in, head, tail); -} - -O prim_list(In *in, O args, O env) { return interp_eval_list(in, args, env); } - -O prim_head(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - return pair_unwrap(in, nextarg(in, &args))->head; -} - -O prim_tail(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - return pair_unwrap(in, nextarg(in, &args))->tail; -} - -O prim_print(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - print(nextarg(in, &args)); - return NIL; -} - -O prim_println(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - O arg = nextarg(in, &args); - println(arg); - return NIL; -} - -O prim_quote(In *in, O args, O env) { - (void)in; +O prim_cons(In *in, O *args, int argc, O env) { (void)env; - return nextarg(in, &args); + if (argc != 2) + error_throw(in, "cons: expected 2 arguments, got %d", argc); + return pair_make(in, args[0], args[1]); } -O prim_if(In *in, O args, O env) { - O cond_expr = nextarg(in, &args); - O then_expr = nextarg(in, &args); - O else_expr = nextarg(in, &args); - - if (cond_expr == NIL || then_expr == NIL) { - fprintf(stderr, "if: expected at least 2 arguments\n"); - abort(); - } - - if (interp_eval(in, cond_expr, env) != NIL) { - return interp_eval(in, then_expr, env); - } else { - return interp_eval(in, else_expr, env); - } -} - -O prim_progn(In *in, O args, O env) { +O prim_list(In *in, O *args, int argc, O env) { + (void)env; O result = NIL; - for (O expr = nextarg(in, &args); expr != NIL; expr = nextarg(in, &args)) - result = interp_eval(in, expr, env); + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, &result); + for (int i = argc - 1; i >= 0; i--) { + result = pair_make(in, args[i], result); + } + gc_rootreset(&in->gc, mark); return result; } -O prim_add(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - I result = nextarg(in, &args); - if (result == NIL) { +O prim_head(In *in, O *args, int argc, O env) { + (void)env; + if (argc != 1) + error_throw(in, "head: expected 1 argument, got %d", argc); + return pair_unwrap(in, args[0])->head; +} + +O prim_tail(In *in, O *args, int argc, O env) { + (void)env; + if (argc != 1) + error_throw(in, "tail: expected 1 argument, got %d", argc); + return pair_unwrap(in, args[0])->tail; +} + +O prim_print(In *in, O *args, int argc, O env) { + (void)env; + if (argc != 1) + error_throw(in, "print: expected 1 argument, got %d", argc); + print(args[0]); + return NIL; +} + +O prim_println(In *in, O *args, int argc, O env) { + (void)env; + if (argc != 1) + error_throw(in, "println: expected 1 argument, got %d", argc); + println(args[0]); + return NIL; +} + +O prim_write(In *in, O *args, int argc, O env) { + (void)env; + if (argc != 1) + error_throw(in, "write: expected 1 argument, got %d", argc); + if (type(args[0]) != TYPE_STR) + error_throw(in, "write: expected string argument, got %s", typename(type(args[0]))); + Ss *s = (Ss *)(UNBOX(args[0]) + 1); + printf("%.*s", (int)s->len, s->data); + return NIL; +} + +O prim_add(In *in, O *args, int argc, O env) { + (void)env; + I result = 0; + for (int i = 0; i < argc; i++) { + if (!IMM(args[i])) + error_throw(in, "+: non numeric argument at position %d", i); + result += ORD(args[i]); + } + return NUM(result); +} + +O prim_sub(In *in, O *args, int argc, O env) { + (void)env; + if (argc == 0) return NUM(0); - } else { - result = ORD(result); - } - for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) { - if (!IMM(arg)) { - error_throw(in, "+: non numeric argument"); - } - result += ORD(arg); + if (!IMM(args[0])) + error_throw(in, "-: non numeric argument at position 0"); + I result = ORD(args[0]); + if (argc == 1) + return NUM(-result); + for (int i = 1; i < argc; i++) { + if (!IMM(args[i])) + error_throw(in, "-: non numeric argument at position %d", i); + result -= ORD(args[i]); } return NUM(result); } -O prim_sub(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - I result = nextarg(in, &args); - if (result == NIL) { - return NUM(0); - } else { - result = ORD(result); - } - for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) { - if (!IMM(arg)) { - error_throw(in, "-: non numeric argument"); - } - result -= ORD(arg); +O prim_mul(In *in, O *args, int argc, O env) { + (void)env; + I result = 1; + for (int i = 0; i < argc; i++) { + if (!IMM(args[i])) + error_throw(in, "*: non numeric argument at position %d", i); + result *= ORD(args[i]); } return NUM(result); } -O prim_mul(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - I result = nextarg(in, &args); - if (result == NIL) { +O prim_div(In *in, O *args, int argc, O env) { + (void)env; + if (argc == 0) return NUM(1); - } else { - result = ORD(result); - } - for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) { - if (!IMM(arg)) { - error_throw(in, "*: non numeric argument"); - } - result *= ORD(arg); + if (!IMM(args[0])) + error_throw(in, "/: non numeric argument at position 0"); + I result = ORD(args[0]); + for (int i = 1; i < argc; i++) { + if (!IMM(args[i])) + error_throw(in, "/: non numeric argument at position %d", i); + if (ORD(args[i]) == 0) + error_throw(in, "/: division by zero at position %d", i); + result /= ORD(args[i]); } return NUM(result); } -O prim_div(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - I result = nextarg(in, &args); - if (result == NIL) { - return NUM(1); - } else { - result = ORD(result); - } - for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) { - if (!IMM(arg)) { - error_throw(in, "/: non numeric argument"); - } - if (ORD(arg) == 0) { - error_throw(in, "/: division by zero"); - } - result /= ORD(arg); - } - return NUM(result); -} - -O prim_equal(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - I result = NIL; - - O fst = nextarg(in, &args); - for (O next = nextarg(in, &args); next != NIL; next = nextarg(in, &args)) { - if (fst == next) { - result = in->t; - } else { +O prim_equal(In *in, O *args, int argc, O env) { + (void)env; + if (argc < 2) + return in->t; + O first = args[0]; + for (int i = 1; i < argc; i++) { + if (first != args[i]) return NIL; - } - fst = next; } - return result; + return in->t; } -O prim_lt(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - O fst = nextarg(in, &args); - O snd = nextarg(in, &args); - if (IMM(fst) && IMM(snd)) { - return bool(in, ORD(fst) < ORD(snd)); +O prim_lt(In *in, O *args, int argc, O env) { + (void)env; + if (argc != 2) + error_throw(in, "<: expected 2 arguments, got %d", argc); + if (IMM(args[0]) && IMM(args[1])) { + return BOOL(ORD(args[0]) < ORD(args[1])); } else { error_throw(in, "<: expected numeric arguments"); return NIL; - }; + } } -O prim_gt(In *in, O args, O env) { - args = interp_eval_list(in, args, env); - O fst = nextarg(in, &args); - O snd = nextarg(in, &args); - if (IMM(fst) && IMM(snd)) { - return bool(in, ORD(fst) > ORD(snd)); +O prim_gt(In *in, O *args, int argc, O env) { + (void)env; + if (argc != 2) + error_throw(in, ">: expected 2 arguments, got %d", argc); + if (IMM(args[0]) && IMM(args[1])) { + return BOOL(ORD(args[0]) > ORD(args[1])); } else { error_throw(in, ">: expected numeric arguments"); return NIL; - }; + } } -O prim_fn(In *in, O args, O env) { - O params = nextarg(in, &args); - O body = args; - - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, ¶ms); - gc_addroot(&in->gc, &env); - gc_addroot(&in->gc, &body); - - O progn = symbol_make(in, "progn"); - O body_form = pair_make(in, progn, body); - gc_addroot(&in->gc, &body_form); - - Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl)); - hdr->type = TYPE_CLOS; - Cl *cl = (Cl *)(hdr + 1); - cl->args = params; - cl->env = env; - cl->body = body_form; - - gc_rootreset(&in->gc, mark); - return BOX(hdr); -} - -O prim_mac(In *in, O args, O env) { - O params = nextarg(in, &args); - O body = args; - - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, ¶ms); - gc_addroot(&in->gc, &env); - gc_addroot(&in->gc, &body); - - O progn = symbol_make(in, "progn"); - O body_form = pair_make(in, progn, body); - gc_addroot(&in->gc, &body_form); - - Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl)); - hdr->type = TYPE_MAC; - Cl *cl = (Cl *)(hdr + 1); - cl->args = params; - cl->env = env; - cl->body = body_form; - - gc_rootreset(&in->gc, mark); - return BOX(hdr); -} - -O prim_gc(In *in, O args, O env) { - (void)in; +O prim_gc(In *in, O *args, int argc, O env) { (void)args; + (void)argc; (void)env; gc_collect(&in->gc); return NIL; } - -O prim_def(In *in, O args, O env) { - O sym = nextarg(in, &args); - O val_expr = nextarg(in, &args); - - if (type(sym) != TYPE_SYM) { - error_throw(in, "def: expected symbol"); - } - - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, &sym); - gc_addroot(&in->gc, &env); - - O val = interp_eval(in, val_expr, env); - gc_addroot(&in->gc, &val); - - O pair = pair_make(in, sym, val); - gc_addroot(&in->gc, &pair); - - in->env = pair_make(in, pair, in->env); - - gc_rootreset(&in->gc, mark); - return sym; -} - -O prim_defn(In *in, O args, O env) { - O sym = nextarg(in, &args); - O params = nextarg(in, &args); - O body = args; - - if (type(sym) != TYPE_SYM) { - error_throw(in, "defn: expected symbol"); - } - - I mark = gc_rootmark(&in->gc); - gc_addroot(&in->gc, &sym); - gc_addroot(&in->gc, ¶ms); - gc_addroot(&in->gc, &body); - gc_addroot(&in->gc, &env); - - O progn = symbol_make(in, "progn"); - O body_form = pair_make(in, progn, body); - gc_addroot(&in->gc, &body_form); - - Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl)); - hdr->type = TYPE_CLOS; - Cl *cl = (Cl *)(hdr + 1); - cl->args = params; - cl->env = env; - cl->body = body_form; - - O fn = BOX(hdr); - gc_addroot(&in->gc, &fn); - - O pair = pair_make(in, sym, fn); - gc_addroot(&in->gc, &pair); - - in->env = pair_make(in, pair, in->env); - - gc_rootreset(&in->gc, mark); - return sym; -} diff --git a/src/prim.h b/src/prim.h index a270f92..1bde768 100644 --- a/src/prim.h +++ b/src/prim.h @@ -1,23 +1,17 @@ #include -O prim_progn(In *in, O args, O env); -O prim_cons(In *in, O args, O env); -O prim_head(In *in, O args, O env); -O prim_tail(In *in, O args, O env); -O prim_list(In *in, O args, O env); -O prim_quote(In *in, O args, O env); -O prim_print(In *in, O args, O env); -O prim_println(In *in, O args, O env); -O prim_if(In *in, O args, O env); -O prim_add(In *in, O args, O env); -O prim_sub(In *in, O args, O env); -O prim_mul(In *in, O args, O env); -O prim_div(In *in, O args, O env); -O prim_equal(In *in, O args, O env); -O prim_lt(In *in, O args, O env); -O prim_gt(In *in, O args, O env); -O prim_fn(In *in, O args, O env); -O prim_mac(In *in, O args, O env); -O prim_gc(In *in, O args, O env); -O prim_def(In *in, O args, O env); -O prim_defn(In *in, O args, O env); +O prim_cons(In *in, O *args, int argc, O env); +O prim_head(In *in, O *args, int argc, O env); +O prim_tail(In *in, O *args, int argc, O env); +O prim_list(In *in, O *args, int argc, O env); +O prim_print(In *in, O *args, int argc, O env); +O prim_println(In *in, O *args, int argc, O env); +O prim_write(In *in, O *args, int argc, O env); +O prim_add(In *in, O *args, int argc, O env); +O prim_sub(In *in, O *args, int argc, O env); +O prim_mul(In *in, O *args, int argc, O env); +O prim_div(In *in, O *args, int argc, O env); +O prim_equal(In *in, O *args, int argc, O env); +O prim_lt(In *in, O *args, int argc, O env); +O prim_gt(In *in, O *args, int argc, O env); +O prim_gc(In *in, O *args, int argc, O env); diff --git a/src/print.c b/src/print.c index 8b8ce53..3481f34 100644 --- a/src/print.c +++ b/src/print.c @@ -46,7 +46,7 @@ void print(O obj) { } case TAG_PRIM: { Pr *p = (Pr *)UNTAG(obj); - printf("<#primitive %s>", p->name); + printf("<#primitive \"%s\">", p->name); break; } default: { @@ -57,18 +57,11 @@ void print(O obj) { break; case TYPE_STR: { Ss *s = (Ss *)(h + 1); - printf("%.*s", (int)s->len, s->data); - break; - } - case TYPE_CLOS: { - Cl *cl = (Cl *)(h + 1); - printf("<#fn "); - print(cl->args); - printf(">"); + printf("\"%.*s\"", (int)s->len, s->data); break; } default: - printf("<#obj type=%" PRId32 " @ %p>", h->type, (void *)h); + printf("<#%s %p>", typename(h->type), (void *)h); break; } } diff --git a/src/type.c b/src/type.c index 7d9ada6..167a88f 100644 --- a/src/type.c +++ b/src/type.c @@ -13,6 +13,7 @@ static const char *typenames[] = { [TYPE_STR] = "string", [TYPE_CLOS] = "closure", [TYPE_MAC] = "macro", + [TYPE_CODE] = "bytecode", }; // clang-format on @@ -40,6 +41,6 @@ I type(O obj) { const char *typename(I t) { if (t >= TYPE__MAX) - return "??"; + return "?"; return typenames[t]; } diff --git a/src/vm.c b/src/vm.c new file mode 100644 index 0000000..b8e4abf --- /dev/null +++ b/src/vm.c @@ -0,0 +1,227 @@ +#include + +#define PUSH(x) (*in->sp++ = (x)) +#define POP() (*--in->sp) +#define PEEK() (*(in->sp - 1)) +#define READ16() (ip += 2, (U16)((ip[-2] << 8) | ip[-1])) + +static O vm_exec(Cm *co_in, O env_in, int argc_in) { + Cm co_struct = *co_in; + Cm *co = &co_struct; + O env = env_in; + In *in = co->in; + int argc = argc_in; + O *fp = in->sp - argc; + + I env_mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, &env); + + U8 *ip = co->code; + U8 *end = co->code + co->count; + + while (ip < end) { + U8 op = *ip++; + switch (op) { + case OP_HALT: + gc_rootreset(&in->gc, env_mark); + return NIL; + case OP_CONST: { + U16 idx = READ16(); + PUSH(co->constants.data[idx]); + break; + } + case OP_GET: { + U16 idx = READ16(); + O sym = co->constants.data[idx]; + O pair = list_assoc(in, sym, env); + if (pair == NIL) + pair = list_assoc(in, sym, in->env); + if (pair == NIL) { + Sy *s = (Sy *)UNTAG(sym); + error_throw(in, "undefined symbol '%.*s'", (int)s->len, s->data); + } + PUSH(pair_unwrap(in, pair)->tail); + break; + } + case OP_SET: { + U16 idx = READ16(); + O sym = co->constants.data[idx]; + O val = POP(); + O binding = pair_make(in, sym, val); + in->env = pair_make(in, binding, in->env); + break; + } + case OP_JUMP: { + U16 offset = READ16(); + ip = co->code + offset; + break; + } + case OP_JUMP_IF_NIL: { + U16 offset = READ16(); + O val = POP(); + if (val == NIL) { + ip = co->code + offset; + } + break; + } + case OP_CALL: { + U8 next_argc = *ip++; + O func = POP(); + O res = NIL; + I ty = type(func); + if (ty == TYPE_PRIM) { + Pr *pr = (Pr *)UNTAG(func); + if (pr->min_args >= 0 && next_argc < pr->min_args) { + error_throw(in, "%s: expected at least %d arguments, got %d", + pr->name, pr->min_args, next_argc); + } + if (pr->max_args >= 0 && next_argc > pr->max_args) { + error_throw(in, "%s: expected at most %d arguments, got %d", pr->name, + pr->max_args, next_argc); + } + O *args = in->sp - next_argc; + res = pr->fn(in, args, next_argc, in->env); + in->sp -= next_argc; + } else if (ty == TYPE_CLOS) { + Gh *hdr = UNBOX(func); + Cl *cl = (Cl *)(hdr + 1); + O nenv = cl->env; + O body = cl->body; + Bc *bc = (Bc *)(UNBOX(body) + 1); + // clang-format off + Cm co2 = { + .in = in, + .code = bc->data, + .count = bc->len, + .constants = { + .data = bc->constants, + .count = bc->constant_count, + .capacity = bc->constant_count + } + }; + // clang-format on + res = vm_exec(&co2, nenv, next_argc); + } else { + error_throw(in, "call to non-function object"); + } + PUSH(res); + break; + } + case OP_TAIL_CALL: { + U8 next_argc = *ip++; + O func = POP(); + I ty = type(func); + if (ty == TYPE_PRIM) { + Pr *pr = (Pr *)UNTAG(func); + if (pr->min_args >= 0 && next_argc < pr->min_args) { + error_throw(in, "%s: expected at least %d arguments, got %d", + pr->name, pr->min_args, next_argc); + } + if (pr->max_args >= 0 && next_argc > pr->max_args) { + error_throw(in, "%s: expected at most %d arguments, got %d", pr->name, + pr->max_args, next_argc); + } + O *args = in->sp - next_argc; + O res = pr->fn(in, args, next_argc, env); + in->sp -= argc + next_argc; + return res; + } else if (ty == TYPE_CLOS) { + Gh *hdr = UNBOX(func); + Cl *cl = (Cl *)(hdr + 1); + env = cl->env; + Bc *bc = (Bc *)(UNBOX(cl->body) + 1); + co->code = ip = bc->data; + co->count = bc->len; + end = ip + bc->len; + co->constants.data = bc->constants; + co->constants.count = bc->constant_count; + O *new_args = in->sp - next_argc; + for (int i = 0; i < next_argc; i++) + fp[i] = new_args[i]; + in->sp = fp + next_argc; + argc = next_argc; + } else { + error_throw(in, "call to non-function object"); + } + break; + } + case OP_BIND: { + U16 idx = READ16(); + O sym = co->constants.data[idx]; + O val = POP(); + O binding = pair_make(in, sym, val); + env = pair_make(in, binding, env); + argc--; + break; + } + case OP_BIND_REST: { + U16 idx = READ16(); + U16 fixed_cnt = READ16(); + O sym = co->constants.data[idx]; + O list = NIL; + I mark = gc_rootmark(&in->gc); + gc_addroot(&in->gc, &list); + while (argc > fixed_cnt) { + list = pair_make(in, POP(), list); + argc--; + } + gc_rootreset(&in->gc, mark); + O binding = pair_make(in, sym, list); + env = pair_make(in, binding, env); + break; + } + case OP_PEEK: { + U16 idx = READ16(); + O val = fp[argc - 1 - idx]; + PUSH(val); + break; + } + case OP_GET_LOCAL: { + U16 idx = READ16(); + O val = fp[idx]; + PUSH(val); + break; + } + case OP_SET_LOCAL: { + U16 idx = READ16(); + O val = PEEK(); + fp[idx] = val; + break; + } + case OP_RESERVE: { + U16 count = READ16(); + for (U16 i = 0; i < count; i++) { + PUSH(NIL); + } + break; + } + case OP_RET: { + O ret = POP(); + in->sp -= argc; + gc_rootreset(&in->gc, env_mark); + return ret; + } + case OP_POP: + (void)POP(); + break; + case OP_CLOS: { + U16 code_idx = READ16(); + U16 args_idx = READ16(); + Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl)); + hdr->type = TYPE_CLOS; + Cl *cl = (Cl *)(hdr + 1); + cl->args = co->constants.data[args_idx]; + cl->body = co->constants.data[code_idx]; + cl->env = env; + PUSH(BOX(hdr)); + break; + } + default: + error_throw(in, "unknown opcode %d", op); + } + } + gc_rootreset(&in->gc, env_mark); + return NIL; +} + +O vm_run(Cm *co) { return vm_exec(co, co->in->env, 0); } diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..c96758e --- /dev/null +++ b/test.lisp @@ -0,0 +1,17 @@ +(def fib-iter (fn (n a b) + (if (= n 0) + a + (fib-iter (- n 1) b (+ a b))))) +(def fib (fn (n) (fib-iter n 0 1))) + +(write "(fib 50) = ") +(println (fib 50)) + +(def sum + (fn (n acc) + (if (= n 0) + acc + (sum (- n 1) (+ n acc))))) + +(write "(sum 1000000) = ") +(println (sum 1000000 0))