rework compose implementation to not use retain stack

examples/compose.grr

@@ -0,0 +1,5 @@
+5 [1 +] [2 *] compose
+call .
+
+10 5 [+] curry
+call .

src/compile.c

@@ -29,10 +29,10 @@ struct {
   {"dig",     {OP_DIG, 0}},
   {">r",      {OP_TOR, 0}},
   {"r>",      {OP_FROMR, 0}},
-  {"dip",    {OP_SWAP, OP_TOR, OP_CALL, OP_FROMR, 0}},
-  {"keep",   {OP_OVER, OP_TOR, OP_CALL, OP_FROMR, 0}},
   {"if",      {OP_CHOOSE, OP_CALL, 0}},
   {"call",    {OP_CALL, 0}},
+  {"compose", {OP_COMPOSE, 0}},
+  {"curry",   {OP_CURRY, 0}},
   {"?",       {OP_CHOOSE, 0}},
   {"+",       {OP_ADD, 0}},
   {"-",       {OP_SUB, 0}},

src/debug.c

@@ -114,6 +114,8 @@ static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
       printf("PRIM \"%s\"\n", prim.name);
       return offset + bytes_read;
     }
+    SIMPLE(COMPOSE);
+    SIMPLE(CURRY);
     SIMPLE(RETURN);
     SIMPLE(CHOOSE);
     SIMPLE(ADD);

src/gc.c

@@ -101,7 +101,6 @@ V gc_collect(Vm *vm) {
     }
     Hd *hdr = (Hd *)scan;
     switch (hdr->type) {
-      // TODO: the rest of the owl
     case OBJ_STR:
       break;
     case OBJ_QUOT: {
@@ -111,6 +110,18 @@ V gc_collect(Vm *vm) {
         chunk->constants.items[i] = forward(gc, chunk->constants.items[i]);
       break;
     }
+    case OBJ_COMPOSE: {
+      Qo *comp = (Qo *)(hdr + 1);
+      comp->first = forward(gc, comp->first);
+      comp->second = forward(gc, comp->second);
+      break;
+    };
+    case OBJ_CURRY: {
+      Qc *curry = (Qc *)(hdr + 1);
+      curry->value = forward(gc, curry->value);
+      curry->callable = forward(gc, curry->callable);
+      break;
+    };
     case OBJ_USERDATA:
       break;
     case OBJ_FWD:

src/object.h

@@ -13,6 +13,8 @@
 enum {
   OBJ_FWD = 2,
   OBJ_QUOT,
+  OBJ_COMPOSE,
+  OBJ_CURRY,
   OBJ_STR,
   OBJ_USERDATA,
 };
@@ -22,6 +24,8 @@ enum {
   TYPE_NUM = 1,
   TYPE_FWD = OBJ_FWD,
   TYPE_QUOT = OBJ_QUOT,
+  TYPE_COMPOSE = OBJ_COMPOSE,
+  TYPE_CURRY = OBJ_CURRY,
   TYPE_STR = OBJ_STR,
   TYPE_USERDATA = OBJ_USERDATA,
 };
@@ -33,6 +37,20 @@ typedef struct Hd {
   U32 size, type;
 } Hd;
 
+/** Composition */
+typedef struct Qo {
+  O first, second;
+} Qo;
+
+/** Curry */
+typedef struct Qc {
+  O value, callable;
+} Qc; //
+
 I type(O);
+static inline I callable(O o) {
+  I t = type(o);
+  return t == TYPE_QUOT || t == TYPE_COMPOSE || t == TYPE_CURRY;
+}
 
 #endif

src/print.c

@@ -20,6 +20,12 @@ V print(O o) {
     case OBJ_QUOT:
       printf("<quotation>");
       break;
+    case OBJ_COMPOSE:
+      printf("<composed>");
+      break;
+    case OBJ_CURRY:
+      printf("<curried>");
+      break;
     case OBJ_STR: {
       // TODO: make this binary safe
       Str *s = string_unwrap(o);

src/vm.c

@@ -5,12 +5,12 @@
 #include "chunk.h"
 #include "compile.h"
 #include "dictionary.h"
+#include "file.h"
 #include "gc.h"
 #include "object.h"
 #include "primitive.h"
-#include "userdata.h"
-#include "file.h"
 #include "string.h"
+#include "userdata.h"
 #include "vm.h"
 
 static I decode_sleb128(U8 **ptr) {
@@ -45,10 +45,18 @@ V vm_init(Vm *vm) {
   for (Z i = 0; i < STACK_SIZE; i++) {
     vm->stack[i] = NIL;
     vm->tstack[i] = NIL;
+    vm->rstack[i].obj = NIL;
     gc_addroot(&vm->gc, &vm->stack[i]);
     gc_addroot(&vm->gc, &vm->tstack[i]);
+    gc_addroot(&vm->gc, &vm->rstack[i].obj);
   }
 
+  vm->next_call = NIL;
+  gc_addroot(&vm->gc, &vm->next_call);
+
+  vm->trampoline = chunk_new("<trampoline>");
+  chunk_emit_byte(vm->trampoline, OP_CALL_NEXT);
+
   vm->stdin = userdata_make(vm, (void *)stdin, &userdata_file);
   vm->stdout = userdata_make(vm, (void *)stdout, &userdata_file);
   vm->stderr = userdata_make(vm, (void *)stderr, &userdata_file);
@@ -59,6 +67,8 @@ V vm_init(Vm *vm) {
 }
 
 V vm_deinit(Vm *vm) {
+  chunk_release(vm->trampoline);
+
   // Free all definitions
   Dt *dstack[256];
   Dt **dsp = dstack;
@@ -122,6 +132,7 @@ V vm_rpush(Vm *vm, Bc *chunk, U8 *ip) {
     vm_error(vm, VM_ERR_STACK_OVERFLOW, "return stack overflow");
   vm->rsp->chunk = chunk;
   vm->rsp->ip = ip;
+  vm->rsp->obj = NIL;
   vm->rsp++;
 }
 Fr vm_rpop(Vm *vm) {
@@ -249,13 +260,31 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
     }
     case OP_CALL: {
       O quot = vm_pop(vm);
-      if (type(quot) == TYPE_QUOT) {
+      vm_rpush(vm, vm->chunk, vm->ip);
+    do_call:
+      switch (type(quot)) {
+      case TYPE_QUOT: {
         Bc **ptr = (Bc **)(UNBOX(quot) + 1);
         Bc *chunk = *ptr;
-        vm_rpush(vm, vm->chunk, vm->ip);
         vm->chunk = chunk;
         vm->ip = chunk->items;
-      } else {
+        break;
+      }
+      case TYPE_COMPOSE: {
+        Qo *comp = (Qo *)(UNBOX(quot) + 1);
+        vm_rpush(vm, vm->trampoline, vm->trampoline->items);
+        vm->rsp[-1].obj = comp->second;
+        quot = comp->first;
+        goto do_call;
+      }
+      case TYPE_CURRY: {
+        Qc *curry = (Qc *)(UNBOX(quot) + 1);
+        vm_push(vm, curry->value);
+        quot = curry->callable;
+        goto do_call;
+        break;
+      }
+      default:
         vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object");
       }
       break;
@@ -269,15 +298,37 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       vm->ip = word->chunk->items;
       break;
     }
+    case OP_CALL_NEXT:
+      vm_push(vm, vm->next_call);
+      vm->next_call = NIL;
+      // fallthrough
     case OP_TAIL_CALL: {
       O quot = vm_pop(vm);
-      if (type(quot) == TYPE_QUOT) {
+    do_tail_call:
+      switch (type(quot)) {
+      case TYPE_QUOT: {
         Bc **ptr = (Bc **)(UNBOX(quot) + 1);
         Bc *chunk = *ptr;
         vm->chunk = chunk;
         vm->ip = chunk->items;
-      } else {
-        vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object\n");
+        break;
+      }
+      case TYPE_COMPOSE: {
+        Qo *comp = (Qo *)(UNBOX(quot) + 1);
+        vm_rpush(vm, vm->trampoline, vm->trampoline->items);
+        vm->rsp[-1].obj = comp->second;
+        quot = comp->first;
+        goto do_tail_call;
+      }
+      case TYPE_CURRY: {
+        Qc *curry = (Qc *)(UNBOX(quot) + 1);
+        vm_push(vm, curry->value);
+        quot = curry->callable;
+        goto do_tail_call;
+        break;
+      }
+      default:
+        vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object");
       }
       break;
     }
@@ -289,9 +340,44 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
         vm_error(vm, err, "primitive call failed");
       break;
     }
+    case OP_COMPOSE: {
+      I mark = gc_mark(&vm->gc);
+      O c1 = vm_pop(vm);
+      O c2 = vm_pop(vm);
+      gc_addroot(&vm->gc, &c2);
+      gc_addroot(&vm->gc, &c1);
+      if (!callable(c2) || !callable(c1))
+        vm_error(vm, VM_ERR_TYPE, "non-callable arguments to compose");
+      Hd *hd = gc_alloc(vm, sizeof(Hd) + sizeof(Qo));
+      hd->type = OBJ_COMPOSE;
+      Qo *comp = (Qo *)(hd + 1);
+      comp->first = c2;
+      comp->second = c1;
+      vm_push(vm, BOX(hd));
+      gc_reset(&vm->gc, mark);
+      break;
+    }
+    case OP_CURRY: {
+      I mark = gc_mark(&vm->gc);
+      O cble = vm_pop(vm);
+      O value = vm_pop(vm);
+      gc_addroot(&vm->gc, &cble);
+      gc_addroot(&vm->gc, &value);
+      if (!callable(cble))
+        vm_error(vm, VM_ERR_TYPE, "non-callable argument to curry");
+      Hd *hd = gc_alloc(vm, sizeof(Hd) + sizeof(Qc));
+      hd->type = OBJ_CURRY;
+      Qc *curry = (Qc *)(hd + 1);
+      curry->value = value;
+      curry->callable = cble;
+      vm_push(vm, BOX(hd));
+      gc_reset(&vm->gc, mark);
+      break;
+    }
     case OP_RETURN:
       if (vm->rsp != vm->rstack) {
         Fr frame = vm_rpop(vm);
+        vm->next_call = frame.obj;
         vm->chunk = frame.chunk;
         vm->ip = frame.ip;
       } else {

src/vm.h

@@ -29,6 +29,8 @@ enum {
   OP_TAIL_DOWORD, // Tail call to dictionary word (reuses current frame)
   OP_TAIL_CALL,   // Tail call to quotation (reuses current frame)
   OP_PRIM,
+  OP_COMPOSE,
+  OP_CURRY,
   OP_RETURN,
   OP_CHOOSE,
   OP_ADD,
@@ -49,6 +51,7 @@ enum {
   OP_AND,
   OP_OR,
   OP_CONCAT,
+  OP_CALL_NEXT,
 };
 
 #define STACK_SIZE 256
@@ -56,6 +59,7 @@ enum {
 typedef struct Fr {
   Bc *chunk;
   U8 *ip;
+  O obj;
 } Fr;
 
 typedef struct Vm {
@@ -68,6 +72,8 @@ typedef struct Vm {
   Dt *dictionary;
   Ar arena;
   jmp_buf error;
+  Bc *trampoline;
+  O next_call;
 
   // These objects need to stay as roots!
   O stdin, stdout, stderr;

std.grr

@@ -8,6 +8,8 @@ def eprintln { stderr fprint "\n" stderr fprint }
 def when { [] if }
 def unless { swap when }
 
+def dip { swap [] curry compose call }
+def keep { over [call] dip }
 def bi { [keep] dip call }
 def tri { [[keep] dip keep] dip call }