*

shell.nix

@@ -1,8 +1,18 @@
-{ pkgs ? import <nixpkgs> {} }:
+{
+  pkgs ? import <nixpkgs> { },
+}:
 
 pkgs.mkShell {
   buildInputs = with pkgs; [
-    clang-tools bear gdb tinycc
+    clang-tools
-    meson ninja rlwrap hyperfine
+    bear
+    gdb
+    tinycc
+    meson
+    ninja
+    rlwrap
+    hyperfine
+    muon
+    samurai
   ];
 }

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 (!compile_expr(&inner, curr, next)) {
-    if (!res) {
       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;
 }

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

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;

src/gc.c

@@ -6,8 +6,7 @@
 #include "chunk.h"
 #include "gc.h"
 #include "object.h"
-#include "src/print.h"
+#include "vm.h"
-#include "src/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]);

src/main.c

@@ -1,8 +1,6 @@
 #include <stdio.h>
 #include <stdlib.h>
 
-#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);

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;
+  O o = *--vm->tsp;
-  *vm->rtsp = NIL;
+  *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);

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;
+  O tstack[STACK_SIZE], *tsp;
-  Fr rstack[STACK_SIZE], *rsp; // Return stack
+  Fr rstack[STACK_SIZE], *rsp;
   U8 *ip;
   Bc *chunk;
   Dt *dictionary;

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 {
+def fib/aux {
-  dup if: 1 <= [drop 1] [dup 1 - fac *];
+  if: dig dup 0 =
+    [drop drop]
+    [bury [swap 1 - swap] dip dup [+] dip swap fib/aux]
+  ;
 }
+def fib { 0 1 fib/aux }
 
-def fib {
+[ 50 fib ] call \=> 12586269025
-  dup if: 1 <= [] [dup 1 - fib swap 2 - fib +];
-}
-
-[ 20 fib ] call \=> 6765
-[ 10 fac ] call \=> 3628800