diff --git a/shell.nix b/shell.nix index a903be6..6857959 100644 --- a/shell.nix +++ b/shell.nix @@ -1,8 +1,18 @@ -{ pkgs ? import {} }: +{ + pkgs ? import { }, +}: pkgs.mkShell { buildInputs = with pkgs; [ - clang-tools bear gdb tinycc - meson ninja rlwrap hyperfine + clang-tools + bear + gdb + tinycc + meson + ninja + rlwrap + hyperfine + muon + samurai ]; } diff --git a/src/compile.c b/src/compile.c index a01cba3..2995d45 100644 --- a/src/compile.c +++ b/src/compile.c @@ -20,6 +20,10 @@ struct { {"dup", OP_DUP}, {"drop", OP_DROP}, {"swap", OP_SWAP}, + {"over", OP_OVER}, + {"nip", OP_NIP}, + {"bury", OP_BURY}, + {"dig", OP_DIG}, {">r", OP_TOR}, {"r>", OP_FROMR}, {"call", OP_APPLY}, @@ -48,6 +52,62 @@ V compiler_init(Cm *cm, Vm *vm, const char *name) { V compiler_deinit(Cm *cm) { cm->dictionary = NULL; } +static I peek_sleb128(U8 *ptr, I *out_value) { + I result = 0; + I shift = 0; + U8 byte; + I bytes = 0; + + do { + byte = ptr[bytes]; + bytes++; + result |= (I)(byte & 0x7F) << shift; + shift += 7; + } while (byte & 0x80); + + if ((shift < 64) && (byte & 0x40)) { + result |= -(1LL << shift); + } + + if (out_value) + *out_value = result; + return bytes; +} + +static V optim_tailcall(Bc *chunk) { + Z i = 0; + while (i < chunk->count) { + U8 opcode = chunk->items[i]; + if (opcode == OP_CALL) { + I ofs = peek_sleb128(&chunk->items[i + 1], NULL); + Z next = i + 1 + ofs; + if (next < chunk->count && chunk->items[next] == OP_RETURN) { + chunk->items[i] = OP_TAIL_CALL; + } + i++; + } else if (opcode == OP_DOWORD) { + I ofs = peek_sleb128(&chunk->items[i + 1], NULL); + Z next = i + 1 + ofs; + if (next < chunk->count && chunk->items[next] == OP_RETURN) { + chunk->items[i] = OP_TAIL_DOWORD; + } + i++; + } else if (opcode == OP_APPLY) { + Z ofs = i + 1; + if (ofs < chunk->count && chunk->items[ofs] == OP_RETURN) { + chunk->items[i] = OP_TAIL_APPLY; + } + i++; + } else if (opcode == OP_CONST || opcode == OP_JUMP || + opcode == OP_JUMP_IF_NIL) { + I ofs = peek_sleb128(&chunk->items[i + 1], NULL); + i += 1 + ofs; + } else { + i++; + } + } +} + static I compile_expr(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next); static I compile_ast(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next); @@ -110,8 +170,7 @@ static I compile_definition(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) { while (curr != NULL) { if (strcmp(curr->tag, "char") == 0 && strcmp(curr->contents, "}") == 0) break; - I res = compile_expr(&inner, curr, next); - if (!res) { + if (!compile_expr(&inner, curr, next)) { chunk_release(inner.chunk); return 0; } @@ -119,8 +178,13 @@ static I compile_definition(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) { } chunk_emit_byte(inner.chunk, OP_RETURN); + optim_tailcall(inner.chunk); + entry->chunk = inner.chunk; - // disassemble(inner.chunk, name, cm->dictionary); + +#if COMPILER_DEBUG + disassemble(inner.chunk, name, cm->dictionary); +#endif return 1; } @@ -145,6 +209,7 @@ static O compile_quotation_obj(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) { curr = mpc_ast_traverse_next(next); } chunk_emit_byte(inner.chunk, OP_RETURN); + optim_tailcall(inner.chunk); Hd *hd = gc_alloc(cm->vm, sizeof(Hd) + sizeof(Bc *)); hd->type = OBJ_QUOT; @@ -206,5 +271,6 @@ Bc *compile_program(Cm *cm, mpc_ast_t *ast) { Bc *chunk = cm->chunk; chunk_emit_byte(chunk, OP_RETURN); + optim_tailcall(chunk); return chunk; } diff --git a/src/compile.h b/src/compile.h index 919bf19..6dd6bb1 100644 --- a/src/compile.h +++ b/src/compile.h @@ -7,7 +7,8 @@ #include "vendor/mpc.h" -// Forward declaration +#define COMPILER_DEBUG 1 + /** Compiler context */ typedef struct Cm { Vm *vm; // Parent context diff --git a/src/debug.c b/src/debug.c index 0f76451..0d25c78 100644 --- a/src/debug.c +++ b/src/debug.c @@ -124,6 +124,33 @@ Z disassemble_instruction(Bc *chunk, Z offset, Dt **dictionary) { case OP_APPLY: printf("APPLY\n"); return offset; + case OP_TAIL_CALL: { + Z bytes_read; + I ofs = decode_sleb128(&chunk->items[offset], &bytes_read); + printf("TAIL_CALL %ld\n", ofs); + return offset + bytes_read; + } + case OP_TAIL_DOWORD: { + Z bytes_read; + I hash = decode_sleb128(&chunk->items[offset], &bytes_read); + printf("TAIL_DOWORD"); + + if (dictionary && *dictionary) { + Dt *entry = lookup_hash(dictionary, hash); + if (entry != NULL) { + printf(" %s", entry->name); + } else { + printf(" ???"); + } + } else { + printf(" 0x%lx", hash); + } + printf("\n"); + return offset + bytes_read; + } + case OP_TAIL_APPLY: + printf("TAIL_APPLY\n"); + return offset; case OP_RETURN: printf("RETURN\n"); return offset; diff --git a/src/gc.c b/src/gc.c index d032703..5f0e572 100644 --- a/src/gc.c +++ b/src/gc.c @@ -6,8 +6,7 @@ #include "chunk.h" #include "gc.h" #include "object.h" -#include "src/print.h" -#include "src/vm.h" +#include "vm.h" #include "vendor/yar.h" #define ALIGN(n) (((n) + 7) & ~7) @@ -83,7 +82,7 @@ V gc_collect(Vm *vm) { Dt *node = *--dsp; if (!node) continue; - if (node->name != NULL) { + if (node->chunk != NULL) { for (Z i = 0; i < node->chunk->constants.count; i++) { node->chunk->constants.items[i] = forward(gc, node->chunk->constants.items[i]); diff --git a/src/main.c b/src/main.c index 876206a..05d5b18 100644 --- a/src/main.c +++ b/src/main.c @@ -1,8 +1,6 @@ #include #include -#include "common.h" - #include "chunk.h" #include "compile.h" #include "debug.h" @@ -75,7 +73,6 @@ I loadfile(const char *fname) { mpc_ast_delete(res.output); if (chunk != NULL) { - // disassemble(chunk, fname, &vm.dictionary); I res = vm_run(&vm, chunk, 0); chunk_release(chunk); vm_deinit(&vm); diff --git a/src/vm.c b/src/vm.c index fcf64dc..f33703c 100644 --- a/src/vm.c +++ b/src/vm.c @@ -31,7 +31,7 @@ static I decode_sleb128(U8 **ptr) { V vm_init(Vm *vm) { vm->sp = vm->stack; vm->rsp = vm->rstack; - vm->rtsp = vm->rtstack; + vm->tsp = vm->tstack; vm->chunk = NULL; vm->dictionary = NULL; @@ -40,9 +40,9 @@ V vm_init(Vm *vm) { for (Z i = 0; i < STACK_SIZE; i++) { vm->stack[i] = NIL; - vm->rtstack[i] = NIL; + vm->tstack[i] = NIL; gc_addroot(&vm->gc, &vm->stack[i]); - gc_addroot(&vm->gc, &vm->rtstack[i]); + gc_addroot(&vm->gc, &vm->tstack[i]); } } @@ -61,10 +61,10 @@ O vm_pop(Vm *vm) { } O vm_peek(Vm *vm) { return *(vm->sp - 1); } -V vm_rtpush(Vm *vm, O o) { *vm->rtsp++ = o; } +V vm_rtpush(Vm *vm, O o) { *vm->tsp++ = o; } O vm_rtpop(Vm *vm) { - O o = *--vm->rtsp; - *vm->rtsp = NIL; + O o = *--vm->tsp; + *vm->tsp = NIL; return o; } @@ -137,6 +137,42 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { vm_push(vm, a); break; } + case OP_NIP: { + /* a b -> b */ + O b = vm_pop(vm); + (void)vm_pop(vm); + vm_push(vm, b); + break; + } + case OP_OVER: { + /* a b -> a b a */ + O b = vm_pop(vm); + O a = vm_pop(vm); + vm_push(vm, a); + vm_push(vm, b); + vm_push(vm, a); + break; + } + case OP_BURY: { + /* a b c - c a b */ + O c = vm_pop(vm); + O b = vm_pop(vm); + O a = vm_pop(vm); + vm_push(vm, c); + vm_push(vm, a); + vm_push(vm, b); + break; + } + case OP_DIG: { + /* a b c - b c a */ + O c = vm_pop(vm); + O b = vm_pop(vm); + O a = vm_pop(vm); + vm_push(vm, b); + vm_push(vm, c); + vm_push(vm, a); + break; + } case OP_TOR: { vm_rtpush(vm, vm_pop(vm)); break; @@ -188,6 +224,38 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { } break; } + case OP_TAIL_CALL: { + I ofs = decode_sleb128(&vm->ip); + // Tail call: reuse current frame, just jump + vm->ip = chunk->items + ofs; + break; + } + case OP_TAIL_DOWORD: { + I hash = decode_sleb128(&vm->ip); + Dt *word = lookup_hash(&vm->dictionary, hash); + if (!word) { + fprintf(stderr, "vm: word not found (hash = %lx)\n", hash); + return 0; + } + // Tail call: reuse current frame + vm->chunk = word->chunk; + vm->ip = word->chunk->items; + break; + } + case OP_TAIL_APPLY: { + O quot = vm_pop(vm); + if (type(quot) == TYPE_QUOT) { + Bc **ptr = (Bc **)(UNBOX(quot) + 1); + Bc *chunk = *ptr; + // Tail call: reuse current frame + vm->chunk = chunk; + vm->ip = chunk->items; + } else { + fprintf(stderr, "vm: attempt to apply non-quotation object\n"); + return 0; + } + break; + } case OP_RETURN: if (vm->rsp != vm->rstack) { Fr frame = vm_rpop(vm); diff --git a/src/vm.h b/src/vm.h index c745538..ee0ebf1 100644 --- a/src/vm.h +++ b/src/vm.h @@ -16,6 +16,10 @@ enum { OP_DROP, OP_DUP, OP_SWAP, + OP_NIP, + OP_OVER, + OP_BURY, + OP_DIG, OP_TOR, // Push from stack to retain stack OP_FROMR, // Push from retain stack to stack OP_JUMP, // Relative jump @@ -23,6 +27,9 @@ enum { OP_CALL, OP_DOWORD, // Call word from dictionary by name hash OP_APPLY, + OP_TAIL_CALL, // Tail call within chunk (reuses current frame) + OP_TAIL_DOWORD, // Tail call to dictionary word (reuses current frame) + OP_TAIL_APPLY, // Tail call to quotation (reuses current frame) OP_RETURN, OP_CHOOSE, OP_ADD, @@ -49,8 +56,8 @@ typedef struct Fr { typedef struct Vm { Gc gc; O stack[STACK_SIZE], *sp; - O rtstack[STACK_SIZE], *rtsp; - Fr rstack[STACK_SIZE], *rsp; // Return stack + O tstack[STACK_SIZE], *tsp; + Fr rstack[STACK_SIZE], *rsp; U8 *ip; Bc *chunk; Dt *dictionary; diff --git a/test.grr b/test.grr index 2ce175f..9220147 100644 --- a/test.grr +++ b/test.grr @@ -1,15 +1,13 @@ -def over { swap dup >r swap r> } def dip { swap >r call r> } def keep { over >r call r> } def if { ? call } -def fac { - dup if: 1 <= [drop 1] [dup 1 - fac *]; +def fib/aux { + if: dig dup 0 = + [drop drop] + [bury [swap 1 - swap] dip dup [+] dip swap fib/aux] + ; } +def fib { 0 1 fib/aux } -def fib { - dup if: 1 <= [] [dup 1 - fib swap 2 - fib +]; -} - -[ 20 fib ] call \=> 6765 -[ 10 fac ] call \=> 3628800 +[ 50 fib ] call \=> 12586269025