Hojun-Cho/ww
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

examples: lisp — proper tail calls in eval

Browse Source
This commit is contained in:
Hojun-Cho
2026-05-12 22:54:34 +09:00
parent ab173b095a
commit 78b1cbfb6a
5 changed files with 282 additions and 166 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
examples/lisp/CLAUDE.md
View File

@@ -94,6 +94,25 @@ always one of the above and shows up under valgrind/gdb the same
way it did the first time: silently dropped store, missing field way it did the first time: silently dropped store, missing field
read, garbage payload after a tagged-union return. read, garbage payload after a tagged-union return.
## Tail-call optimization
`eval` is a single `for(true)` trampoline; a tail position rewrites
`v` (current expr) and `cure` (current env) in place and `continue`s
instead of recursing. Tail positions are:
- the chosen branch of `if`
- the last form of `begin` / `let` / a lambda body
- a direct call in any of the above
A `tailed` flag flips on the first jump into a fresh scope (LET
binding, lambda body) so subsequent `define`/`set!` mutate the local
`cure` chain rather than the caller's `ein` slot — same scoping the
old recursive `run_body(_, &pe)` path gave.
Mutual recursion still doesn't work — that's a `define` tie-back
limitation, not a TCO one. Defining `evn?` before `od?` captures an
env where `od?` is unbound; the tie-back only adds the self-binding.
## Interpreter limitations (design, not bug) ## Interpreter limitations (design, not bug)
- **No GC.** Every cons / value / env frame is `mmap`'d via - **No GC.** Every cons / value / env frame is `mmap`'d via
@@ -101,10 +120,9 @@ read, garbage payload after a tagged-union return.
the process exits. The test_huge demo peaks at ~595 MB under the process exits. The test_huge demo peaks at ~595 MB under
`--pages-as-heap=yes`. Per-top-level-form arena reset would cut `--pages-as-heap=yes`. Per-top-level-form arena reset would cut
this by ~100× — see the closing note in `repl()` for the hook this by ~100× — see the closing note in `repl()` for the hook
point. point. Note: `rt_alloc` is one mmap syscall per call returning a
- **No tail-call optimization.** Recursion grows the C-side stack whole 4KB page, so even tail-recursive loops are bottlenecked on
one frame per Lisp call. `(spin 100000 0)` will eventually stack- allocation, not on Lisp work — `(spin 100000 0)` runs in ~4s.
overflow even though it's tail-recursive in source.
- **No bigints.** `i64` wraps silently on overflow. `(fact 21)` - **No bigints.** `i64` wraps silently on overflow. `(fact 21)`
rolls over. rolls over.
- **Float printing is fixed `%.6f`.** `1.0` prints as `1.000000`. - **Float printing is fixed `%.6f`.** `1.0` prints as `1.000000`.

2
examples/lisp/Makefile
View File

@@ -33,7 +33,7 @@ lisp_test: lisp_test.ww lispcore.ww
# Demo programs in tree. `make demo` runs every test_*.lisp through # Demo programs in tree. `make demo` runs every test_*.lisp through
# the REPL; each prints its results to stdout (errors go to stderr # the REPL; each prints its results to stdout (errors go to stderr
# and don't break the run). Useful as a smoke check after edits. # and don't break the run). Useful as a smoke check after edits.
DEMOS := test_arith.lisp test_list.lisp test_lambda.lisp test_error.lisp DEMOS := test_arith.lisp test_list.lisp test_lambda.lisp test_error.lisp test_tco.lisp
demo: lisp demo: lisp
@for f in $(DEMOS); do \ @for f in $(DEMOS); do \

12
examples/lisp/lisp_test.ww
View File

@@ -263,6 +263,18 @@ export fn main() i32 = {
check_int ("let-product", "(let ((a 3) (b 4)) (* a b))", 12i64, ep); check_int ("let-product", "(let ((a 3) (b 4)) (* a b))", 12i64, ep);
check_int ("begin-last", "(begin 1 2 (+ 10 20))", 30i64, ep); check_int ("begin-last", "(begin 1 2 (+ 10 20))", 30i64, ep);
// ---- tail-call optimization ----
// 30k iterations is well past the pre-TCO segfault threshold
// (~25k) but still completes inside the test budget. Each probe
// exercises a different tail position: lambda body via if,
// lambda body via begin, and lambda body via let.
run ("def-spin", "(define spin (lambda (n a) (if (= n 0) a (spin (- n 1) (+ a 1)))))", ep);
check_int ("tco-if", "(spin 30000 0)", 30000i64, ep);
run ("def-bspin", "(define bspin (lambda (n a) (if (= n 0) a (begin a (bspin (- n 1) (+ a 1))))))", ep);
check_int ("tco-begin", "(bspin 30000 0)", 30000i64, ep);
run ("def-lspin", "(define lspin (lambda (n a) (if (= n 0) a (let ((m (- n 1))) (lspin m (+ a 1))))))", ep);
check_int ("tco-let", "(lspin 30000 0)", 30000i64, ep);
// ---- floats ---- // ---- floats ----
check_float("float-add", "(+ 1.5 2.5)", 4.0, ep); check_float("float-add", "(+ 1.5 2.5)", 4.0, ep);
check_float("float-mul", "(* 0.5 0.5)", 0.25, ep); check_float("float-mul", "(* 0.5 0.5)", 0.25, ep);

381
examples/lisp/lispcore.ww
View File

@@ -6,7 +6,7 @@
// //
// What this exercises across the ww language: // What this exercises across the ww language:
// - tagged-union returns with many variants: // - tagged-union returns with many variants:
// (*value | rterror) from eval / apply // (*value | rterror) from eval
// (*value | parserr | eof) from the parser // (*value | parserr | eof) from the parser
// - `match` with `yield` so the REPL dispatch is one expression // - `match` with `yield` so the REPL dispatch is one expression
// - `?` to propagate the error variant up the call chain // - `?` to propagate the error variant up the call chain
@@ -983,174 +983,233 @@ fn apply_builtin(id: i32, xs: []*value) (*value | rterror) = {
// ---- eval ------------------------------------------------------------- // ---- eval -------------------------------------------------------------
export fn eval(v: *value, e: **env) (*value | rterror) = { // eval — drive the evaluation of a single form. Most paths are ordinary
// Self-evaluating atoms — every variant of `valkind` that isn't // recursion; tail positions (IF branch, last form of BEGIN/LET/lambda
// SYM (lookup) or CONS (application). // body, and a tail call into another lambda) re-enter this loop with a
if (v.kind == valkind.NIL) { return v; }; // new (v, cure) instead of recursing, so deep tail-recursive Lisp code
if (v.kind == valkind.BOOL) { return v; }; // doesn't grow the C stack one frame per call.
if (v.kind == valkind.INT) { return v; }; //
if (v.kind == valkind.FLOAT) { return v; }; // Scope handling. `ein` is the *caller's* env slot. While evaluation
if (v.kind == valkind.STR) { return v; }; // stays in the caller's scope (top-level work, IF, BEGIN), `define`/
if (v.kind == valkind.BUILTIN) { return v; }; // `set!` mutate via `ein` so a top-level define lands in the caller's
if (v.kind == valkind.LAMBDA) { return v; }; // global env. Once a tail-jump enters a fresh scope (LET binding,
// lambda body), `tailed` flips and further `define`s are confined to
// the local `cure` chain — same behavior as the pre-TCO code, where
// LET/apply created their own `pe` local that died at scope exit.
export fn eval(v0: *value, ein: **env) (*value | rterror) = {
let v: *value = v0;
let cure: *env = *ein;
let tailed: bool = false;
for (true) {
// Self-evaluating atoms — every variant of `valkind` that
// isn't SYM (lookup) or CONS (application).
if (v.kind == valkind.NIL) { return v; };
if (v.kind == valkind.BOOL) { return v; };
if (v.kind == valkind.INT) { return v; };
if (v.kind == valkind.FLOAT) { return v; };
if (v.kind == valkind.STR) { return v; };
if (v.kind == valkind.BUILTIN) { return v; };
if (v.kind == valkind.LAMBDA) { return v; };
if (v.kind == valkind.SYM) { if (v.kind == valkind.SYM) {
return env_lookup(*e, v.sid)?; return env_lookup(cure, v.sid)?;
};
// CONS — application. The head selects a special form (via symbol
// id) or evaluates to a callable.
let head: *value = v.car;
let rest: *value = v.cdr;
if (head.kind == valkind.SYM) {
let sf: sform = classify_sform(head.sid);
if (sf != sform.NONE) {
return eval_sform(sf, rest, e)?;
}; };
};
let callee: *value = eval(head, e)?; // CONS — application. Head selects a special form (via
// symbol id) or evaluates to a callable.
let head: *value = v.car;
let rest: *value = v.cdr;
// Inline the args walk: a separate `(slice | rterror)` return loses let sf: sform = sform.NONE;
// xs.len through the wwstage cgen's 3-reg tagged-union convention if (head.kind == valkind.SYM) {
// (AX=tag, DX=ptr, CX=cap — len is computed into BX and dropped). sf = classify_sform(head.sid);
// Keeping the slice strictly local sidesteps that.
let xs: []*value;
xs.ptr = nil;
xs.len = 0;
xs.cap = 0;
let cur: *value = rest;
for (cur.kind == valkind.CONS) {
let av = eval(cur.car, e)?;
append(xs, av);
cur = cur.cdr;
};
return apply(callee, xs, e)?;
};
// eval_sform — dispatch on the special-form tag. Each arm consumes a
// specific shape of the rest-list and updates `e` if it must.
fn eval_sform(sf: sform, rest: *value, e: **env) (*value | rterror) = {
let tag: sform = sf;
switch (tag) {
case sform.QUOTE: {
if (rest.kind != valkind.CONS) { return "quote: missing arg": rterror; };
return rest.car;
};
case sform.IF: {
if (list_len(rest) < 2) { return "if: need cond + then": rterror; };
let cnd: *value = rest.car;
let thn: *value = rest.cdr.car;
let cv = eval(cnd, e)?;
if (truthy(cv)) { return eval(thn, e)?; };
let elsep: *value = rest.cdr.cdr;
if (elsep.kind == valkind.CONS) {
return eval(elsep.car, e)?;
}; };
return vnil();
};
case sform.DEFINE: {
if (list_len(rest) != 2) { return "define: (define name expr)": rterror; };
let nameval: *value = rest.car;
if (nameval.kind != valkind.SYM) { return "define: name must be symbol": rterror; };
let body: *value = rest.cdr.car;
let bv = eval(body, e)?;
env_define(e, nameval.sid, bv);
// Recursive-lambda tie-back: prepend a self-binding frame
// to the captured env so `(fact …)` inside fact's body
// resolves. Earlier versions clobbered `bv.envp` with `*e`,
// which wiped out any non-global env that closures (e.g.
// `(adder 5)` returning `(lambda (x) (+ x k))`) had captured.
if (bv.kind == valkind.LAMBDA) {
let frame: *env = alloc(env{
sid = nameval.sid,
val = bv,
next = bv.envp,
});
bv.envp = frame;
};
return vnil();
};
case sform.SETBANG: {
if (list_len(rest) != 2) { return "set!: (set! name expr)": rterror; };
let nameval: *value = rest.car;
if (nameval.kind != valkind.SYM) { return "set!: name must be symbol": rterror; };
let body: *value = rest.cdr.car;
let bv = eval(body, e)?;
env_set(*e, nameval.sid, bv)?;
return bv;
};
case sform.LAMBDA: {
if (list_len(rest) < 2) { return "lambda: (lambda (params) body...)": rterror; };
let params: *value = rest.car;
let body: *value = rest.cdr;
return vlambda(params, body, *e);
};
case sform.LET: {
// (let ((x v) (y w) ...) body...)
if (list_len(rest) < 2) { return "let: (let ((b ...)) body)": rterror; };
let binds: *value = rest.car;
let body: *value = rest.cdr;
let inner: *env = *e;
let cur: *value = binds;
for (cur.kind == valkind.CONS) {
let pair: *value = cur.car;
if (list_len(pair) != 2) { return "let: bad binding": rterror; };
let nm: *value = pair.car;
if (nm.kind != valkind.SYM) { return "let: name must be sym": rterror; };
let val = eval(pair.cdr.car, e)?;
let f: *env = alloc(env{ sid = nm.sid, val = val, next = inner });
inner = f;
cur = cur.cdr;
};
let inscope: *env = inner;
let pe: *env = inscope;
return run_body(body, &pe)?;
};
case sform.BEGIN: {
return run_body(rest, e)?;
};
};
return "bad sform": rterror;
};
// run_body — evaluate a sequence of forms, returning the last value. if (sf == sform.QUOTE) {
fn run_body(forms: *value, e: **env) (*value | rterror) = { if (rest.kind != valkind.CONS) {
let result: *value = vnil(); return "quote: missing arg": rterror;
let cur: *value = forms; };
for (cur.kind == valkind.CONS) { return rest.car;
result = eval(cur.car, e)?;
cur = cur.cdr;
};
return result;
};
// apply — call a BUILTIN or LAMBDA with already-evaluated args.
fn apply(callee: *value, xs: []*value, e: **env) (*value | rterror) = {
if (callee.kind == valkind.BUILTIN) {
return apply_builtin(callee.ival: i32, xs)?;
};
if (callee.kind == valkind.LAMBDA) {
// Extend the lambda's captured env with one frame per param.
let inner: *env = callee.envp;
let p: *value = callee.car;
let i: i32 = 0;
for (p.kind == valkind.CONS) {
if (i >= xs.len) { return "lambda: too few args": rterror; };
let nm: *value = p.car;
if (nm.kind != valkind.SYM) { return "lambda: bad param": rterror; };
let f: *env = alloc(env{ sid = nm.sid, val = xs[i], next = inner });
inner = f;
p = p.cdr;
i += 1;
}; };
if (i != xs.len) { return "lambda: too many args": rterror; }; if (sf == sform.IF) {
let pe: *env = inner; if (list_len(rest) < 2) {
return run_body(callee.cdr, &pe)?; return "if: need cond + then": rterror;
};
let cnd: *value = rest.car;
let thn: *value = rest.cdr.car;
let cv = eval(cnd, &cure)?;
if (truthy(cv)) {
v = thn;
continue;
};
let elsep: *value = rest.cdr.cdr;
if (elsep.kind == valkind.CONS) {
v = elsep.car;
continue;
};
return vnil();
};
if (sf == sform.DEFINE) {
if (list_len(rest) != 2) {
return "define: (define name expr)": rterror;
};
let nameval: *value = rest.car;
if (nameval.kind != valkind.SYM) {
return "define: name must be symbol": rterror;
};
let body: *value = rest.cdr.car;
let bv = eval(body, &cure)?;
if (tailed) {
env_define(&cure, nameval.sid, bv);
} else {
env_define(ein, nameval.sid, bv);
cure = *ein;
};
// Recursive-lambda tie-back: prepend a self-binding
// frame to the captured env so `(fact …)` inside
// fact's body resolves. Earlier versions clobbered
// `bv.envp` with `*e`, which wiped out any non-global
// env that closures (e.g. `(adder 5)` returning
// `(lambda (x) (+ x k))`) had captured.
if (bv.kind == valkind.LAMBDA) {
let frame: *env = alloc(env{
sid = nameval.sid,
val = bv,
next = bv.envp,
});
bv.envp = frame;
};
return vnil();
};
if (sf == sform.SETBANG) {
if (list_len(rest) != 2) {
return "set!: (set! name expr)": rterror;
};
let nameval: *value = rest.car;
if (nameval.kind != valkind.SYM) {
return "set!: name must be symbol": rterror;
};
let body: *value = rest.cdr.car;
let bv = eval(body, &cure)?;
env_set(cure, nameval.sid, bv)?;
return bv;
};
if (sf == sform.LAMBDA) {
if (list_len(rest) < 2) {
return "lambda: (lambda (params) body...)": rterror;
};
let params: *value = rest.car;
let body: *value = rest.cdr;
return vlambda(params, body, cure);
};
if (sf == sform.LET) {
// (let ((x v) (y w) ...) body...). Bindings see the
// outer scope; the body sees `inner`.
if (list_len(rest) < 2) {
return "let: (let ((b ...)) body)": rterror;
};
let binds: *value = rest.car;
let body: *value = rest.cdr;
let inner: *env = cure;
let bcur: *value = binds;
for (bcur.kind == valkind.CONS) {
let pair: *value = bcur.car;
if (list_len(pair) != 2) {
return "let: bad binding": rterror;
};
let nm: *value = pair.car;
if (nm.kind != valkind.SYM) {
return "let: name must be sym": rterror;
};
let val = eval(pair.cdr.car, &cure)?;
let f: *env = alloc(env{
sid = nm.sid, val = val, next = inner,
});
inner = f;
bcur = bcur.cdr;
};
cure = inner;
tailed = true;
// All-but-last in non-tail; last via loop jump.
let bf: *value = body;
for (bf.cdr.kind == valkind.CONS) {
eval(bf.car, &cure)?;
bf = bf.cdr;
};
v = bf.car;
continue;
};
if (sf == sform.BEGIN) {
if (rest.kind != valkind.CONS) { return vnil(); };
let bf: *value = rest;
for (bf.cdr.kind == valkind.CONS) {
eval(bf.car, &cure)?;
bf = bf.cdr;
};
v = bf.car;
continue;
};
// Normal application: evaluate head, then args, dispatch.
let callee: *value = eval(head, &cure)?;
// Inline the args walk: a separate `(slice | rterror)`
// return loses xs.len through the wwstage cgen's 3-reg
// tagged-union convention (AX=tag, DX=ptr, CX=cap — len
// is computed into BX and dropped). Keeping the slice
// strictly local sidesteps that.
let xs: []*value;
xs.ptr = nil;
xs.len = 0;
xs.cap = 0;
let acur: *value = rest;
for (acur.kind == valkind.CONS) {
let av = eval(acur.car, &cure)?;
append(xs, av);
acur = acur.cdr;
};
if (callee.kind == valkind.BUILTIN) {
return apply_builtin(callee.ival: i32, xs)?;
};
if (callee.kind == valkind.LAMBDA) {
// Extend the lambda's captured env with one frame
// per param, then tail-jump into the body.
let inner: *env = callee.envp;
let p: *value = callee.car;
let i: i32 = 0;
for (p.kind == valkind.CONS) {
if (i >= xs.len) {
return "lambda: too few args": rterror;
};
let nm: *value = p.car;
if (nm.kind != valkind.SYM) {
return "lambda: bad param": rterror;
};
let f: *env = alloc(env{
sid = nm.sid, val = xs[i], next = inner,
});
inner = f;
p = p.cdr;
i += 1;
};
if (i != xs.len) {
return "lambda: too many args": rterror;
};
cure = inner;
tailed = true;
let bod: *value = callee.cdr;
for (bod.cdr.kind == valkind.CONS) {
eval(bod.car, &cure)?;
bod = bod.cdr;
};
v = bod.car;
continue;
};
return "not callable": rterror;
}; };
return "not callable": rterror; // Unreachable — every path inside the loop returns or continues.
return vnil();
}; };
// ---- printer --------------------------------------------------------- // ---- printer ---------------------------------------------------------

27
examples/lisp/test_tco.lisp Normal file
View File

@@ -0,0 +1,27 @@
; test_tco.lisp — proper tail calls. Each form below would have blown
; the C stack pre-TCO (segfault around ~25k recursive calls). The
; counts here are deliberately past that line and across all three
; tail positions: if-tail, begin-tail, let-tail.
; if-tail: classic accumulator countdown.
(define spin
(lambda (n a)
(if (= n 0) a (spin (- n 1) (+ a 1)))))
(spin 30000 0)
; begin-tail: last form of a begin block is the recursive call.
(define bspin
(lambda (n a)
(if (= n 0) a (begin a (bspin (- n 1) (+ a 1))))))
(bspin 30000 0)
; let-tail: last form of a let body is the recursive call.
(define lspin
(lambda (n a)
(if (= n 0) a (let ((m (- n 1))) (lspin m (+ a 1))))))
(lspin 30000 0)
; gcd: tail call from the else branch of an if (already tested by
; lisp_test, kept here as a nice short demo).
(define gcd (lambda (a b) (if (= b 0) a (gcd b (mod a b)))))
(gcd 1071 462)