From fedaec3e1801f643e0bb82624324614e6045ae78 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 09:17:56 +0700 Subject: [PATCH] recur is checked, which is the reason to prefer it over tail calls MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit There is no TCO here and recur is not a cheaper substitute for one: the compiler verifies the call is in the loop body's tail position, so the mistake is a compile error where it was written rather than a stack overflow somewhere else. A loop is a let, a While whose condition is true, and two jumps — emit.ml is untouched, and the barrier question recur asks is the one labelled break already answered. Tail position is a permission that is withdrawn at the top of check, the same read-and-withdraw defer_ok does, handed back only by a block's last form, both arms of an if and a match arm. So nothing enumerates the forms that are not tails, which a pre-pass over the Ast would have had to, and would have had to keep doing. loop is also a barrier for break and continue, which is added rather than inherited: a loop answers with the value of its body and a jump out has no value to give. That is also why it takes no label. A while inside a loop keeps its own break. Two things the shape forced. A loop binding is a plain name, because destructuring would make recur's argument count unreadable off the binding vector. And in_loop's "moves a value bound outside the loop" rule had to be told about the loop's own names, or (loop [v (vec-new i32)] ...) would have been refused for doing the ordinary thing. --- BUILT.md | 80 +++++++++++++ NEXT.md | 24 ++-- lib/ast.ml | 10 ++ lib/check.ml | 242 +++++++++++++++++++++++++++++++++++---- lib/load.ml | 7 ++ lib/parse.ml | 43 ++++++- lib/tast.ml | 8 +- test/programs/recur.flan | 90 +++++++++++++++ test/test_acceptance.ml | 6 + test/test_flan.ml | 45 ++++++++ 10 files changed, 521 insertions(+), 34 deletions(-) create mode 100644 test/programs/recur.flan diff --git a/BUILT.md b/BUILT.md index 8b7cad6..0e03483 100644 --- a/BUILT.md +++ b/BUILT.md @@ -3006,6 +3006,86 @@ and the function still has to answer. The loop-with-a-sentinel-flag shape that b in the prelude. The two compiler-emitted retry loops in `check.ml` are that shape, and they are the one place it cannot help: their sentinel is set inside a `restart-case` body, which is a barrier. +## `loop` and `recur`, and why `recur` is better than tail calls and not only cheaper + +There is no TCO anywhere in this compiler — nothing emits a tail call, and `plan.org` mentions them only as something +the backend choice *could* control. `recur` is the answer, and the reason is not that it is cheap. **It is checked.** +The compiler verifies the call is in the loop body's tail position and turns it into a jump, so writing it in the +wrong place is a compile error at the place it was written. Under silent TCO the same mistake compiles and is a stack +overflow at run time, with a backtrace pointing at whatever ran out of stack rather than at what was wrong. Clojure +adopted `recur` because the JVM lacks TCO; it turned out to be the better design, and it is the better design here for +the same reason. + +What it does **not** give is mutual recursion between two functions. That needs real tail calls and is out of scope, +and the refusal for a `recur` outside any loop says so in as many words. + +### Nothing new reaches the backend + +`(loop [x 0 acc 1] body ...)` is a `let` over the names, a `While` whose condition is `true`, and two jumps. `emit.ml` +is untouched. That is the whole argument for building this on the labelled `break`/`continue` that landed just before +it: the machinery was already there, and the question `recur` asks — *may this jump cross that* — is the question +`break` already answers. + +- **A loop answers with the value of its body.** The result goes into a slot of its own on the way out and is read + after the loop, so an accumulator comes back without a mutable local and without a sentinel flag. +- **A `Unit` body needs no slot**, and a **`Never` body needs neither slot nor break** — a body every path of which + recurs or returns never falls off the end, so there is nothing to break to and nothing to store. +- **`Set` of a `Never` body is safe**, which is the one thing that had to be checked rather than assumed. `emit` + closes a block at its terminator and drops what follows (`ins` tests `f.live`), and `Tast.Set` resolves the place + before the value, where a local's place is an address with no instruction behind it. So when the body ends in a + jump, the store is simply never written. +- **`recur` rebinds every name at once.** The new values go into temporaries and are written afterwards, so + `(recur y x)` swaps. Interleaved writes would give `y y`, and `recur.flan` asserts the swap for exactly that + reason. + +`tast.ml` said a `While` the checker *invents* contains no jumps, because the depths would be minted against a stack +it is not on. `check_loop`'s `While` is the exception, and it is the exception because it is pushed on `ctx.loops` +like any other: being invented was never the property that mattered, being on the stack is. The comment now says so. + +### Tail position, as a permission that is withdrawn + +The alternative was a pre-pass over the `Ast` marking tail positions, which would have to enumerate every constructor +and stay in step with the type forever. Instead `ctx.tail` is read and withdrawn at the top of `check`, the same +read-and-withdraw `defer_ok` already does and for the same reason: nothing reached from here inherits it. Three forms +hand it back on, and they are the only three that pass a tail through — the last form of a `block`, both arms of an +`if` (including the one-armed `when` shape, which is how nearly every loop is written), and a `match` arm. Everything +else is non-tail **by construction**, and no walk has to list the cases that are not. + +The bodies of `restart-case` and `handler-bind` are tails semantically and are deliberately not given the permission +here — the barrier below refuses them anyway, and with a better sentence. + +### `loop` is a barrier for `break` and `continue` + +`lentry` gains `Lrecur`, carrying the slot and type of each of the loop's names. It is the target a `recur` resolves +to, by the same walk over the same stack `break` makes, refusing on the same barriers — `handler-bind`, `restart-case` +and a `defer`'s forms — rather than by a second mechanism. + +It is **also a barrier itself**, and that is a restriction added here rather than one inherited. A loop answers with +the value of its body; a `break` out of one would have to produce that value from somewhere and there is nowhere, and +a `continue` would re-run the body without rebinding anything. So both are refused, and the message names the fix +(*answer with the value, or use a while*). A `while` written **inside** a loop sits below the entry and keeps its own +perfectly good break, which is the relative rule doing the job it was built for. + +Two consequences fall out of this and are worth stating: + +- **`loop` takes no label**, because there is nothing for a label to name. A leading keyword is caught in `parse.ml` + rather than left to `bindings`, which would have complained that `:outer` has no value. +- **A `recur` can only ever be at depth 0 in practice.** A loop body is not a tail position, so no `recur` is ever + written inside a nested loop. `recur_target` counts the depth anyway rather than assuming it, because the count is + what `emit` indexes. + +### Two small things the shape forced + +**A loop binding is a plain name.** `let`'s `bindings` expands a destructuring pattern into several bindings from one +form, and then `recur`'s argument count would no longer be readable off the binding vector. `loop_bindings` is the +pairs without the patterns, and it refuses a duplicate name. + +**The move tracker had to be told.** `in_loop` refuses a body that moves a binding declared outside the loop, because +the second iteration would use what the first gave away. A loop's own names are bound before the entry is pushed — +their initial values are evaluated once, outside — so they would have landed in that set, and +`(loop [v (vec-new i32)] ...)` would have been refused for doing the ordinary thing. `recur` writes every one of them +on the way round, so the rule is not about them; `in_loop` takes the loop's own slots and excludes them. + ## `(array 4 rl/Vector2)`, and the one position with no type slot `[4 T]` is the ordinary type spelling and is unchanged. It already works everywhere a type is expected — `(defvar diff --git a/NEXT.md b/NEXT.md index 963e2b1..4bb0aee 100644 --- a/NEXT.md +++ b/NEXT.md @@ -826,7 +826,7 @@ destination is always honest about what it is. Drop Clojure's `:eduction` branch — that is the pass-around case, and the one part that would need runtime machinery. -## Queued: `loop`/`recur` (the return type is done) +## ~~Queued: `loop`/`recur` (the return type is done)~~ — **landed** ~~**1. A `defn` must always state its return type, and unit is written `()`.**~~ **Done.** See *The return type is the slot, and unit is `()`* in [`BUILT.md`](BUILT.md). @@ -857,18 +857,20 @@ python3 tools/unit-return.py --in-html web/index.html reports exactly six sites, all in `test_flan.ml`, which spell the refused forms *on purpose* so the refusals can be tested. Read the diff of every non-`.flan` file — BUILT.md lists what the script can and cannot see. -**2. `loop` and `recur`.** Both are already refused by name in `parse.ml`. There is **no TCO** — nothing emits tail -calls, and `plan.org` mentions them only as something the current backend choice *could* control (LLVM's `musttail` is -there if wanted). +~~**2. `loop` and `recur`.**~~ **Done.** See *`loop` and `recur`, and why `recur` is better than tail calls and not +only cheaper* in [`BUILT.md`](BUILT.md). `emit.ml` is untouched: a loop is a `let`, a `While` whose condition is +`true`, and two jumps, and the barrier question `recur` asks is the one labelled `break` already answered. -`recur` is the better answer than silent TCO, and not only because it is cheaper. **It is checked**: the compiler -verifies the call is in tail position and turns it into a jump, so breaking tail position is a compile error rather -than a stack overflow at run time. Clojure adopted it because the JVM lacks TCO and it turned out to be the better -design. +Three things the plan did not anticipate, each written up there. **Tail position is a permission that is withdrawn** +rather than a pre-pass over the `Ast` — `ctx.tail` is read and cleared at the top of `check`, exactly as `defer_ok` +is, and handed back only by the three forms that pass a tail through, so nothing has to enumerate the forms that do +not. **`loop` is itself a barrier** for `break` and `continue`, which is a restriction added rather than inherited: a +loop answers with the value of its body, so a jump out of one has no value to give, and therefore `loop` also takes +no label. And **the move tracker had to be told about the loop's own names**, which are bound before the loop entry is +pushed and would otherwise have tripped the "moves a value bound outside the loop" rule on the ordinary case. -Cheap here — a jump to the top of a `loop`, which is the machinery `while` and the new labelled `break`/`continue` -already have. What it does **not** give is mutual recursion between two functions; that needs real tail calls, and is -a separate question if it is ever wanted. +Still not given, and still out of scope: **mutual recursion between two functions.** That needs real tail calls. The +refusal for a `recur` outside any loop says so by name. ## The next batch, in order diff --git a/lib/ast.ml b/lib/ast.ml index baf9c3f..9790e56 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -43,6 +43,16 @@ and expr_kind = (* The [string option] is a loop label: [(while :outer c ...)]. A keyword in that position is unambiguous because a loop condition is never one. *) | While of string option * expr * expr list + (* [(loop [x 0 acc 1] body ...)] and [(recur v ...)]. A loop answers with the + value of its body; a [recur] rebinds every one of the loop's names at once + and jumps back to the top. It is not a tail call and there is no tail-call + elimination anywhere in this compiler — the checker refuses a [recur] that + is not in the loop body's tail position, so what would be a stack overflow + under silent TCO is a compile error here. Each name takes a plain symbol: + a destructuring pattern would turn one name into several and [recur]'s + argument count could no longer be read off the binding vector. *) + | Loop of (string * expr) list * expr list + | Recur of expr list | Return of expr option (* Leaving a loop, and starting its next iteration. The [string option] is the label of the loop meant, and [None] means the innermost. Neither is a diff --git a/lib/check.ml b/lib/check.ml index 2061a37..3c3ff75 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -143,6 +143,12 @@ let declared_note env name = it can name a loop outside it. *) type lentry = | Lloop of string option + (* A [(loop ...)], carrying the slot and type of each of its names so that a + [recur] can rebind them. It is *also* a barrier for [break] and + [continue]: a loop answers with the value of its body, so a jump that left + one would have no value to give. A [while] written inside a loop is + unaffected, which is the relative rule doing its job again. *) + | Lrecur of (int * Types.t) list | Lbarrier of string (* Per-function state. Slots are never reused, so [slots] is also the frame @@ -205,6 +211,13 @@ type ctx = { of why they are not a goto — a label that names no loop on this list is refused, so control can only leave a loop it is already in. *) mutable loops : lentry list; + (* True where this form's value is the value of the enclosing [loop]'s body, + which is the only place a [recur] may stand. Read and withdrawn at the top + of [check] exactly as [defer_ok] is, and granted again by the three forms + that pass a tail through: the last form of a block, both arms of an [if], + and a [match] arm. Everything else is therefore non-tail by construction, + and no walk has to enumerate the cases that are not. *) + mutable tail : bool; (* True inside a [defer]'s forms. A defer is the cleanup a transfer runs on its way out (§5), so a transfer *starting* there has no answer: this function's defers are already half run and the first transfer's target is @@ -763,7 +776,7 @@ let hash_ty = Types.Int Types.U64 none of these is a body anyone wrote. *) let invented_ctx env ret = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; - defers = []; outer = []; outer_what = None; in_frames = None; loops = []; + defers = []; outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } @@ -964,6 +977,11 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = grant it again before the *next* form rather than once around the body. *) let defer_ok = ctx.defer_ok in ctx.defer_ok <- false; + (* The same read-and-withdraw, for the same reason: a [recur] is in tail + position only if *this* form was, and nothing reached from here inherits + it unless the arm below hands it on deliberately. *) + let tail = ctx.tail in + ctx.tail <- false; match e.Ast.e with | Ast.Int n -> int_literal loc ~want n | Ast.Byte b -> int_literal loc ~want ~default:Types.U8 (Int64.of_int b) @@ -1002,11 +1020,13 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.Quote _ -> unimplemented loc "a quoted symbol (restart names)" 6 | Ast.Var name -> var ctx loc ~want name - | Ast.Do body -> block ctx ?want loc body + | Ast.Do body -> ctx.tail <- tail; block ctx ?want loc body (* [defer_ok] rides through: a [let] at the top level of a function body has - exactly the function's extent, and so does a [let] nested inside one. *) - | Ast.Let (bs, body) -> check_let ctx ?want ~defer_ok loc bs body - | Ast.If (c, t, e') -> check_if ctx ?want loc c t e' + exactly the function's extent, and so does a [let] nested inside one. + [tail] rides through for the same shape of reason: a [recur] written as + the last form of a [let] inside a loop body is in the loop's tail. *) + | Ast.Let (bs, body) -> check_let ctx ~tail ?want ~defer_ok loc bs body + | Ast.If (c, t, e') -> check_if ctx ~tail ?want loc c t e' | Ast.While (label, c, body) -> let c = check ctx ~want:Types.Bool c in let body = in_loop ctx ?label (fun () -> @@ -1017,6 +1037,12 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = expect loc ~want (mk loc Types.Unit (Tast.While (c, body, []))) (* [Never], as [exit] and [return] are: nothing after one of these runs, and an [if] arm that ends in a break does not have to agree with the other. *) + (* (loop [x 0 acc 1] body ...) — a loop that answers with the value of its + body, and the only place a [recur] may stand. Not an IR node: it is a + [let] over the names, a [While] whose condition is [true], and a jump. + See [check_loop]. *) + | Ast.Loop (bs, body) -> check_loop ctx ?want loc bs body + | Ast.Recur args -> check_recur ctx ~tail loc args | Ast.Break label -> mk loc Types.Never (Tast.Break (loop_target ctx loc "break" label)) | Ast.Continue label -> @@ -1070,7 +1096,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.ArrayOf t -> let ty = resolve ctx.env t in expect loc ~want (mk loc ty (Tast.Zero ty)) - | Ast.Match (scrutinee, arms) -> check_match ctx ?want loc scrutinee arms + | Ast.Match (scrutinee, arms) -> check_match ctx ~tail ?want loc scrutinee arms | Ast.Call (head, args) -> check_call ctx ~want loc head args | Ast.Unwrap (Ast.Usome, v) -> (* Unwrap Some, else early-return None from the enclosing function, so the @@ -1343,12 +1369,18 @@ and block ctx ?want ?(defer_ok = false) loc body = match body with | [] -> expect loc ~want (unit_at loc) | _ -> + (* A block's tail is its last form and nothing else. Callers that must not + pass one on need do nothing: [check] withdrew it before they were + reached, so [tail] is already false here for all of them. *) + let tail = ctx.tail in let rec go = function | [ last ] -> ctx.defer_ok <- defer_ok; + ctx.tail <- tail; let l = check ctx ?want last in [ l ], l.Tast.ty | x :: rest -> ctx.defer_ok <- defer_ok; + ctx.tail <- false; let x = check ctx x in let rest, ty = go rest in x :: rest, ty | [] -> assert false @@ -1402,7 +1434,7 @@ and check_fn ctx ~want loc (params : string list) body = let fctx = { env = ctx.env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; outer = ctx.scope; - outer_what = Some "an fn"; in_frames = None; loops = []; + outer_what = Some "an fn"; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = ctx.owner } in @@ -1478,7 +1510,7 @@ and check_handler_bind ctx ?want loc clauses body = the enclosing one. *) let hctx = { env = ctx.env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; - scope = []; defers = []; outer = ctx.scope; outer_what = Some "a handler"; in_frames = None; loops = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } + scope = []; defers = []; outer = ctx.scope; outer_what = Some "a handler"; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } in (* The condition crosses as a pointer, because the handler runs while the signalling frame is still alive and there is nothing to copy. @@ -1630,7 +1662,7 @@ and register_defer ctx loc forms = (* [defer_ok] says whether *this* let has the function's extent. If it does, so does every form in its body, including a nested let — which is why the flag is handed to the body rather than consumed here. *) -and check_let ctx ?want ?(defer_ok = false) loc bs body = +and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = scoped ctx (fun () -> let bs = map_lr @@ -1647,6 +1679,8 @@ and check_let ctx ?want ?(defer_ok = false) loc bs body = (slot, v)) bs in + (* After the bindings, because checking each of them withdrew it. *) + ctx.tail <- tail; let body = block ctx ?want ~defer_ok loc body in mk loc body.Tast.ty (Tast.Let (bs, [ body ]))) @@ -1659,13 +1693,20 @@ and check_let ctx ?want ?(defer_ok = false) loc bs body = iteration would use what the first moved, and a set that is merged once at the end of the body sees one move, not two. So it is a rule rather than an inference, stated as one. *) -and in_loop ctx ?label f = - let outer_slots = List.map (fun (_, b) -> b.slot) ctx.scope in +and in_loop ctx ?label ?entry ?(fresh = []) f = + let outer_slots = + List.filter (fun s -> not (List.mem s fresh)) + (List.map (fun (_, b) -> b.slot) ctx.scope) + in let before = ctx.dead in (* The loop goes on the stack before the body is checked and comes off after, so a [break] inside it can see it and one outside it cannot. *) let loops = ctx.loops in - ctx.loops <- Lloop label :: loops; + (* [fresh] is a [loop]'s own names. They are bound before the entry is pushed + — their initial values are evaluated once, outside — but [recur] writes + every one of them on the way round, so the next iteration never sees what + this one gave away and the rule below is not about them. *) + ctx.loops <- (match entry with Some e -> e | None -> Lloop label) :: loops; (* Named so that a defer written in here is refused as "a loop body" rather than as a nested form: the reason is specific — it would fire once at function exit rather than once per iteration — and the message says it. *) @@ -1705,6 +1746,23 @@ and loop_target ctx loc verb label = | None -> depth | Some l when name = Some l -> depth | Some _ -> go (depth + 1) rest) + (* A [loop] answers with the value of its body. A jump out of one would + have to produce that value from somewhere and there is nowhere, so it is + a barrier like the others, named as what it is. A [while] written inside + a loop sits below this entry and keeps its own break. *) + | Lrecur _ :: _ -> + (match label with + | None -> + fail loc + "%s is not allowed here: the nearest loop is a (loop ...), which \ + answers with the value of its body, so leaving it this way would \ + have no value to give. Answer with the value, or use a while" + verb + | Some l -> + fail loc + "%s :%s would leave a (loop ...), which it may not: a loop answers \ + with the value of its body and a jump out of one has no value to \ + give" verb l) | Lbarrier what :: rest -> (* Crossing it would skip whatever the construct does on the way out — the handler or restart frames it pushed, or, for a defer, would jump @@ -1754,13 +1812,152 @@ and check_dotimes ctx ~want loc label name count body = expect loc ~want (mk loc Types.Unit (Tast.Let ([ (i, zero); (limit, count) ], [ loop ])))) -and check_if ctx ?want loc c t e = +(* ── (loop [...] ...) and (recur ...) ─────────────────────────────────── + + A loop is a [let] over its names, a [While] whose condition is [true], and + two jumps: [recur] rebinds every name and continues, and falling off the end + of the body breaks. Nothing new reaches the backend, which is the whole + argument for [recur] over tail calls — the machinery is the one [while] and + the labelled [break]/[continue] already needed. + + **The value.** A loop answers with the value of its body, so the result is + written into a slot of its own on the way out and read after the loop. A + body that is [Unit] needs no slot, and a body that is [Never] — one that + only ever recurs or returns — needs neither a slot nor the break, because + nothing falls off the end of it. + + **Why [Set] of a [Never] body is safe.** [emit] closes a block at its + terminator and drops what follows ([ins] checks [f.live]), so when the body + ends in a jump the store is simply never written. The one ordering that + matters is inside [Tast.Set]: the place is resolved before the value, and a + local's place is an address with no instruction behind it. + + **Why the invented [While] may carry jumps.** [tast.ml] says a [While] the + checker invents contains none, because the depths it would carry were minted + against a stack it is not on. This one is different and the difference is + the licence: it is pushed on [ctx.loops] like any other, so the [Break 0] + below and every [continue] a [recur] mints count from the same stack [emit] + indexes. *) +and check_loop ctx ?want loc bs body = + scoped ctx (fun () -> + (* Each initial value is evaluated once, before the loop, exactly as a + [let]'s is and as [dotimes]'s bound is. *) + let inits = + map_lr + (fun (n, v) -> + let v = check ctx v in + (match v.Tast.ty with + | Types.Unit | Types.Never -> + fail v.Tast.loc "%s would be bound to %s, which is not a value" n + (Types.to_string v.Tast.ty) + | _ -> ()); + (n, v)) + bs + in + let binds = + List.map (fun (n, v) -> (bind ctx n v.Tast.ty ~assignable:true, v)) inits + in + let names = List.map (fun (slot, v) -> (slot, v.Tast.ty)) binds in + (* The singleton is [in_loop]'s doing: it sits in this recursive group and + is therefore monomorphic, and every other caller hands it a list. *) + let tbody = + match + in_loop ctx ~entry:(Lrecur names) ~fresh:(List.map fst binds) (fun () -> + [ scoped ctx (fun () -> + (* The body's last form is the loop's tail, which is the only + place a [recur] may stand. [block] distributes it. *) + ctx.tail <- true; + block ctx ?want loc body) ]) + with + | [ b ] -> b + | _ -> assert false + in + let ty = tbody.Tast.ty in + let yes = mk loc Types.Bool (Tast.Bool true) in + let leave = mk loc Types.Never (Tast.Break 0) in + let inner, result = + if ty = Types.Never then ([ tbody ], None) + else if ty = Types.Unit then ([ tbody; leave ], None) + else + let r = fresh_slot ctx ty in + ([ mk loc Types.Unit (Tast.Set (Tast.Plocal r, tbody)); leave ], Some r) + in + let loop = mk loc Types.Unit (Tast.While (yes, inner, [])) in + match result with + | None -> expect loc ~want (mk loc ty (Tast.Let (binds, [ loop ]))) + | Some r -> + expect loc ~want + (mk loc ty + (Tast.Let (binds @ [ (r, mk loc ty (Tast.Zero ty)) ], + [ loop; mk loc ty (Tast.Local r) ])))) + +(* Which loop a [recur] means, and what it has to rebind. The same walk + [break] and [continue] make, over the same stack and refusing on the same + barriers — [recur] asks "may this jump cross that" and gets the answer that + was already settled, not a second mechanism. *) +and recur_target ctx loc = + let rec go depth = function + | [] -> + fail loc + "recur is only allowed inside a (loop ...). There are no tail calls in \ + this compiler, so a function cannot recur into itself and two \ + functions cannot recur into each other — write the repetition as a \ + loop with a recur in its tail" + | Lrecur names :: _ -> (depth, names) + (* Unreachable while the tail rule holds — a loop body is not a tail + position, so no [recur] is ever written inside one — but the depth is + counted rather than assumed, because it is what [emit] indexes. *) + | Lloop _ :: rest -> go (depth + 1) rest + | Lbarrier what :: _ -> + fail loc + "recur would leave %s, which it may not: whatever %s does on the way \ + out would be skipped. Write the loop inside it, or leave with a value \ + and test that after" + what what + in + go 0 ctx.loops + +and check_recur ctx ~tail loc args = + let depth, names = recur_target ctx loc in + (* Checked, which is the whole of why this is better than a silent TCO: a + recur that is not in tail position is a compile error here, where under + tail calls it would have been a stack overflow at run time. *) + if not tail then + fail loc + "recur must be in the tail position of its loop — the last thing the \ + body does, or the last thing in an if, match or let arm that is itself \ + in the tail. Here something would still have to run afterwards, and a \ + recur is a jump back to the top, not a call that returns"; + let want = List.length names and got = List.length args in + if want <> got then + fail loc "this loop binds %d name%s and this recur passes %d" want + (if want = 1 then "" else "s") got; + let vals = List.map2 (fun a (_, ty) -> check ctx ~want:ty a) args names in + (* Every name is rebound at once. The new values go into temporaries first, + so that (recur y x) swaps rather than writing y over x and then reading it + back — the same reason Clojure's recur is simultaneous. *) + let temps = List.map2 (fun v (_, ty) -> (fresh_slot ctx ty, v)) vals names in + let sets = + List.map2 + (fun (t, _) (slot, ty) -> + mk loc Types.Unit + (Tast.Set (Tast.Plocal slot, mk loc ty (Tast.Local t)))) + temps names + in + mk loc Types.Never + (Tast.Let (temps, sets @ [ mk loc Types.Never (Tast.Continue depth) ])) + +and check_if ctx ?(tail = false) ?want loc c t e = let c = check ctx ~want:Types.Bool c in + (* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))] + is how nearly every loop is written, and the branch is still the last + thing the body does. *) + let in_tail f = ctx.tail <- tail; f () in match e with | None -> (* A one-armed if produces Unit whatever the branch evaluates to: there is no value on the missing side. `when` desugars to this. *) - let t = branch ctx (fun () -> check ctx t) in + let t = branch ctx (fun () -> in_tail (fun () -> check ctx t)) in expect loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) | Some e -> (* Both arms start from the same dead set and the union survives: moving in @@ -1769,7 +1966,7 @@ and check_if ctx ?want loc c t e = refused [(if c (free v) (free v))] and allowed the use after a one-armed move, which are the two ways to be wrong here. *) let before = ctx.dead in - let t = branch ctx (fun () -> check ctx ?want t) in + let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in let after_then = ctx.dead in ctx.dead <- before; (* With no expectation the then-branch supplies one for the else-branch, @@ -1779,7 +1976,7 @@ and check_if ctx ?want loc c t e = | Some _ -> want | None -> if t.Tast.ty = Types.Never then None else Some t.Tast.ty in - let e = branch ctx (fun () -> check ctx ?want:ewant e) in + let e = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) in ctx.dead <- after_then @ List.filter (fun (k, _) -> not (List.mem_assoc k after_then)) ctx.dead; @@ -1928,7 +2125,7 @@ and check_arr ctx ~want loc items = an array literal does not satisfy a slice expectation. *) expect loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items)) -and check_match ctx ?want loc scrutinee arms = +and check_match ctx ?(tail = false) ?want loc scrutinee arms = let s = check ctx scrutinee in (* What the arms are alternatives over. An [Option] is a two-case union wearing a special coat, so the two shapes below are the same shape: a set @@ -2035,6 +2232,9 @@ and check_match ctx ?want loc scrutinee arms = List.map (fun (n, ty) -> bind ctx n ty ~assignable:false) binds in + (* Every arm is the tail, exactly as an [if]'s two arms are. + Restored here because checking the scrutinee withdrew it. *) + ctx.tail <- tail; let body = block ctx ?want:!want a.Ast.aloc a.Ast.body in if !want = None && body.Tast.ty <> Types.Never then want := Some body.Tast.ty; @@ -4269,7 +4469,7 @@ let collect env (decls : Ast.decl list) = run without swallowing it. *) let infer (_, v) = (check { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; - outer = []; outer_what = None; in_frames = None; loops = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } v).Tast.ty + outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } v).Tast.ty in let pending = ref (List.rev !untyped) in let rec settle () = @@ -4322,7 +4522,7 @@ let check_finite env = let check_fn env (fn : Ast.fn) : Tast.fn = let params, ret = Hashtbl.find env.fns fn.Ast.name in let ctx = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; - outer = []; outer_what = None; in_frames = None; loops = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; + outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = fn.Ast.name } in List.iter2 (fun (p : Ast.field) ty -> @@ -4425,7 +4625,7 @@ let no_move_only_global loc n (ty : Types.t) = let check_global env (d : Ast.decl) : Tast.global option = let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; - outer = []; outer_what = None; in_frames = None; loops = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } in + outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } in match d.Ast.d with | Ast.Defvar (n, _, init) -> let ty, _ = Hashtbl.find env.globals n in @@ -4589,7 +4789,7 @@ let expression env (e : Ast.expr) : Tast.expr * Types.t array * string option array = let ctx = { env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; - outer = []; outer_what = None; in_frames = None; loops = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } + outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; dead = []; borrow = false; owner = "" } in let t = check ctx e in (t, Array.of_list (List.rev ctx.slot_tys), diff --git a/lib/load.ml b/lib/load.ml index a13550e..fe52b52 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -184,6 +184,11 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = Ast.Let (List.rev bs, List.map (rename_expr owned alias bound) body) | Ast.If (c, t, e') -> Ast.If (go c, go t, Option.map go e') | Ast.While (l, c, body) -> Ast.While (l, go c, gos body) + (* A loop's names are its own and are never imported; its initial + values and its body are ordinary expressions. *) + | Ast.Loop (bs, body) -> + Ast.Loop (List.map (fun (n, v) -> (n, go v)) bs, gos body) + | Ast.Recur args -> Ast.Recur (gos args) (* A loop label is not a top-level name: it is resolved against the loops this form is inside, so an import has nothing to qualify. *) | (Ast.Break _ | Ast.Continue _) as k -> k @@ -377,6 +382,8 @@ let rec expr_uses acc (e : Ast.expr) = gos body | Ast.If (c, t, e') -> go c; go t; Option.iter go e' | Ast.While (_, c, body) -> go c; gos body + | Ast.Loop (bs, body) -> List.iter (fun (_, v) -> go v) bs; gos body + | Ast.Recur args -> gos args | Ast.Break _ | Ast.Continue _ -> () | Ast.Return v -> Option.iter go v | Ast.Set (p, v) -> place_uses acc e.Ast.loc p; go v diff --git a/lib/parse.ml b/lib/parse.ml index 651136a..6530821 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -233,6 +233,25 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = mk (Ast.Dotimes (lbl, sym n, expr count, body_of body)) | _ -> fail f "dotimes is (dotimes [name count] body ...)") + (* [(loop [x 0 acc 1] body ...)]. No label: [break] and [continue] may not + leave a loop — a loop answers with the value of its body, and a jump out + of one has no value to give — so there is nothing here for a label to + name. A leading keyword is caught here rather than left to [bindings], + which would complain that [:outer] has no value. *) + | Sym "loop" -> + (match args with + | { v = Kw k; _ } :: _ -> + fail f + ":%s — loop takes no label. break and continue may not leave a loop, \ + because a loop answers with the value of its body; there is nothing \ + for a label to name" k + | { v = Vec bs; _ } :: body -> mk (Ast.Loop (loop_bindings f bs, body_of body)) + | _ -> fail f "loop is (loop [name value ...] body ...)") + + (* Rebind and jump to the top. Its arguments are checked against the loop's + names in order, so the count is the binding vector's count. *) + | Sym "recur" -> mk (Ast.Recur (List.map expr args)) + | Sym "defer" -> (match args with | [] -> fail f "defer is (defer body ...)" @@ -350,7 +369,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = [find-restart] and [compute-restarts] are §4's two ways to look at the restart stack without committing to one. *) | "find-restart" | "compute-restarts" - | "errdefer" | "loop" | "recur" + | "errdefer" | "await" as name) -> fail f "%s is not implemented yet (see the build sequence in plan.org)" name @@ -384,6 +403,28 @@ and label (items : Form.t list) : string option * Form.t list = | { v = Kw k; _ } :: rest -> (Some k, rest) | _ -> (None, items) +(* A loop's binding vector. Pairs like [let]'s, but plain names only: a + destructuring pattern expands to several bindings from one form, and then + [recur]'s argument count would no longer match what is written here. *) +and loop_bindings f (items : Form.t list) : (string * Ast.expr) list = + let rec go = function + | [] -> [] + | name :: value :: rest -> + no_pattern name; + (sym name, expr value) :: go rest + | [ odd ] -> + Loc.fail odd.loc + "binding %s has no value — loop takes name/value pairs" + (Form.to_string odd) + in + let bs = go items in + List.iter + (fun (n, _) -> + if List.length (List.filter (fun (m, _) -> m = n) bs) > 1 then + fail f "%s is bound twice in this loop" n) + bs; + bs + and bindings f (items : Form.t list) : Ast.binding list = (* [name value ...] and [name Type value ...] both read; a type is a form that is not a value position — disambiguated by pair vs triple is diff --git a/lib/tast.ml b/lib/tast.ml index 40181fe..7d6bc15 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -112,7 +112,13 @@ and expr_kind = only from its own loop stack, and both stacks are pushed once per [While]. A [While] the checker *invents* (alloc_guard, the file-failure retry) is built directly and never contains one of these, so the entry it pushes in - [emit] matches nothing and is harmless — keep it that way. *) + [emit] matches nothing and is harmless — keep it that way. + + [check_loop]'s [While] is the one exception and the exception proves the + rule: it *is* pushed on [ctx.loops], so the [Break 0] that leaves it and + every [Continue] a [recur] mints are counted against the same stack [emit] + indexes. Invented is not the property that matters; being on the stack + is. *) | Break of int | Continue of int | Set of place * expr diff --git a/test/programs/recur.flan b/test/programs/recur.flan new file mode 100644 index 0000000..e25daf0 --- /dev/null +++ b/test/programs/recur.flan @@ -0,0 +1,90 @@ +;;;; loop and recur. +;;;; +;;;; What is worth asserting here rather than in a unit test is the code that +;;;; comes out, and there are four things: +;;;; +;;;; 1. A loop answers with the value of its body — the accumulator comes back +;;;; without a mutable slot and without a sentinel flag. +;;;; 2. recur rebinds every name *at once*. A swap is the test that fails if +;;;; the writes were interleaved with the reads. +;;;; 3. recur is a jump, not a call. A loop that goes round ten million times +;;;; would overflow the stack if it were a call, and this one returns. +;;;; 4. A loop whose body never falls off the end (every path recurs or +;;;; returns) still terminates, which is the Never-bodied shape. + +(defn gcd [a i32 b i32] i32 + (loop [x a y b] + (if (= y 0) + x + (recur y (% x y))))) + +;; The body is Never: neither arm produces a value, so there is no result slot +;; and no break — nothing falls off the end of this loop. +(defn first-over [n i32] i32 + (loop [i 0] + (if (> (* i i) n) + (return i) + (recur (+ i 1))))) + +;; Named so the match below has a return type to read None out of. +(defn step [i i32] (Option i32) + (if (= i 4) None (Some i))) + +(defn main [] i32 + ;; The value of the body, with no mutable accumulator anywhere. + (print (loop [i 0 acc 0] + (if (= i 5) + acc + (recur (+ i 1) (+ acc i))))) + (println "") ; 0+1+2+3+4 = 10 + + ;; Simultaneous rebinding. Interleaved writes would give 1 1. + (let [p (loop [a 1 b 2 n 0] + (if (= n 3) + a + (recur b a (+ n 1))))] + (print p) (println "")) ; three swaps: 2 + + (print (gcd 1071 462)) (println "") ; 21 + (print (first-over 50)) (println "") ; 8 + + ;; A jump and not a call: ten million frames is not a stack this has. + (print (loop [i 0] + (if (= i 10000000) i (recur (+ i 1))))) + (println "") ; 10000000 + + ;; recur in the tail of a let, and of a when inside a do — both are tails, + ;; and both are how a loop actually gets written. + (print (loop [i 0 acc 1] + (let [next (* acc 2)] + (if (= i 6) acc (recur (+ i 1) next))))) + (println "") ; 2^6 = 64 + + ;; A Unit-bodied loop: it is run for its effect and answers with nothing. + (let [n 0] + (loop [i 0] + (when (< i 3) + (print i) + (recur (+ i 1)))) + (println "") ; 012 + (print n) (println "")) ; 0 + + ;; A while nested inside a loop keeps its own break: the loop is a barrier + ;; only to a jump that would *leave* it. + (print (loop [i 0 acc 0] + (if (= i 4) + acc + (let [j 0 hit 0] + (while (< j 10) + (set j (+ j 1)) + (when (= j 3) (set hit 1) (break))) + (recur (+ i 1) (+ acc hit)))))) + (println "") ; 4 + + ;; A match arm is a tail too. + (print (loop [i 0 acc 0] + (match (step i) + (Some v) (recur (+ i 1) (+ acc v)) + None acc))) + (println "") ; 0+1+2+3 = 6 + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 915a4b7..288b0f0 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -126,6 +126,12 @@ let () = watchdog above is what turns that failure back into a report. *) outputs "break and continue" "programs/loops.flan" "4\n9\n8\n3\n0\n1\n0\n0\n0\n3\n6\nhit\nhit\n2\n"; + (* loop and recur. The ten-million line is the one that matters: a recur is + a jump to the top of a [While] and not a call, so the program returns + rather than running out of stack. The swap line is the other — recur + rebinds every name at once, and interleaved writes would print 1. *) + outputs "loop and recur" "programs/recur.flan" + "10\n2\n21\n8\n10000000\n64\n012\n0\n4\n6\n"; (* The prelude's slice algorithms. Every assertion here is over an input a wrong implementation fails: unsorted with duplicates, negatives and an odd length; a reverse-sorted slice; and a sort of a subslice whose diff --git a/test/test_flan.ml b/test/test_flan.ml index 535ada9..fe24390 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -944,6 +944,51 @@ let () = rejects_check "break may not leave a handler-bind" "(defstruct C [n i32]) (defn f [] () (while true (handler-bind [(C [c] 0)] (break))))" ~needle:"a handler-bind"; + (* loop and recur. The same stack, the same barriers, and one rule of its + own: a recur must be in the loop body's tail. That is what makes this + better than a silent TCO rather than only cheaper — the mistake is a + compile error here and would be a stack overflow there. *) + accepts "recur in the tail of the body" + "(defn f [] i32 (loop [i 0] (if (= i 3) i (recur (+ i 1)))))"; + accepts "recur in the tail of a when" + "(defn f [] () (loop [i 0] (when (< i 3) (recur (+ i 1)))))"; + accepts "recur in the tail of a nested let" + "(defn f [] i32 (loop [i 0] (let [n (+ i 1)] (if (= i 3) i (recur n)))))"; + rejects_check "recur that is not in tail position" + "(defn f [] () (loop [i 0] (recur (+ i 1)) (println \"\")))" + ~needle:"tail position"; + rejects_check "recur under a call is not in tail position" + "(defn f [] i32 (loop [i 0] (+ 1 (recur (+ i 1)))))" + ~needle:"tail position"; + rejects_check "recur in a nested loop body is not in tail position" + "(defn f [] () (loop [i 0] (while true (recur (+ i 1)))))" + ~needle:"tail position"; + (* Where the "refuse mutual recursion by name" answer lives: there are no + tail calls, so a function cannot recur into itself either. *) + rejects_check "recur outside a loop" + "(defn f [] () (recur))" ~needle:"no tail calls"; + rejects_check "recur with the wrong number of values" + "(defn f [] i32 (loop [i 0 j 1] (recur 1)))" + ~needle:"binds 2 names and this recur passes 1"; + (* The barrier, asked the same question break asks and given the same + answer, rather than a second mechanism. *) + rejects_check "recur may not leave a restart-case" + "(defn f [] () (loop [i 0] (restart-case (recur (+ i 1)) (go [] (println \"\")))))" + ~needle:"a restart-case"; + (* And the restriction this form adds: a loop answers with the value of its + body, so a jump out of one would have no value to give. A while written + inside a loop is untouched, which is the relative rule again. *) + accepts "a while inside a loop keeps its own break" + "(defn f [] () (loop [i 0] (while true (break))))"; + rejects_check "break may not leave a loop" + "(defn f [] () (loop [i 0] (break)))" ~needle:"no value to give"; + rejects_check "a labelled break may not leave a loop" + "(defn f [] () (while :o true (loop [i 0] (break :o))))" + ~needle:"no value to give"; + rejects_check "loop takes no label" + "(defn f [] () (loop :o [i 0] (recur i)))" ~needle:"loop takes no label"; + rejects_check "a loop binding is a plain name" + "(defn f [] () (loop [[a b] 0] (recur 0)))" ~needle:"destructuring pattern"; (* An import is resolved by [Load] before the checker runs, so one that reaches [Check] means a driver skipped that step. *) rejects_check "an unresolved import is a driver bug"