examples: lisp — proper tail calls in eval
This commit is contained in:
@@ -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
|
||||
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)
|
||||
|
||||
- **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
|
||||
`--pages-as-heap=yes`. Per-top-level-form arena reset would cut
|
||||
this by ~100× — see the closing note in `repl()` for the hook
|
||||
point.
|
||||
- **No tail-call optimization.** Recursion grows the C-side stack
|
||||
one frame per Lisp call. `(spin 100000 0)` will eventually stack-
|
||||
overflow even though it's tail-recursive in source.
|
||||
point. Note: `rt_alloc` is one mmap syscall per call returning a
|
||||
whole 4KB page, so even tail-recursive loops are bottlenecked on
|
||||
allocation, not on Lisp work — `(spin 100000 0)` runs in ~4s.
|
||||
- **No bigints.** `i64` wraps silently on overflow. `(fact 21)`
|
||||
rolls over.
|
||||
- **Float printing is fixed `%.6f`.** `1.0` prints as `1.000000`.
|
||||
|
||||
@@ -33,7 +33,7 @@ lisp_test: lisp_test.ww lispcore.ww
|
||||
# Demo programs in tree. `make demo` runs every test_*.lisp through
|
||||
# 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.
|
||||
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
|
||||
@for f in $(DEMOS); do \
|
||||
|
||||
@@ -263,6 +263,18 @@ export fn main() i32 = {
|
||||
check_int ("let-product", "(let ((a 3) (b 4)) (* a b))", 12i64, 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 ----
|
||||
check_float("float-add", "(+ 1.5 2.5)", 4.0, ep);
|
||||
check_float("float-mul", "(* 0.5 0.5)", 0.25, ep);
|
||||
|
||||
@@ -6,7 +6,7 @@
|
||||
//
|
||||
// What this exercises across the ww language:
|
||||
// - tagged-union returns with many variants:
|
||||
// (*value | rterror) from eval / apply
|
||||
// (*value | rterror) from eval
|
||||
// (*value | parserr | eof) from the parser
|
||||
// - `match` with `yield` so the REPL dispatch is one expression
|
||||
// - `?` to propagate the error variant up the call chain
|
||||
@@ -983,9 +983,26 @@ fn apply_builtin(id: i32, xs: []*value) (*value | rterror) = {
|
||||
|
||||
// ---- eval -------------------------------------------------------------
|
||||
|
||||
export fn eval(v: *value, e: **env) (*value | rterror) = {
|
||||
// Self-evaluating atoms — every variant of `valkind` that isn't
|
||||
// SYM (lookup) or CONS (application).
|
||||
// eval — drive the evaluation of a single form. Most paths are ordinary
|
||||
// recursion; tail positions (IF branch, last form of BEGIN/LET/lambda
|
||||
// body, and a tail call into another lambda) re-enter this loop with a
|
||||
// new (v, cure) instead of recursing, so deep tail-recursive Lisp code
|
||||
// doesn't grow the C stack one frame per call.
|
||||
//
|
||||
// Scope handling. `ein` is the *caller's* env slot. While evaluation
|
||||
// stays in the caller's scope (top-level work, IF, BEGIN), `define`/
|
||||
// `set!` mutate via `ein` so a top-level define lands in the caller's
|
||||
// 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; };
|
||||
@@ -995,74 +1012,65 @@ export fn eval(v: *value, e: **env) (*value | rterror) = {
|
||||
if (v.kind == valkind.LAMBDA) { return v; };
|
||||
|
||||
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.
|
||||
// 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;
|
||||
|
||||
let sf: sform = sform.NONE;
|
||||
if (head.kind == valkind.SYM) {
|
||||
let sf: sform = classify_sform(head.sid);
|
||||
if (sf != sform.NONE) {
|
||||
return eval_sform(sf, rest, e)?;
|
||||
};
|
||||
sf = classify_sform(head.sid);
|
||||
};
|
||||
|
||||
let callee: *value = eval(head, e)?;
|
||||
|
||||
// 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 cur: *value = rest;
|
||||
for (cur.kind == valkind.CONS) {
|
||||
let av = eval(cur.car, e)?;
|
||||
append(xs, av);
|
||||
cur = cur.cdr;
|
||||
if (sf == sform.QUOTE) {
|
||||
if (rest.kind != valkind.CONS) {
|
||||
return "quote: missing arg": rterror;
|
||||
};
|
||||
|
||||
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; };
|
||||
if (sf == 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 cv = eval(cnd, &cure)?;
|
||||
if (truthy(cv)) {
|
||||
v = thn;
|
||||
continue;
|
||||
};
|
||||
let elsep: *value = rest.cdr.cdr;
|
||||
if (elsep.kind == valkind.CONS) {
|
||||
return eval(elsep.car, e)?;
|
||||
v = elsep.car;
|
||||
continue;
|
||||
};
|
||||
return vnil();
|
||||
};
|
||||
case sform.DEFINE: {
|
||||
if (list_len(rest) != 2) { return "define: (define name expr)": rterror; };
|
||||
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; };
|
||||
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.
|
||||
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,
|
||||
@@ -1073,85 +1081,136 @@ fn eval_sform(sf: sform, rest: *value, e: **env) (*value | rterror) = {
|
||||
};
|
||||
return vnil();
|
||||
};
|
||||
case sform.SETBANG: {
|
||||
if (list_len(rest) != 2) { return "set!: (set! name expr)": rterror; };
|
||||
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; };
|
||||
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)?;
|
||||
let bv = eval(body, &cure)?;
|
||||
env_set(cure, nameval.sid, bv)?;
|
||||
return bv;
|
||||
};
|
||||
case sform.LAMBDA: {
|
||||
if (list_len(rest) < 2) { return "lambda: (lambda (params) body...)": rterror; };
|
||||
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, *e);
|
||||
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;
|
||||
};
|
||||
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 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, e)?;
|
||||
let f: *env = alloc(env{ sid = nm.sid, val = val, next = inner });
|
||||
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;
|
||||
cur = cur.cdr;
|
||||
bcur = bcur.cdr;
|
||||
};
|
||||
let inscope: *env = inner;
|
||||
let pe: *env = inscope;
|
||||
return run_body(body, &pe)?;
|
||||
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;
|
||||
};
|
||||
case sform.BEGIN: {
|
||||
return run_body(rest, e)?;
|
||||
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;
|
||||
};
|
||||
return "bad sform": rterror;
|
||||
v = bf.car;
|
||||
continue;
|
||||
};
|
||||
|
||||
// run_body — evaluate a sequence of forms, returning the last value.
|
||||
fn run_body(forms: *value, e: **env) (*value | rterror) = {
|
||||
let result: *value = vnil();
|
||||
let cur: *value = forms;
|
||||
for (cur.kind == valkind.CONS) {
|
||||
result = eval(cur.car, e)?;
|
||||
cur = cur.cdr;
|
||||
};
|
||||
return result;
|
||||
// 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;
|
||||
};
|
||||
|
||||
// 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.
|
||||
// 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; };
|
||||
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 });
|
||||
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; };
|
||||
let pe: *env = inner;
|
||||
return run_body(callee.cdr, &pe)?;
|
||||
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;
|
||||
};
|
||||
// Unreachable — every path inside the loop returns or continues.
|
||||
return vnil();
|
||||
};
|
||||
|
||||
// ---- printer ---------------------------------------------------------
|
||||
|
||||
|
||||
27
examples/lisp/test_tco.lisp
Normal file
27
examples/lisp/test_tco.lisp
Normal 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)
|
||||
Reference in New Issue
Block a user