diff --git a/examples/compose.grr b/examples/compose.grr new file mode 100644 index 0000000..2565021 --- /dev/null +++ b/examples/compose.grr @@ -0,0 +1,5 @@ +5 [1 +] [2 *] compose +call . + +10 5 [+] curry +call . diff --git a/src/compile.c b/src/compile.c index e71430d..b0fa3ec 100644 --- a/src/compile.c +++ b/src/compile.c @@ -19,40 +19,40 @@ 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}}, - {"?", {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}}, + {"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/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/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/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..0211d59 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) { @@ -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(""); + 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 { diff --git a/src/vm.h b/src/vm.h index 8fb4b55..168fc09 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, @@ -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; 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 }