engineering/lumbda
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
lumbda/c/vm.c
russell@unturf.com f7352b51b0 rename: uncommonlisp -> lumbda throughout the repo 
Historical internal name "uncommonlisp" retired in favor of the
public name "lumbda" ahead of lumbda.com going live. Scope of
this commit:

Source files renamed:
  uncommonlisp.py                     -> lumbda.py
  asm/uncommonlisp.s                  -> asm/lumbda.s
  c/uncommonlisp.h                    -> c/lumbda.h
  whitepaper/uncommonlisp-whitepaper  -> whitepaper/lumbda-whitepaper (.rst + .pdf)

Binaries renamed (tracked ones; c/ was always gitignored):
  asm/uncommonlisp, asm/uncommonlisp-gc, asm/uncommonlisp.o,
  asm/uncommonlisp-gc.o                -> asm/lumbda(-gc)(.o)
  c/.gitignore                          -> ignores lumbda

Internal string updates (sed pass ordered longest-first):
  asm/uncommonlisp -> asm/lumbda
  c/uncommonlisp   -> c/lumbda
  uncommonlisp.py  -> lumbda.py
  UNCOMMONLISP_BIN -> LUMBDA_BIN (asm/test.sh env var)
  "uncommonlisp> " -> "lumbda> " (asm REPL prompt baked into binary)
  UNCOMMONLISP     -> LUMBDA (macros, comments)
  uncommonlisp     -> lumbda (prose)

Binary portal magic updated:
  "ULPORTAL" -> "LUMBDAB1"   # "Lumbda Binary v1"
Old portal files are not backward-compatible — this is a deliberate
break since it's the rename moment. S-expression portals already
carry their own ";; lumbda-portal v1" header and remain cleanly
versioned.

WHITEPAPER.pdf / WHITEPAPER.rst symlinks repointed to the renamed
files. Makefile's whitepaper target targets lumbda-whitepaper.pdf.

Not changed (intentional, separate phases):
  - Filesystem directory /home/fox/git/uncommonlisp itself
    (fox renames locally and the gitlab repo URL in a follow-up)
  - tests.py hardcoded cwd=/home/fox/git/uncommonlisp
    (matches the current on-disk location; will flip when the
    directory rename ships)
  - Git history (immutable; old commits still say uncommonlisp,
    which is correct — that's what they were)

Verified:
  137 asm no-GC + 137 asm GC + 571 Python + 83 C + 189 shared
  functional tests all pass under the new names.
  bench-gc-http (2000 req): all 4 cells behave as expected
  (cells 1/2 flat, 3 leaks, 4 bounded at 1 chunk).
  Python REPL, C REPL, asm REPL all start cleanly.
2026-04-19 10:20:11 -04:00

983 lines
41 KiB
C
Raw Blame History

/*
* vm.c — Bytecode compiler + stack-based VM
*/
#include "lumbda.h"
/* ═══════════════════════════════════════════════════════════════════════════
* CodeObj
* ═══════════════════════════════════════════════════════════════════════════ */
CodeObj *make_code(const char *name) {
CodeObj *c = (CodeObj *)ul_malloc(sizeof(CodeObj));
c->hdr.type = OBJ_CODE;
c->cap = 64;
c->count = 0;
c->instrs = (Instruction *)ul_malloc(sizeof(Instruction) * c->cap);
c->source_map = (int *)ul_malloc(sizeof(int) * c->cap);
c->name = name ? ul_strdup(name) : NULL;
c->self_name = NULL;
c->self_params = NULL;
c->self_nparams = 0;
return c;
}
int code_emit(CodeObj *c, Opcode op, Value arg) {
if (c->count >= c->cap) {
c->cap *= 2;
c->instrs = (Instruction *)ul_realloc(c->instrs, sizeof(Instruction) * c->cap);
c->source_map = (int *)ul_realloc(c->source_map, sizeof(int) * c->cap);
}
int idx = c->count;
c->instrs[idx].op = op;
c->instrs[idx].arg = arg;
c->instrs[idx].arg2 = 0;
c->source_map[idx] = 0;
c->count++;
return idx;
}
void code_emit2(CodeObj *c, Opcode op, Value arg, int arg2) {
int idx = code_emit(c, op, arg);
c->instrs[idx].arg2 = arg2;
}
void code_patch(CodeObj *c, int addr, Value arg) {
c->instrs[addr].arg = arg;
}
/* ═══════════════════════════════════════════════════════════════════════════
* Bytecode compiler
* ═══════════════════════════════════════════════════════════════════════════ */
static bool bc_is_global(Value sym, Env *env) {
Env *e = env;
Env *g = e->global;
while (e && e != g) {
/* Check if sym is locally bound */
EnvBinding *b = NULL;
uint32_t h = (uint32_t)((GET_PAYLOAD(sym) * 2654435761ULL) % e->nbuckets);
b = e->buckets[h];
while (b) { if (b->sym == sym) return false; b = b->next; }
e = e->parent;
}
return true;
}
/* Fallback forms — these get compiled to OP_EVAL */
static bool is_fallback_form(Value head) {
return head == SYM_QUASIQUOTE || head == SYM_DEFINE_MACRO || head == SYM_DEFMACRO ||
head == SYM_DEFINE_SYNTAX || head == SYM_LET_SYNTAX || head == SYM_LETREC_SYNTAX ||
head == SYM_SYNTAX_RULES || head == SYM_DEFINE_VALUES || head == SYM_LET_VALUES ||
head == SYM_LET_STAR_VALUES || head == SYM_DEFINE_RECORD_TYPE ||
head == SYM_MODULE || head == SYM_IMPORT || head == SYM_INCLUDE || head == SYM_LOAD ||
head == SYM_PARAMETERIZE || head == SYM_DYNAMIC_WIND ||
head == SYM_WITH_EXCEPTION_HANDLER || head == SYM_GUARD ||
head == SYM_CALL_WITH_VALUES || head == SYM_VALUES || head == SYM_EVAL ||
head == SYM_ERROR || head == SYM_CASE;
}
static void bc_body(Value *body, int nbody, CodeObj *code, Env *env, bool tail) {
if (nbody == 0) { code_emit(code, OP_VOID, VAL_NIL); return; }
for (int i = 0; i < nbody - 1; i++) {
bc_compile(body[i], code, env, false);
code_emit(code, OP_POP, VAL_NIL);
}
bc_compile(body[nbody - 1], code, env, tail);
}
CodeObj *bc_lambda(Value *body, int nbody, Value *params, int nparams,
Value rest, Env *env, const char *name,
const char *self_name, Value *self_params, int self_nparams) {
CodeObj *inner = make_code(name);
if (self_name) {
inner->self_name = ul_strdup(self_name);
inner->self_params = (Value *)ul_malloc(sizeof(Value) * self_nparams);
memcpy(inner->self_params, self_params, sizeof(Value) * self_nparams);
inner->self_nparams = self_nparams;
}
/* Handle internal defines */
int i = 0;
Value *def_names = NULL;
int ndef = 0;
Value *expanded = (Value *)ul_malloc(sizeof(Value) * (nbody + 64));
memcpy(expanded, body, sizeof(Value) * nbody);
int n = nbody;
while (i < n) {
Value f = expanded[i];
if (IS_PAIR(f) && CAR(f) == SYM_DEFINE) {
Value *a; int na = value_to_list(CDR(f), &a);
Value nm = IS_PAIR(a[0]) ? CAR(a[0]) : a[0];
if (IS_SYM(nm)) {
def_names = (Value *)ul_realloc(def_names, sizeof(Value) * (ndef + 1));
def_names[ndef++] = nm;
}
ul_free(a);
i++;
} else if (IS_PAIR(f) && CAR(f) == SYM_BEGIN) {
Value *spliced; int ns = value_to_list(CDR(f), &spliced);
memmove(expanded + i + ns, expanded + i + 1, sizeof(Value) * (n - i - 1));
memcpy(expanded + i, spliced, sizeof(Value) * ns);
n = n + ns - 1;
ul_free(spliced);
} else {
break;
}
}
if (ndef > 0) {
code_emit(inner, OP_PUSH_ENV, VAL_NIL);
for (int j = 0; j < ndef; j++) {
code_emit(inner, OP_VOID, VAL_NIL);
code_emit(inner, OP_BIND, def_names[j]);
}
}
bc_body(expanded, n, inner, env, true);
code_emit(inner, OP_RETURN, VAL_NIL);
ul_free(expanded);
ul_free(def_names);
return inner;
}
void bc_compile(Value expr, CodeObj *code, Env *env, bool tail) {
/* Self-evaluating */
if (IS_VOID(expr)) { code_emit(code, OP_VOID, VAL_NIL); return; }
if (IS_NIL(expr) || IS_TRUE(expr) || IS_FALSE(expr) || IS_EOF(expr) || IS_CHAR(expr)) {
code_emit(code, OP_CONST, expr); return;
}
if (IS_INT(expr) || IS_DOUBLE(expr) || IS_RATIONAL(expr)) {
code_emit(code, OP_CONST, expr); return;
}
if (IS_STRING(expr) || IS_VECTOR(expr)) {
code_emit(code, OP_CONST, expr); return;
}
if (IS_SYM(expr)) { code_emit(code, OP_LOOKUP, expr); return; }
if (!IS_PAIR(expr)) { code_emit(code, OP_CONST, expr); return; }
Value head = CAR(expr);
Value args = CDR(expr);
/* Fallback forms */
if (IS_SYM(head) && is_fallback_form(head)) {
code_emit(code, OP_EVAL, expr); return;
}
/* quote */
if (head == SYM_QUOTE) { code_emit(code, OP_CONST, CADR(expr)); return; }
/* if */
if (head == SYM_IF) {
Value *a; int na = value_to_list(args, &a);
bc_compile(a[0], code, env, false);
int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL);
bc_compile(a[1], code, env, tail);
int je = code_emit(code, OP_JUMP, VAL_NIL);
code_patch(code, jf, VAL_INT(code->count));
if (na > 2) bc_compile(a[2], code, env, tail);
else code_emit(code, OP_VOID, VAL_NIL);
code_patch(code, je, VAL_INT(code->count));
ul_free(a); return;
}
/* begin */
if (head == SYM_BEGIN) {
Value *a; int na = value_to_list(args, &a);
if (na == 0) { code_emit(code, OP_VOID, VAL_NIL); ul_free(a); return; }
for (int i = 0; i < na - 1; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); }
bc_compile(a[na-1], code, env, tail);
ul_free(a); return;
}
/* and */
if (head == SYM_AND) {
Value *a; int na = value_to_list(args, &a);
if (na == 0) { code_emit(code, OP_CONST, VAL_TRUE); ul_free(a); return; }
if (na == 1) { bc_compile(a[0], code, env, tail); ul_free(a); return; }
int *ends = (int *)ul_malloc(sizeof(int) * na);
int nends = 0;
for (int i = 0; i < na - 1; i++) {
bc_compile(a[i], code, env, false);
ends[nends++] = code_emit(code, OP_JUMP_IF_FALSE_KEEP, VAL_NIL);
}
bc_compile(a[na-1], code, env, tail);
int end = code->count;
for (int i = 0; i < nends; i++) code_patch(code, ends[i], VAL_INT(end));
ul_free(ends); ul_free(a); return;
}
/* or */
if (head == SYM_OR) {
Value *a; int na = value_to_list(args, &a);
if (na == 0) { code_emit(code, OP_CONST, VAL_FALSE); ul_free(a); return; }
if (na == 1) { bc_compile(a[0], code, env, tail); ul_free(a); return; }
int *ends = (int *)ul_malloc(sizeof(int) * na);
int nends = 0;
for (int i = 0; i < na - 1; i++) {
bc_compile(a[i], code, env, false);
ends[nends++] = code_emit(code, OP_JUMP_IF_TRUE_KEEP, VAL_NIL);
}
bc_compile(a[na-1], code, env, tail);
int end = code->count;
for (int i = 0; i < nends; i++) code_patch(code, ends[i], VAL_INT(end));
ul_free(ends); ul_free(a); return;
}
/* when */
if (head == SYM_WHEN) {
Value *a; int na = value_to_list(args, &a);
bc_compile(a[0], code, env, false);
int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL);
for (int i = 1; i < na - 1; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); }
bc_compile(a[na-1], code, env, tail);
int je = code_emit(code, OP_JUMP, VAL_NIL);
code_patch(code, jf, VAL_INT(code->count));
code_emit(code, OP_VOID, VAL_NIL);
code_patch(code, je, VAL_INT(code->count));
ul_free(a); return;
}
/* unless */
if (head == SYM_UNLESS) {
Value *a; int na = value_to_list(args, &a);
bc_compile(a[0], code, env, false);
int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL);
code_emit(code, OP_VOID, VAL_NIL);
int je = code_emit(code, OP_JUMP, VAL_NIL);
code_patch(code, jf, VAL_INT(code->count));
for (int i = 1; i < na - 1; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); }
bc_compile(a[na-1], code, env, tail);
code_patch(code, je, VAL_INT(code->count));
ul_free(a); return;
}
/* cond */
if (head == SYM_COND) {
Value *clauses; int nc = value_to_list(args, &clauses);
int *ends = (int *)ul_malloc(sizeof(int) * nc);
int nends = 0;
for (int i = 0; i < nc; i++) {
Value *cl; int ncl = value_to_list(clauses[i], &cl);
if (cl[0] == SYM_ELSE) {
for (int j = 1; j < ncl - 1; j++) { bc_compile(cl[j], code, env, false); code_emit(code, OP_POP, VAL_NIL); }
bc_compile(ncl > 1 ? cl[ncl-1] : VAL_VOID, code, env, tail);
ul_free(cl); break;
}
if ((ncl >= 3 && cl[1] == SYM_ARROW) || ncl == 1) {
/* Fallback for => and bare test */
code_emit(code, OP_EVAL, expr);
ul_free(cl); ul_free(ends); ul_free(clauses); return;
}
bc_compile(cl[0], code, env, false);
int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL);
for (int j = 1; j < ncl - 1; j++) { bc_compile(cl[j], code, env, false); code_emit(code, OP_POP, VAL_NIL); }
bc_compile(cl[ncl-1], code, env, tail);
ends[nends++] = code_emit(code, OP_JUMP, VAL_NIL);
code_patch(code, jf, VAL_INT(code->count));
ul_free(cl);
if (i == nc - 1) code_emit(code, OP_VOID, VAL_NIL);
}
int end = code->count;
for (int i = 0; i < nends; i++) code_patch(code, ends[i], VAL_INT(end));
ul_free(ends); ul_free(clauses); return;
}
/* define */
if (head == SYM_DEFINE) {
Value *a; int na = value_to_list(args, &a);
if (IS_PAIR(a[0])) {
Value fname = CAR(a[0]);
Formals f = parse_formals(CDR(a[0]));
CodeObj *inner = bc_lambda(a + 1, na - 1, f.params, f.nparams, f.rest, env,
sym_name(fname), NULL, NULL, 0);
/* Emit closure + define */
/* Pack closure info as a vector: [inner_code, nparams, rest] */
Value closure_info = make_vector(3, VAL_NIL);
AS_VECTOR(closure_info)->data[0] = VAL_PTR(inner);
AS_VECTOR(closure_info)->data[1] = VAL_INT(f.nparams);
AS_VECTOR(closure_info)->data[2] = f.rest;
/* Store params in the vector too */
Value params_vec = make_vector_from(f.params, f.nparams);
AS_VECTOR(closure_info)->data = (Value *)ul_realloc(AS_VECTOR(closure_info)->data, sizeof(Value) * 4);
AS_VECTOR(closure_info)->len = 4;
AS_VECTOR(closure_info)->cap = 4;
AS_VECTOR(closure_info)->data[3] = params_vec;
code_emit(code, OP_MAKE_CLOSURE, closure_info);
code_emit(code, OP_DEFINE, fname);
} else {
if (na > 1) bc_compile(a[1], code, env, false);
else code_emit(code, OP_VOID, VAL_NIL);
code_emit(code, OP_DEFINE, a[0]);
}
code_emit(code, OP_VOID, VAL_NIL);
ul_free(a); return;
}
/* set! */
if (head == SYM_SET) {
Value *a; int na = value_to_list(args, &a);
bc_compile(a[1], code, env, false);
code_emit(code, OP_SET, a[0]);
code_emit(code, OP_VOID, VAL_NIL);
ul_free(a); return;
}
/* lambda */
if (head == SYM_LAMBDA || head == SYM_LAMBDA_UC) {
Value *a; int na = value_to_list(args, &a);
Formals f = parse_formals(a[0]);
CodeObj *inner = bc_lambda(a + 1, na - 1, f.params, f.nparams, f.rest, env,
NULL, NULL, NULL, 0);
Value closure_info = make_vector(4, VAL_NIL);
AS_VECTOR(closure_info)->data[0] = VAL_PTR(inner);
AS_VECTOR(closure_info)->data[1] = VAL_INT(f.nparams);
AS_VECTOR(closure_info)->data[2] = f.rest;
AS_VECTOR(closure_info)->data[3] = make_vector_from(f.params, f.nparams);
code_emit(code, OP_MAKE_CLOSURE, closure_info);
ul_free(a); return;
}
/* let */
if (head == SYM_LET) {
Value *a; int na = value_to_list(args, &a);
if (IS_SYM(a[0])) {
/* Named let */
Value name = a[0];
Value *binds; int nb = value_to_list(a[1], &binds);
Value *bps = (Value *)ul_malloc(sizeof(Value) * nb);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
bps[i] = bp[0];
ul_free(bp);
}
CodeObj *inner = bc_lambda(a + 2, na - 2, bps, nb, VAL_NIL, env,
sym_name(name), sym_name(name), bps, nb);
code_emit(code, OP_PUSH_ENV, VAL_NIL);
Value closure_info = make_vector(4, VAL_NIL);
AS_VECTOR(closure_info)->data[0] = VAL_PTR(inner);
AS_VECTOR(closure_info)->data[1] = VAL_INT(nb);
AS_VECTOR(closure_info)->data[2] = VAL_NIL;
AS_VECTOR(closure_info)->data[3] = make_vector_from(bps, nb);
code_emit(code, OP_MAKE_CLOSURE, closure_info);
code_emit(code, OP_DUP, VAL_NIL);
code_emit(code, OP_BIND, name);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
bc_compile(bp[1], code, env, false);
ul_free(bp);
}
code_emit(code, tail ? OP_TAIL_CALL : OP_CALL, VAL_INT(nb));
if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL);
ul_free(bps); ul_free(binds); ul_free(a); return;
}
/* Regular let */
Value *binds; int nb = value_to_list(a[0], &binds);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
bc_compile(bp[1], code, env, false);
ul_free(bp);
}
code_emit(code, OP_PUSH_ENV, VAL_NIL);
for (int i = nb - 1; i >= 0; i--) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
code_emit(code, OP_BIND, bp[0]);
ul_free(bp);
}
bc_body(a + 1, na - 1, code, env, tail);
if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL);
ul_free(binds); ul_free(a); return;
}
/* let* */
if (head == SYM_LET_STAR) {
Value *a; int na = value_to_list(args, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
code_emit(code, OP_PUSH_ENV, VAL_NIL);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
bc_compile(bp[1], code, env, false);
code_emit(code, OP_BIND, bp[0]);
ul_free(bp);
}
bc_body(a + 1, na - 1, code, env, tail);
if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL);
ul_free(binds); ul_free(a); return;
}
/* letrec / letrec* */
if (head == SYM_LETREC || head == SYM_LETREC_STAR) {
Value *a; int na = value_to_list(args, &a);
Value *binds; int nb = value_to_list(a[0], &binds);
code_emit(code, OP_PUSH_ENV, VAL_NIL);
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
code_emit(code, OP_VOID, VAL_NIL);
code_emit(code, OP_BIND, bp[0]);
ul_free(bp);
}
for (int i = 0; i < nb; i++) {
Value *bp; int nbp = value_to_list(binds[i], &bp);
bc_compile(bp[1], code, env, false);
code_emit(code, OP_SET, bp[0]);
ul_free(bp);
}
bc_body(a + 1, na - 1, code, env, tail);
if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL);
ul_free(binds); ul_free(a); return;
}
/* do */
if (head == SYM_DO) {
Value *a; int na = value_to_list(args, &a);
Value *vcs; int nvc = value_to_list(a[0], &vcs);
Value *term; int nterm = value_to_list(a[1], &term);
/* Initialize vars */
typedef struct { Value var; Value step; } DoSpec;
DoSpec *specs = (DoSpec *)ul_malloc(sizeof(DoSpec) * nvc);
for (int i = 0; i < nvc; i++) {
Value *sp; int nsp = value_to_list(vcs[i], &sp);
specs[i].var = sp[0];
specs[i].step = nsp > 2 ? sp[2] : sp[0];
bc_compile(sp[1], code, env, false);
ul_free(sp);
}
code_emit(code, OP_PUSH_ENV, VAL_NIL);
for (int i = nvc - 1; i >= 0; i--) code_emit(code, OP_BIND, specs[i].var);
int loop_start = code->count;
bc_compile(term[0], code, env, false);
int jf = code_emit(code, OP_JUMP_IF_FALSE, VAL_NIL);
if (nterm > 1) {
for (int i = 1; i < nterm - 1; i++) { bc_compile(term[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); }
bc_compile(term[nterm-1], code, env, tail);
} else {
code_emit(code, OP_VOID, VAL_NIL);
}
int je = code_emit(code, OP_JUMP, VAL_NIL);
code_patch(code, jf, VAL_INT(code->count));
/* Body */
for (int i = 2; i < na; i++) { bc_compile(a[i], code, env, false); code_emit(code, OP_POP, VAL_NIL); }
/* Steps */
for (int i = 0; i < nvc; i++) bc_compile(specs[i].step, code, env, false);
for (int i = nvc - 1; i >= 0; i--) code_emit(code, OP_SET, specs[i].var);
code_emit(code, OP_JUMP, VAL_INT(loop_start));
code_patch(code, je, VAL_INT(code->count));
if (!tail) code_emit(code, OP_POP_ENV, VAL_NIL);
ul_free(specs); ul_free(vcs); ul_free(term); ul_free(a);
return;
}
/* call/cc */
if (head == SYM_CALL_CC || head == SYM_CALL_CC2) {
Value *a; int na = value_to_list(args, &a);
bc_compile(a[0], code, env, false);
code_emit(code, OP_CALL_CC, VAL_NIL);
ul_free(a); return;
}
/* apply — fallback to eval */
if (head == SYM_APPLY) {
code_emit(code, OP_EVAL, expr); return;
}
/* Macro expansion at compile time */
if (IS_SYM(head)) {
TRY(ctx) {
Value hval = env_lookup(env, head);
if (IS_MACRO(hval)) {
ULMacro *m = AS_MACRO(hval);
Value *a; int na = value_to_list(args, &a);
Value expanded;
if (IS_SYNTAX_TRANSFORMER(m->transformer)) {
Value form = list_to_value(a, na);
expanded = syntax_transform_value(AS_SYNTAX_TRANSFORMER(m->transformer), form);
} else {
expanded = call_proc(m->transformer, a, na, env);
}
ul_free(a);
bc_compile(expanded, code, env, tail);
return;
}
} CATCH {
/* Not found — continue to regular call */
} ENDTRY;
}
/* Specialized opcodes for hot builtins */
if (IS_SYM(head) && bc_is_global(head, env)) {
Value *call_args; int nca = value_to_list(args, &call_args);
/* + with 2 args */
if (head == intern("+") && nca == 2) {
/* Check for +1 optimization */
if (IS_INT(call_args[1]) && as_int(call_args[1]) == 1 && IS_SYM(call_args[0])) {
code_emit(code, OP_LOOK_ADD1, call_args[0]);
ul_free(call_args); return;
}
if (IS_INT(call_args[0]) && as_int(call_args[0]) == 1 && IS_SYM(call_args[1])) {
code_emit(code, OP_LOOK_ADD1, call_args[1]);
ul_free(call_args); return;
}
bc_compile(call_args[0], code, env, false);
bc_compile(call_args[1], code, env, false);
code_emit(code, OP_ADD, VAL_NIL);
ul_free(call_args); return;
}
/* - with 2 args */
if (head == intern("-") && nca == 2) {
if (IS_INT(call_args[1]) && as_int(call_args[1]) == 1 && IS_SYM(call_args[0])) {
code_emit(code, OP_LOOK_SUB1, call_args[0]);
ul_free(call_args); return;
}
bc_compile(call_args[0], code, env, false);
bc_compile(call_args[1], code, env, false);
code_emit(code, OP_SUB, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("-") && nca == 1) {
bc_compile(call_args[0], code, env, false);
code_emit(code, OP_NEG, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("*") && nca == 2) {
bc_compile(call_args[0], code, env, false);
bc_compile(call_args[1], code, env, false);
code_emit(code, OP_MUL, VAL_NIL);
ul_free(call_args); return;
}
/* Comparison ops */
#define SPECIALIZE_CMP(sym_str, opcode) \
if (head == intern(sym_str) && nca == 2) { \
bc_compile(call_args[0], code, env, false); \
bc_compile(call_args[1], code, env, false); \
code_emit(code, opcode, VAL_NIL); \
ul_free(call_args); return; \
}
SPECIALIZE_CMP("=", OP_NUM_EQ)
SPECIALIZE_CMP("<", OP_LT)
SPECIALIZE_CMP(">", OP_GT)
SPECIALIZE_CMP("<=", OP_LE)
SPECIALIZE_CMP(">=", OP_GE)
#undef SPECIALIZE_CMP
/* car, cdr, cons, null?, pair?, not, zero? */
if (head == intern("car") && nca == 1) {
bc_compile(call_args[0], code, env, false);
code_emit(code, OP_CAR, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("cdr") && nca == 1) {
bc_compile(call_args[0], code, env, false);
code_emit(code, OP_CDR, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("cons") && nca == 2) {
bc_compile(call_args[0], code, env, false);
bc_compile(call_args[1], code, env, false);
code_emit(code, OP_CONS, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("null?") && nca == 1) {
bc_compile(call_args[0], code, env, false);
code_emit(code, OP_NULL_P, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("pair?") && nca == 1) {
bc_compile(call_args[0], code, env, false);
code_emit(code, OP_PAIR_P, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("not") && nca == 1) {
bc_compile(call_args[0], code, env, false);
code_emit(code, OP_NOT, VAL_NIL);
ul_free(call_args); return;
}
if (head == intern("zero?") && nca == 1) {
bc_compile(call_args[0], code, env, false);
code_emit(code, OP_ZERO_P, VAL_NIL);
ul_free(call_args); return;
}
ul_free(call_args);
}
/* Self tail-call optimization */
if (tail && IS_SYM(head) && code->self_name && strcmp(sym_name(head), code->self_name) == 0) {
Value *call_args; int nca = value_to_list(args, &call_args);
for (int i = 0; i < nca; i++) bc_compile(call_args[i], code, env, false);
code_emit2(code, OP_SELF_TAIL_CALL, VAL_INT(nca), code->self_nparams);
ul_free(call_args); return;
}
/* Regular function call */
bc_compile(head, code, env, false);
Value *call_args; int nca = value_to_list(args, &call_args);
for (int i = 0; i < nca; i++) bc_compile(call_args[i], code, env, false);
code_emit(code, tail ? OP_TAIL_CALL : OP_CALL, VAL_INT(nca));
ul_free(call_args);
}
/* syntax_transform_value is declared in lumbda.h, implemented in eval.c */
/* ═══════════════════════════════════════════════════════════════════════════
* Compile a Proc into a CompiledProc
* ═══════════════════════════════════════════════════════════════════════════ */
CompiledProc *compile_proc(Proc *p, Env *env) {
CodeObj *code = bc_lambda(p->body.exprs, p->body.count,
p->params, p->nparams, p->rest, env,
p->name, NULL, NULL, 0);
CompiledProc *cp = (CompiledProc *)ul_malloc(sizeof(CompiledProc));
cp->hdr.type = OBJ_COMPILED_PROC;
cp->code = code;
cp->params = (Value *)ul_malloc(sizeof(Value) * p->nparams);
memcpy(cp->params, p->params, sizeof(Value) * p->nparams);
cp->nparams = p->nparams;
cp->rest = p->rest;
cp->env = p->env;
cp->name = p->name ? ul_strdup(p->name) : NULL;
return cp;
}
/* ═══════════════════════════════════════════════════════════════════════════
* VM execution
* ═══════════════════════════════════════════════════════════════════════════ */
/* Invoke a FullCont — signals the VM trampoline via longjmp */
static Value invoke_continuation(FullCont *cont, Value val) {
if (!g_cont_trampoline || !g_cont_trampoline->active) {
lisp_error("continuation invoked outside VM execution");
}
g_cont_invoked = cont;
g_cont_invoked_val = val;
longjmp(g_cont_trampoline->jmp, 1);
return VAL_VOID; /* unreachable */
}
/* Builtin wrapper for calling a continuation as a function */
static Value cont_call_builtin(Value *args, int nargs, Env *env) {
(void)env;
/* The continuation value is stored as the first arg; we passed it differently.
* Actually, we need to find the continuation. The trick: we use the eval.c
* call path which checks IS_CONTINUATION. So this path is only for when
* continuations end up in the generic builtin slot (which won't happen). */
lisp_error("continuation called through wrong path");
return VAL_VOID;
}
Value vm_exec(CodeObj *code, Env *env) {
CodeObj *cur_code = code;
Instruction *instrs = code->instrs;
int ip = 0;
int n_instrs = code->count;
ValueStack stack;
vs_init(&stack, 128);
/* Frame stack */
int frame_cap = 32;
int frame_count = 0;
VMFrame *frames = (VMFrame *)ul_malloc(sizeof(VMFrame) * frame_cap);
/* Unique ID for this VM invocation (used to match continuations) */
int vm_id_storage;
void *vm_id = &vm_id_storage;
/* Set up trampoline for continuation invocation */
ContTrampoline trampoline;
trampoline.active = true;
ContTrampoline *prev_trampoline = g_cont_trampoline;
g_cont_trampoline = &trampoline;
if (setjmp(trampoline.jmp) != 0) {
/* A continuation was invoked — resume it */
FullCont *c = g_cont_invoked;
Value val = g_cont_invoked_val;
g_cont_invoked = NULL;
/* Deep-copy the continuation state for multi-shot safety */
frame_count = c->nframes;
if (frame_count > frame_cap) {
frame_cap = frame_count * 2;
}
ul_free(frames);
frames = deep_copy_frames(c->frames, c->nframes);
frame_cap = frame_count > 0 ? frame_count * 2 : 32;
ul_free(stack.data);
stack.len = c->stack_len;
stack.cap = c->stack_len + 16;
stack.data = (Value *)ul_malloc(sizeof(Value) * stack.cap);
memcpy(stack.data, c->stack, sizeof(Value) * c->stack_len);
vs_push(&stack, val);
ip = c->ip;
instrs = c->instrs;
n_instrs = c->n_instrs;
env = deep_copy_env(c->env);
/* Fall through to main loop */
}
while (ip < n_instrs) {
Instruction *instr = &instrs[ip++];
Opcode op = instr->op;
Value arg = instr->arg;
switch (op) {
case OP_CONST:
vs_push(&stack, arg);
break;
case OP_LOOKUP:
vs_push(&stack, env_lookup(env, arg));
break;
case OP_SET:
env_set(env, arg, vs_pop(&stack));
break;
case OP_DEFINE:
env_define(env, arg, vs_pop(&stack));
break;
case OP_POP:
vs_pop(&stack);
break;
case OP_DUP:
vs_push(&stack, vs_peek(&stack));
break;
case OP_VOID:
vs_push(&stack, VAL_VOID);
break;
case OP_JUMP:
ip = (int)as_int(arg);
if (g_portal_checkpoint_path) {
FullCont *cp_cont = make_full_cont(frames, frame_count,
stack.data, stack.len, ip, instrs, n_instrs, env, vm_id);
portal_save(env, g_portal_checkpoint_path, cp_cont);
ul_free((void *)g_portal_checkpoint_path);
g_portal_checkpoint_path = NULL;
}
break;
case OP_JUMP_IF_FALSE: {
Value v = vs_pop(&stack);
if (IS_FALSE(v)) ip = (int)as_int(arg);
break;
}
case OP_JUMP_IF_FALSE_KEEP:
if (IS_FALSE(stack.data[stack.len - 1])) ip = (int)as_int(arg);
else vs_pop(&stack);
break;
case OP_JUMP_IF_TRUE_KEEP:
if (IS_TRUTHY(stack.data[stack.len - 1])) ip = (int)as_int(arg);
else vs_pop(&stack);
break;
case OP_CALL: {
int nargs = (int)as_int(arg);
Value *args_arr = stack.data + stack.len - nargs;
stack.len -= nargs;
Value func = vs_pop(&stack);
if (IS_CONTINUATION(func)) {
Value val = nargs > 0 ? args_arr[0] : VAL_VOID;
invoke_continuation(AS_CONTINUATION(func), val);
break; /* unreachable */
}
if (IS_COMPILED_PROC(func)) {
CompiledProc *cp = AS_COMPILED_PROC(func);
/* Push frame */
if (frame_count >= frame_cap) {
frame_cap *= 2;
frames = (VMFrame *)ul_realloc(frames, sizeof(VMFrame) * frame_cap);
}
VMFrame *f = &frames[frame_count++];
f->instrs = instrs; f->ip = ip; f->n_instrs = n_instrs;
f->env = env;
f->stack = stack.data; f->stack_len = stack.len; f->stack_cap = stack.cap;
env = env_child(cp->env, cp->params, cp->nparams, cp->rest, args_arr, nargs);
cur_code = cp->code;
instrs = cp->code->instrs; ip = 0; n_instrs = cp->code->count;
vs_init(&stack, 64);
continue;
}
if (IS_PROC(func)) {
vs_push(&stack, call_proc(func, args_arr, nargs, env));
} else if (IS_BUILTIN(func)) {
vs_push(&stack, AS_BUILTIN(func)(args_arr, nargs, env));
} else {
lisp_error("not callable");
}
break;
}
case OP_TAIL_CALL: {
int nargs = (int)as_int(arg);
Value *args_arr = stack.data + stack.len - nargs;
stack.len -= nargs;
Value func = vs_pop(&stack);
if (IS_CONTINUATION(func)) {
Value val = nargs > 0 ? args_arr[0] : VAL_VOID;
invoke_continuation(AS_CONTINUATION(func), val);
break; /* unreachable */
}
if (IS_COMPILED_PROC(func)) {
CompiledProc *cp = AS_COMPILED_PROC(func);
env = env_child(cp->env, cp->params, cp->nparams, cp->rest, args_arr, nargs);
cur_code = cp->code;
instrs = cp->code->instrs; ip = 0; n_instrs = cp->code->count;
vs_clear(&stack);
if (g_portal_checkpoint_path) {
FullCont *cp_cont = make_full_cont(frames, frame_count,
stack.data, stack.len, ip, instrs, n_instrs, env, vm_id);
portal_save(env, g_portal_checkpoint_path, cp_cont);
ul_free((void *)g_portal_checkpoint_path);
g_portal_checkpoint_path = NULL;
}
continue;
}
if (IS_PROC(func) || IS_BUILTIN(func)) {
Value ret = call_proc(func, args_arr, nargs, env);
if (frame_count == 0) { ul_free(frames); ul_free(stack.data); g_cont_trampoline = prev_trampoline; return ret; }
VMFrame *f = &frames[--frame_count];
instrs = f->instrs; ip = f->ip; n_instrs = f->n_instrs;
env = f->env;
ul_free(stack.data);
stack.data = f->stack; stack.len = f->stack_len; stack.cap = f->stack_cap;
vs_push(&stack, ret);
continue;
}
lisp_error("not callable");
break;
}
case OP_RETURN: {
Value ret = stack.len > 0 ? vs_pop(&stack) : VAL_VOID;
if (frame_count == 0) { ul_free(frames); ul_free(stack.data); g_cont_trampoline = prev_trampoline; return ret; }
VMFrame *f = &frames[--frame_count];
instrs = f->instrs; ip = f->ip; n_instrs = f->n_instrs;
env = f->env;
ul_free(stack.data);
stack.data = f->stack; stack.len = f->stack_len; stack.cap = f->stack_cap;
vs_push(&stack, ret);
continue;
}
case OP_MAKE_CLOSURE: {
/* arg is a vector: [code, nparams, rest, params_vec] */
ULVector *info = AS_VECTOR(arg);
CodeObj *inner = AS_CODE(info->data[0]);
int nparams = (int)as_int(info->data[1]);
Value rest = info->data[2];
ULVector *params_vec = AS_VECTOR(info->data[3]);
CompiledProc *cp = (CompiledProc *)ul_malloc(sizeof(CompiledProc));
cp->hdr.type = OBJ_COMPILED_PROC;
cp->code = inner;
cp->params = params_vec->data;
cp->nparams = nparams;
cp->rest = rest;
cp->env = env;
cp->name = inner->name;
vs_push(&stack, VAL_PTR(cp));
break;
}
case OP_PUSH_ENV:
env = make_env(env);
break;
case OP_POP_ENV:
env = env->parent;
break;
case OP_BIND:
env_define(env, arg, vs_pop(&stack));
break;
case OP_EVAL:
vs_push(&stack, leval(arg, env));
break;
case OP_CALL_CC:
/* Full call/cc — capture current VM state as a FullCont */
{
Value proc = vs_pop(&stack);
FullCont *cont = make_full_cont(frames, frame_count,
stack.data, stack.len, ip, instrs, n_instrs, env, vm_id);
Value cont_val = VAL_PTR(cont);
if (IS_COMPILED_PROC(proc)) {
/* Push frame and enter compiled proc with continuation as arg */
CompiledProc *cp = AS_COMPILED_PROC(proc);
if (frame_count >= frame_cap) {
frame_cap *= 2;
frames = (VMFrame *)ul_realloc(frames, sizeof(VMFrame) * frame_cap);
}
VMFrame *f = &frames[frame_count++];
f->instrs = instrs; f->ip = ip; f->n_instrs = n_instrs;
f->env = env;
f->stack = stack.data; f->stack_len = stack.len; f->stack_cap = stack.cap;
Value kargs[1] = {cont_val};
env = env_child(cp->env, cp->params, cp->nparams, cp->rest, kargs, 1);
cur_code = cp->code;
instrs = cp->code->instrs; ip = 0; n_instrs = cp->code->count;
vs_init(&stack, 64);
continue;
}
if (IS_PROC(proc) || IS_BUILTIN(proc)) {
Value kargs[1] = {cont_val};
vs_push(&stack, call_proc(proc, kargs, 1, env));
} else {
lisp_error("call/cc: not callable");
}
}
break;
/* Specialized opcodes */
case OP_ADD: { Value b = vs_pop(&stack); stack.data[stack.len-1] = num_add(stack.data[stack.len-1], b); break; }
case OP_SUB: { Value b = vs_pop(&stack); stack.data[stack.len-1] = num_sub(stack.data[stack.len-1], b); break; }
case OP_MUL: { Value b = vs_pop(&stack); stack.data[stack.len-1] = num_mul(stack.data[stack.len-1], b); break; }
case OP_NEG: stack.data[stack.len-1] = num_neg(stack.data[stack.len-1]); break;
case OP_ADD1: stack.data[stack.len-1] = num_add(stack.data[stack.len-1], VAL_INT(1)); break;
case OP_SUB1: stack.data[stack.len-1] = num_sub(stack.data[stack.len-1], VAL_INT(1)); break;
case OP_NUM_EQ: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_eq(stack.data[stack.len-1], b)); break; }
case OP_LT: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_lt(stack.data[stack.len-1], b)); break; }
case OP_GT: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_gt(stack.data[stack.len-1], b)); break; }
case OP_LE: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_le(stack.data[stack.len-1], b)); break; }
case OP_GE: { Value b = vs_pop(&stack); stack.data[stack.len-1] = VAL_BOOL(num_ge(stack.data[stack.len-1], b)); break; }
case OP_CAR: stack.data[stack.len-1] = CAR(stack.data[stack.len-1]); break;
case OP_CDR: stack.data[stack.len-1] = CDR(stack.data[stack.len-1]); break;
case OP_CONS: { Value d = vs_pop(&stack); stack.data[stack.len-1] = cons(stack.data[stack.len-1], d); break; }
case OP_NULL_P: stack.data[stack.len-1] = VAL_BOOL(IS_NIL(stack.data[stack.len-1])); break;
case OP_PAIR_P: stack.data[stack.len-1] = VAL_BOOL(IS_PAIR(stack.data[stack.len-1])); break;
case OP_NOT: stack.data[stack.len-1] = VAL_BOOL(IS_FALSE(stack.data[stack.len-1])); break;
case OP_ZERO_P: stack.data[stack.len-1] = VAL_BOOL(num_eq(stack.data[stack.len-1], VAL_INT(0))); break;
case OP_VEC_REF: { Value i = vs_pop(&stack); stack.data[stack.len-1] = AS_VECTOR(stack.data[stack.len-1])->data[(int)as_int(i)]; break; }
case OP_VEC_SET: { Value v = vs_pop(&stack); Value i = vs_pop(&stack); AS_VECTOR(stack.data[stack.len-1])->data[(int)as_int(i)] = v; stack.data[stack.len-1] = VAL_VOID; break; }
/* Superinstructions */
case OP_LOOK_ADD1: vs_push(&stack, num_add(env_lookup(env, arg), VAL_INT(1))); break;
case OP_LOOK_SUB1: vs_push(&stack, num_sub(env_lookup(env, arg), VAL_INT(1))); break;
case OP_SELF_TAIL_CALL: {
int nargs = (int)as_int(arg);
int nparams_expected = instr->arg2;
Value *args_arr = stack.data + stack.len - nargs;
/* Rebind in current env */
if (cur_code->self_params) {
for (int i = 0; i < nargs && i < nparams_expected; i++) {
env_set(env, cur_code->self_params[i], args_arr[i]);
}
}
ip = 0;
vs_clear(&stack);
continue;
}
default:
lisp_error("unknown opcode: %d", op);
}
}
Value ret = stack.len > 0 ? stack.data[stack.len - 1] : VAL_VOID;
ul_free(stack.data);
ul_free(frames);
g_cont_trampoline = prev_trampoline;
return ret;
}
Reference in a new issue View git blame Copy permalink