JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

recur is checked, which is the reason to prefer it over tail calls

Browse Source 
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.
This commit is contained in:
Joseph Ferano 2026-09-13 09:17:56 +07:00
parent 83369196a9
commit fedaec3e18
10 changed files with 521 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
BUILT.md
View File

@ -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

24
NEXT.md
View File

@ -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

10
lib/ast.ml
View File

@ -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

242
lib/check.ml
View File

@ -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 = "<none>" }
@ -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 = "<none>" }
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 = "<none>" }
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 = "<none>" } 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 = "<none>" } 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 = "<none>" } 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 = "<none>" } 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 = "<none>" }
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 = "<none>" }
in
let t = check ctx e in
(t, Array.of_list (List.rev ctx.slot_tys),

7
lib/load.ml
View File

@ -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

43
lib/parse.ml
View File

@ -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

8
lib/tast.ml
View File

@ -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

90
test/programs/recur.flan Normal file
View File

@ -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)

6
test/test_acceptance.ml
View File

@ -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

45
test/test_flan.ml
View File

@ -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"