From cfc45d763abdc4486c9301a21c00573e0b4480d0 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Fri, 23 Jan 2026 14:19:47 -0300 Subject: [PATCH 1/3] quotation composition --- examples/compose.grr | 1 + src/compile.c | 1 + src/debug.c | 2 ++ src/object.h | 18 +++++++++++++ src/print.c | 6 +++++ src/vm.c | 64 ++++++++++++++++++++++++++++++++++++++------ src/vm.h | 3 +++ 7 files changed, 87 insertions(+), 8 deletions(-) create mode 100644 examples/compose.grr diff --git a/examples/compose.grr b/examples/compose.grr new file mode 100644 index 0000000..daabece --- /dev/null +++ b/examples/compose.grr @@ -0,0 +1 @@ +5 [1 +] [2 *] compose call . diff --git a/src/compile.c b/src/compile.c index e71430d..76c50c1 100644 --- a/src/compile.c +++ b/src/compile.c @@ -33,6 +33,7 @@ struct { {"keep", {OP_OVER, OP_TOR, OP_CALL, OP_FROMR, 0}}, {"if", {OP_CHOOSE, OP_CALL, 0}}, {"call", {OP_CALL, 0}}, + {"compose",{OP_COMPOSE, 0}}, {"?", {OP_CHOOSE, 0}}, {"+", {OP_ADD, 0}}, {"-", {OP_SUB, 0}}, diff --git a/src/debug.c b/src/debug.c index e414e56..eda0ee6 100644 --- a/src/debug.c +++ b/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); diff --git a/src/object.h b/src/object.h index 34ce4b0..f987b5f 100644 --- a/src/object.h +++ b/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 diff --git a/src/print.c b/src/print.c index 1407963..8549e5d 100644 --- a/src/print.c +++ b/src/print.c @@ -20,6 +20,12 @@ V print(O o) { case OBJ_QUOT: printf(""); break; + case OBJ_COMPOSE: + printf(""); + break; + case OBJ_CURRY: + printf(""); + break; case OBJ_STR: { // TODO: make this binary safe Str *s = string_unwrap(o); diff --git a/src/vm.c b/src/vm.c index ae56946..288985f 100644 --- a/src/vm.c +++ b/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) { @@ -49,6 +49,10 @@ V vm_init(Vm *vm) { gc_addroot(&vm->gc, &vm->tstack[i]); } + vm->trampoline = chunk_new(""); + chunk_emit_byte(vm->trampoline, OP_FROMR); + chunk_emit_byte(vm->trampoline, OP_TAIL_CALL); + 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 +63,8 @@ V vm_init(Vm *vm) { } V vm_deinit(Vm *vm) { + chunk_release(vm->trampoline); + // Free all definitions Dt *dstack[256]; Dt **dsp = dstack; @@ -249,13 +255,24 @@ 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_tpush(vm, comp->second); + quot = comp->first; + goto do_call; + } + default: vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object"); } break; @@ -271,13 +288,24 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { } 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_tpush(vm, comp->second); + quot = comp->first; + goto do_tail_call; + } + default: + vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object"); } break; } @@ -289,6 +317,26 @@ 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 q2 = vm_pop(vm); + O q1 = vm_pop(vm); + gc_addroot(&vm->gc, &q1); + gc_addroot(&vm->gc, &q2); + if (!callable(q1) || !callable(q2)) + 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 = q1; + comp->second = q2; + vm_push(vm, BOX(hd)); + gc_reset(&vm->gc, mark); + break; + } + case OP_CURRY: { + 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 8fb4b55..3eac49e 100644 --- a/src/vm.h +++ b/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, @@ -68,6 +70,7 @@ typedef struct Vm { Dt *dictionary; Ar arena; jmp_buf error; + Bc *trampoline; // These objects need to stay as roots! O stdin, stdout, stderr; From 58c1f241618d33b13773c49fac3a8c31258c733d Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Fri, 23 Jan 2026 15:14:49 -0300 Subject: [PATCH 2/3] add curry --- examples/compose.grr | 6 +++- src/compile.c | 71 ++++++++++++++++++++++---------------------- src/gc.c | 13 +++++++- src/vm.c | 42 +++++++++++++++++++++----- 4 files changed, 88 insertions(+), 44 deletions(-) diff --git a/examples/compose.grr b/examples/compose.grr index daabece..2565021 100644 --- a/examples/compose.grr +++ b/examples/compose.grr @@ -1 +1,5 @@ -5 [1 +] [2 *] compose call . +5 [1 +] [2 *] compose +call . + +10 5 [+] curry +call . diff --git a/src/compile.c b/src/compile.c index 76c50c1..350efe1 100644 --- a/src/compile.c +++ b/src/compile.c @@ -19,41 +19,42 @@ struct { const char *name; U8 opcode[8]; } primitives[] = { - {"nil", {OP_NIL, 0}}, - {"dup", {OP_DUP, 0}}, - {"drop", {OP_DROP, 0}}, - {"swap", {OP_SWAP, 0}}, - {"over", {OP_OVER, 0}}, - {"nip", {OP_NIP, 0}}, - {"bury", {OP_BURY, 0}}, - {"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}}, - {"?", {OP_CHOOSE, 0}}, - {"+", {OP_ADD, 0}}, - {"-", {OP_SUB, 0}}, - {"*", {OP_MUL, 0}}, - {"/", {OP_DIV, 0}}, - {"%", {OP_MOD, 0}}, - {"logand", {OP_LOGAND, 0}}, - {"logor", {OP_LOGOR, 0}}, - {"logxor", {OP_LOGXOR, 0}}, - {"lognot", {OP_LOGNOT, 0}}, - {"=", {OP_EQ, 0}}, - {"<>", {OP_NEQ, 0}}, - {"<", {OP_LT, 0}}, - {">", {OP_GT, 0}}, - {"<=", {OP_LTE, 0}}, - {">=", {OP_GTE, 0}}, - {"and", {OP_AND, 0}}, - {"or", {OP_OR, 0}}, - {"^", {OP_CONCAT, 0}}, - {NULL, {0}}, + {"nil", {OP_NIL, 0}}, + {"dup", {OP_DUP, 0}}, + {"drop", {OP_DROP, 0}}, + {"swap", {OP_SWAP, 0}}, + {"over", {OP_OVER, 0}}, + {"nip", {OP_NIP, 0}}, + {"bury", {OP_BURY, 0}}, + {"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}}, + {"*", {OP_MUL, 0}}, + {"/", {OP_DIV, 0}}, + {"%", {OP_MOD, 0}}, + {"logand", {OP_LOGAND, 0}}, + {"logor", {OP_LOGOR, 0}}, + {"logxor", {OP_LOGXOR, 0}}, + {"lognot", {OP_LOGNOT, 0}}, + {"=", {OP_EQ, 0}}, + {"<>", {OP_NEQ, 0}}, + {"<", {OP_LT, 0}}, + {">", {OP_GT, 0}}, + {"<=", {OP_LTE, 0}}, + {">=", {OP_GTE, 0}}, + {"and", {OP_AND, 0}}, + {"or", {OP_OR, 0}}, + {"^", {OP_CONCAT, 0}}, + {NULL, {0}}, }; // clang-format on diff --git a/src/gc.c b/src/gc.c index 0add844..c67ea3c 100644 --- a/src/gc.c +++ b/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: diff --git a/src/vm.c b/src/vm.c index 288985f..ade231b 100644 --- a/src/vm.c +++ b/src/vm.c @@ -272,6 +272,13 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { 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"); } @@ -304,6 +311,13 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { 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"); } @@ -319,22 +333,36 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { } case OP_COMPOSE: { I mark = gc_mark(&vm->gc); - O q2 = vm_pop(vm); - O q1 = vm_pop(vm); - gc_addroot(&vm->gc, &q1); - gc_addroot(&vm->gc, &q2); - if (!callable(q1) || !callable(q2)) + 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 = q1; - comp->second = q2; + 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: From f40fd7eaa17a312505a5d92c3f71eeadcaeb6238 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Fri, 23 Jan 2026 15:25:26 -0300 Subject: [PATCH 3/3] rework compose implementation to not use retain stack --- src/compile.c | 2 -- src/vm.c | 18 ++++++++++++++---- src/vm.h | 3 +++ std.grr | 2 ++ 4 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/compile.c b/src/compile.c index 350efe1..b0fa3ec 100644 --- a/src/compile.c +++ b/src/compile.c @@ -29,8 +29,6 @@ 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}}, diff --git a/src/vm.c b/src/vm.c index ade231b..0211d59 100644 --- a/src/vm.c +++ b/src/vm.c @@ -45,13 +45,17 @@ 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(""); - chunk_emit_byte(vm->trampoline, OP_FROMR); - chunk_emit_byte(vm->trampoline, OP_TAIL_CALL); + 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); @@ -128,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) { @@ -268,7 +273,7 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { case TYPE_COMPOSE: { Qo *comp = (Qo *)(UNBOX(quot) + 1); vm_rpush(vm, vm->trampoline, vm->trampoline->items); - vm_tpush(vm, comp->second); + vm->rsp[-1].obj = comp->second; quot = comp->first; goto do_call; } @@ -293,6 +298,10 @@ 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); do_tail_call: @@ -307,7 +316,7 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { case TYPE_COMPOSE: { Qo *comp = (Qo *)(UNBOX(quot) + 1); vm_rpush(vm, vm->trampoline, vm->trampoline->items); - vm_tpush(vm, comp->second); + vm->rsp[-1].obj = comp->second; quot = comp->first; goto do_tail_call; } @@ -368,6 +377,7 @@ I vm_run(Vm *vm, Bc *chunk, I offset) { 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 { diff --git a/src/vm.h b/src/vm.h index 3eac49e..168fc09 100644 --- a/src/vm.h +++ b/src/vm.h @@ -51,6 +51,7 @@ enum { OP_AND, OP_OR, OP_CONCAT, + OP_CALL_NEXT, }; #define STACK_SIZE 256 @@ -58,6 +59,7 @@ enum { typedef struct Fr { Bc *chunk; U8 *ip; + O obj; } Fr; typedef struct Vm { @@ -71,6 +73,7 @@ typedef struct Vm { Ar arena; jmp_buf error; Bc *trampoline; + O next_call; // These objects need to stay as roots! O stdin, stdout, stderr; diff --git a/std.grr b/std.grr index 5faa2e7..779b125 100644 --- a/std.grr +++ b/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 }