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

Merge branch 'master' into worktree-agent-ac49c2c6835655472

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 13:14:44 +07:00
commit 1998f57ca8
32 changed files with 1863 additions and 631 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
TODO.org
View File

@ -540,14 +540,12 @@ an ordinary =defn= declares no environment and is byte-for-byte what it was. The
static side does not pay for the dynamic side. Rejected names: Closure, Proc, Fun, static side does not pay for the dynamic side. Rejected names: Closure, Proc, Fun,
Func, Fnptr. Func, Fnptr.
** NEXT Escaping closures, allocated on the GC side ** DONE Escaping closures, allocated on the GC side
Decided 2026-09-25: start it. It must work on wasm32. CLOSED: [2026-09-25]
The second half of "do both". What changes is where the environment points — a Only a capturing =fn= that may outlive its frame gets a collector environment; one
frame slot today, a collector allocation then — and the escape check goes away only called or passed down keeps its stack environment, as every handler does.
with it, along with the refusals on returning, storing, pointing at and pushing a Capture stays by value, and a =Map= of function values is refused. Rules out a
capturing value. Two things for it to know: a widening thunk's environment holds a tag bit on the environment word and a heap environment for every closure.
code pointer rather than a GC object, and capturing a dyn stays refused until a
synthesised environment has a descriptor.
** WAIT CFn and C's calling convention ** WAIT CFn and C's calling convention
Decided 2026-09-25: waits with C callbacks, until a program needs one. Decided 2026-09-25: waits with C callbacks, until a program needs one.
@ -1207,6 +1205,8 @@ the buffer.
** TODO Marking through a descriptor an x86 reload module emitted ** TODO Marking through a descriptor an x86 reload module emitted
The module links and runs. What is not proved is a collection running while a live The module links and runs. What is not proved is a collection running while a live
instance of a dyn-holding struct sits in a frame of a body that module delivered. instance of a dyn-holding struct sits in a frame of a body that module delivered.
The same holds for a closure environment a reload module allocated: the module
builds on both backends, and nothing yet collects while one is live.
For the next sweep rather than for a lane. For the next sweep rather than for a lane.
** NEXT A sliced string loses the trailing NUL ** NEXT A sliced string loses the trailing NUL

120
docs/BUILT.md
View File

@ -4332,7 +4332,8 @@ implemented.
**Refused, each with its own reason and its own program:** **Refused, each with its own reason and its own program:**
- **Capture does not exist.** *Superseded — see "Capture by value" below. It exists, the program that was this - **Capture does not exist.** *Superseded — see "Capture by value" below. It exists, the program that was this
refusal's witness now runs, and what is refused in its place is the **escape**.* refusal's witness now runs. The escape refusal that replaced it is gone too; see "Escape: only an escaping
closure's environment is the collector's".*
- **An `fn` with nothing to say what it takes** (`fn-no-type.flan`), above. - **An `fn` with nothing to say what it takes** (`fn-no-type.flan`), above.
- **A position that would zero one** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element, - **A position that would zero one** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element,
`(zeroed)`. ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which `(zeroed)`. ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which
@ -4358,8 +4359,9 @@ feature. This compiles:
(apply2 (fn [x] (+ x bonus)) 5)) (apply2 (fn [x] (+ x bonus)) 5))
``` ```
`bonus` is **copied** into an environment on the enclosing function's frame at the instant the `fn` value is made, `bonus` is **copied** into an environment at the instant the `fn` value is made, and the lifted body reads the copy.
and the lifted body reads the copy. Not a reference: `fn-capture.flan` changes the local through a pointer *after* The environment is a slot of the enclosing frame, or a collector allocation when the value outlives it;
see "Escape: only an escaping closure's environment is the collector's" below. Not a reference: `fn-capture.flan` changes the local through a pointer *after*
the value exists and *before* it is called, and the `fn` still answers with the old one. That test is the whole the value exists and *before* it is called, and the `fn` still answers with the old one. That test is the whole
claim, and it is the one no evaluation order can fake. claim, and it is the one no evaluation order can fake.
@ -4525,76 +4527,69 @@ A redefinition that changes which locals an `fn` names changes an environment's
place, a slot of the frame the literal was written in, written by the same module that reads it on every entry. A place, a slot of the frame the literal was written in, written by the same module that reads it on every entry. A
restart for editing a capture list would take the dev loop away from the feature it was built for. restart for editing a capture list would take the dev loop away from the feature it was built for.
### Escape, which is what makes "case 2" a bounded claim ### Escape: only an escaping closure's environment is the collector's
A value carrying an environment may be **called, passed down, and held in a `let`**. It may not be **returned, spec-memory.md's **case 3**. A capturing `fn` is checked with its copies on the frame it was written in, and
stored, pointed at, or pushed into a container**. The check runs over the typed IR of every function the program `Check.place_closures` moves them to an environment the collector allocates (`flan_dyn_env_new`) only for a value
ends up with — including the lifted ones, so an `fn` inside an `fn` needs no special case — and classifies that may outlive that frame. A closure that is only called, passed down or let-bound keeps its stack environment,
function-typed values as *suspect* or clean: costs what it cost before, and is accepted under `--no-gc`. The refusals on returning, storing, pointing at and
pushing a capturing value are gone.
- suspect: a capturing literal (`Tast.Closure`, the only node that makes one); a **parameter** of type `Fn`, in **What escapes** is decided over the whole program, to a fixed point: a function value is followed back to a
every function; an `Fn` read back out of a struct, a case or a pointer; a local bound to any of those, literal, a parameter or a lifted body's copy of a captured value, and escapes when one of those reaches a `set`, a
transitively; a branch or a valued form whose value is one. return, an `Option`, an array, a struct or case field, a pointer to its slot, the runtime (a push, a put), a
- clean: the address of a name, the result of any call, and **everything of type `CFn`** — the last for free, restart's arguments or an argument of a call through a function value. A call to a named function asks the callee
because a `CFn` has no environment to dangle and the type says so. The second follows from the first refusal, whether that parameter escapes; a capture asks the lifted body whether its copy escapes, and escapes outright when the
which is what stops a function from returning a suspect at all. capturing literal does. The rewrite turns the frame-slot `Let` and `Closure` into a `Closure` carrying the copies; the
backends tell the two forms apart by the second operand's type. Handler clauses never escape and are untouched.
The two types made this pass narrower rather than wider, which is the point of having them: a signature that says **Capture stays by value.** A store into a captured name is still refused (`fn-capture-set.flan`); shared state goes
`CFn` has already promised what the analysis would otherwise have to prove, and nothing written against one is through something that is itself a reference, such as a captured dyn map.
ever examined.
**The clean set is the enumeration, not the suspect set**, and that is a correction. It read the other way round — **Three things can be in an `Fn`'s second word** — null, an environment (on a frame or on the heap), or a widened
`Field`, `CaseField` and `Deref` named as suspect, everything else clean — and had a hole exactly where a list like name's code address — and nothing in the word says which; on wasm32 a code address is a small table index, so no tag
this cannot: `(at s 0)` over a slice of `Fn` is a `Prim`, so it came out clean while the `Vec`, struct and pointer bit is free. The collector keeps the **set of environments it allocated** and follows a word only when the set has
spellings of the same act were refused. Nothing can write an `Fn` into a slice today, so it was unreachable; but it, so it never reads through a code address or a frame address. The sweep deletes freed environments from the set
the pass claims its enumeration is closed, and a default of "clean" is how that claim stops being true without and shrinks it once it is mostly empty.
anyone noticing. `fn-escape-at.flan` pins it. The same inversion fixed which of the two refusal messages an index
read gets.
Two of those arms are there because leaving them out is unsound rather than merely conservative, and each has a **Descriptors** gained two tables beside the dyn words: environment words, and `Vec` headers whose elements hold
program. **A function value read out of an environment** (`fn-escape-copy.flan`): a lifted body holds *copies* of function values, with the element's descriptor. Environment words are named through `Option`, data type payloads and
what it captured, read back with `Field(Deref env, i)`, so a copy of a captured function value carries whatever unions — every case's word, since the live case is a tag the table cannot read — which is sound only because of the
environment the original did. Treat it as clean and the lifted body can return it, the return arrives at the outer set. The LLVM offsets are constant `getelementptr` expressions over the type, so wasm32's 4-byte pointers are laid
caller as an ordinary call result, and the whole "a call result is clean" rule has been walked around from inside. out by the target (`gcword.gpath`); x86 writes numbers. The descriptors follow the function bodies in the module,
**A valued form's tail** (`fn-escape-handled.flan`): `handler-bind`, `with-allocator` and `restart-case` are because LLVM sizes a named type only after its definition.
expressions whose value is their body's — and a `restart-case`'s is a clause's too — so each is a way for a suspect
to be a function's answer that a check looking only at `return` and at the last form of a block would step over.
**The parameter rule is the whole answer to the hard case.** A capturing `fn` passed to a function that stores it is **A `Vec` header is not trusted.** It is copied by value, so a copy goes stale when another copy's push moves the
caught *inside that function*: its parameter is suspect there and the store is refused where it is written. So no block, and the freed block may be unmapped. flan_rt.c reports every Vec block it allocates, moves or frees through
call can leak what its caller passed, and no caller has to be analysed. What it costs is real: `flan_vec_block_hook`; `flan_dyn_track_vecs`, called first thing in `main` by a program that can make a heap
`(defn keep [f (Fn [] i32)] (Fn [] i32) f)` is refused although it is harmless, and so is holding a parameter of environment, installs the collector's table of live blocks, and the marker reads a header's elements only when its
function type in a `Vec` that never leaves the frame. `fn-escape-param.flan` is that refusal, written down as a pointer is a live block, no further than the block's size, and not after its allocator's epoch has moved.
refusal of something that would sometimes have been fine. `fn-vec-stale.flan` segfaults in the collector without it.
Refusing `Addr` of a suspect matters more than it looks: without it, `deref` of a `(Ptr (Fn ...))` launders a **The static side does not pay.** `Emit.m.gcfn` is true when some closure's environment is on the heap, or in a dev
suspect into a clean value and the return refusal has been walked around. Treating the `deref` itself as suspect is build. Otherwise an `Fn` holds nothing the collector owns and nothing roots one. When it is true, a *parameter* of
the other half of that door, and it is free: nothing a `(Ptr (Fn ...))` can point at is anywhere but a frame, since function type is still not rooted — it cannot be assigned, so it holds what the caller passed, and the caller holds
a global and a struct field of function type are both refused already. that: in a rooted slot, or pinned by `Emit.held_operands`, which pins every function-value argument that is not a
read of a local. So the prelude's `map`, `filter` and `reduce` are as cheap in a program that makes one escaping
closure as in one that makes none: a map, filter and reduce loop measured 1.77G instructions at LLVM `-O2` with
and without one unrelated escaping closure.
Name resolution inside a lifted body now asks the enclosing function's locals **before** the globals, which is a **What is refused.** A `Map` whose values hold a function value (`fn-in-map.flan`): a `Map`'s storage is not walked.
deliberate tightening: inside the enclosing function a local shadows a global of the same name, so a body lifted out A bare `Fn` field, global or array element is still refused for its zero; `(Option (Fn ...))` holds one.
of it must mean the same thing. The old order was an accident of where the refusal sat.
Every one of these messages names **case 3** — the escaping closure, with an environment the collector owns — **A module that makes a heap closure is never unloaded**: the environment points at the module's descriptor and
because "this cannot be done" and "this cannot be done yet" are different sentences and the second is the true one. code, so making one counts toward the same gate a string literal does. A capturing `fn` typed at the dev prompt takes
Five programs: `fn-escape-return.flan`, `fn-escape-param.flan`, `fn-escape-store.flan`, `fn-escape-vec.flan`, and its lifted body and environment struct into the evaluation's module.
`fn-capture-set.flan`.
### What may be captured ### What may be captured
Anything but a **dyn**. A scalar, a struct and a fixed array copy whole. A string, a slice and a `Vec` or `Map` Anything. A scalar, a struct and a fixed array copy whole. A string, a slice and a `Vec` or `Map` header copy as their
header copy as their words, aliasing whatever they pointed at — which is exactly right while the value cannot words and alias what they point at — the same borrow a struct holding a slice has when it is returned, which the
outlive the frame that owns the storage, and is exactly what would break under escape. A function value copies as a static side leaves to the program; there is no ownership tracking to refuse it with. A function value copies as a
function value, environment included; capturing one into another `fn`'s environment is the one place a suspect may function value, environment included, and the environment's descriptor names the copy's environment word, so a
be written into an aggregate, and it is sound because the outer literal is itself suspect, so the pair of closure capturing a closure keeps it alive. A **dyn** copies as a dyn word and the descriptor names it
environments lives and dies with one frame. (`fn-capture-dyn.flan`); the refusal that stood here waited for exactly this descriptor. A handler clause may capture a
dyn for the same reason: its frame slot holding the copies is rooted with the environment struct's descriptor.
A **dyn is refused**, for the reason a struct field of dyn already is (`A struct cannot hold a dyn field the
collector would never find`): the collector's roots are frames, and nothing pushes the fields of a synthesised
environment. A copy in there would be a live value reachable only through memory the marker never walks. Milestone
2's per-type descriptors lift it, alongside the condition payload's and the struct field's — and case 3's
collector-allocated environment is where it belongs anyway. `fn-capture-dyn.flan`.
### Handlers, which get this for free and have no case 3 to wait for ### Handlers, which get this for free and have no case 3 to wait for
@ -4638,7 +4633,8 @@ after it, seeing the last iteration's copies — cannot be written: a captured v
### What each backend cost ### What each backend cost
Very little, which was the point of putting the environment in a frame slot and passing it as an ordinary argument Very little, which was the point of putting the environment in a frame slot and passing it as an ordinary argument
at the one call that needs it. at the one call that needs it. (The environment has since moved to the collector's heap; what that cost is in the
escape section above.)
`emit.ml`: a `%fnv` type and a 16-byte layout for `Fn`, `ptr` and eight for `CFn`; an `insertvalue` pair where a `emit.ml`: a `%fnv` type and a 16-byte layout for `Fn`, `ptr` and eight for `CFn`; an `insertvalue` pair where a
symbol used to stand alone; two `extractvalue`s at a call through an `Fn`; one appended operand on that call and on symbol used to stand alone; two `extractvalue`s at a call through an `Fn`; one appended operand on that call and on

2
lib/ast.ml
View File

@ -127,7 +127,7 @@ and expr_kind =
| ArrayFill of len list * expr | ArrayFill of len list * expr
| ArrayGen of len list * expr | ArrayGen of len list * expr
(* These bind names or alter control flow, so none of them can be a call. *) (* These bind names or alter control flow, so none of them can be a call. *)
| Fn of string list * expr list (* (fn [x y] ...) — non-escaping *) | Fn of string list * expr list (* (fn [x y] ...) *)
(* (dotimes :o [i n] ...), (dotimes [i start stop] ...) and (* (dotimes :o [i n] ...), (dotimes [i start stop] ...) and
(dotimes [i start stop step] ...). The bounds are a record rather than (dotimes [i start stop step] ...). The bounds are a record rather than
three positional fields because the one-bound form is the common one and three positional fields because the one-bound form is the common one and

431
lib/check.ml
View File

@ -717,19 +717,7 @@ let rec capture ctx loc name =
| None -> if ctx.outer_what = None then None else from_parent () | None -> if ctx.outer_what = None then None else from_parent ()
in in
match ctx.outer_what, outer with match ctx.outer_what, outer with
| Some what, Some (outer : binding) -> | Some _, Some (outer : binding) ->
if outer.bty = Types.Dyn then
(* [what] is a descriptor — "an fn", "a handler" — so it reads as the
subject of a sentence and nowhere else. It used to be substituted
into a noun slot as well, which produced "the environment an fn is
handed"; the environment belongs to *this* capture and naming it
twice said less, not more. *)
Loc.failk "check/capture-dyn" loc
"%s cannot capture %s: it is a dyn, and the collector finds its \
roots by frame — a copy inside the environment would be a live \
value nothing walks. Pass it in as a parameter, or hold it in a \
global"
what name;
let slot = bind ctx name outer.bty ~assignable:false in let slot = bind ctx name outer.bty ~assignable:false in
ctx.caught <- ctx.caught @ [ (name, (outer, slot)) ]; ctx.caught <- ctx.caught @ [ (name, (outer, slot)) ];
Some { slot; bty = outer.bty; assignable = false; bwhat = None } Some { slot; bty = outer.bty; assignable = false; bwhat = None }
@ -1053,12 +1041,9 @@ let map_type ?(preds = []) loc (k : Types.t) (v : Types.t) =
(* The positions a function value may not be written in, and the one reason (* The positions a function value may not be written in, and the one reason
they are all the same position: something zeroes it. they are all the same position: something zeroes it.
Since capture arrived there is a second reason standing behind the first, The zero is the whole reason: a capturing value's environment belongs to
and it is the sharper one: every position on this list outlives the frame the collector and may be kept anywhere, and [(Option (Fn ...))] is how a
a captured environment is on, so even a value nobody zeroed could not be field or a global holds one.
kept there. The message names the zero because that is the one that applies
to *every* function value and not only to a capturing one — and the escape
is what [escape_check] says, at the store rather than at the declaration.
ZII is the language's rule — an omitted struct field, a fixed array's ZII is the language's rule — an omitted struct field, a fixed array's
elements, a [defonce] with no initialiser are all all-bytes-zero — and a elements, a [defonce] with no initialiser are all all-bytes-zero — and a
@ -1187,9 +1172,9 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t =
(resolve env ~seen v) (resolve env ~seen v)
(* (Fn [T ...] R) is a code address and the environment it is called with: (* (Fn [T ...] R) is a code address and the environment it is called with:
two words. A value made out of a name carries a null there; one made out two words. A value made out of a name carries a null there; one made out
of an [fn] that captures carries the address of the copies on the frame of an [fn] that captures carries the address of its copies: a slot of
it was written in, and [escape_check] is what stops that address the frame it was written in, or an environment the collector allocated
outliving the frame. when the value outlives that frame (see [place_closures]).
(CFn [T ...] R) is the address alone, one word, and nothing that can (CFn [T ...] R) is the address alone, one word, and nothing that can
capture — see [Types] for why the C is information rather than capture — see [Types] for why the C is information rather than
@ -2165,7 +2150,6 @@ let close_over ~fname (octx : ctx) (fctx : ctx) loc =
caught caught
in in
let prefix body = [ mk loc fctx.ret (Tast.Let (binds, body)) ] in let prefix body = [ mk loc fctx.ret (Tast.Let (binds, body)) ] in
let mslot = fresh_slot octx ety in
let make = let make =
mk loc ety mk loc ety
(Tast.Make (ename, (Tast.Make (ename,
@ -2174,6 +2158,7 @@ let close_over ~fname (octx : ctx) (fctx : ctx) loc =
mk loc b.bty (Tast.Local b.slot)) mk loc b.bty (Tast.Local b.slot))
caught)) caught))
in in
let mslot = fresh_slot octx ety in
prefix, Some eslot, Some (mslot, make), prefix, Some eslot, Some (mslot, make),
Some (mk loc (Types.Ptr ety) (Tast.Addr (Tast.Plocal mslot))) Some (mk loc (Types.Ptr ety) (Tast.Addr (Tast.Plocal mslot)))
@ -4284,15 +4269,13 @@ and block ctx ?want ?(defer_ok = false) loc body =
landed, and the surface feature is that machinery given a name rather than a landed, and the surface feature is that machinery given a name rather than a
second one invented beside it. second one invented beside it.
**Capture is by value, and the value may not escape.** The body sees its **Capture is by value.** The body sees its parameters, the program's
parameters, the program's globals, and the locals of the function it was globals, and the locals of the function it was written in — those last
written in — those last copied into an environment on that function's copied into an environment at the instant the value is made (see
frame at the instant the value is made (see [capture] and [close_over]). [capture] and [close_over]). The copies go on that function's frame, and
So the value is two words, the second of them an address into a frame, and [place_closures] moves them to an environment the collector allocates for
what keeps that address good is [escape_check]: it may be called, passed a value that may outlive the frame — so it may be returned, stored or
down and let-bound, and may not be returned, stored or pushed anywhere. pushed like any other value: spec-memory.md's case 3.
spec-memory.md's case 3 — an environment the collector owns, and with it
the escaping closure — is a separate lane, and every refusal names it.
**The parameter types come from the position.** [Ast.Fn] carries names and **The parameter types come from the position.** [Ast.Fn] carries names and
no types — that is the surface syntax, not an omission here — so an fn is no types — that is the surface syntax, not an omission here — so an fn is
@ -4442,11 +4425,12 @@ and check_fn ctx ~want ?gen loc (params : string list) body =
let v = let v =
match addr with match addr with
| None -> mk loc fty (Tast.FnAddr (Tast.Flanfn fname)) | None -> mk loc fty (Tast.FnAddr (Tast.Flanfn fname))
(* The value, and the store that fills its environment on this frame
around it. Whether the environment stays there is decided once the
whole program is checked, by [place_closures]: a value that may
outlive this frame has its copies moved to an environment the
collector allocates instead. *)
| Some a -> | Some a ->
(* The value, and the store that fills its environment around it. What
stops the value leaving this frame is [escape_check], which reads the
finished body: a rule about where a value may *go* cannot be settled
at the point it is made. *)
let c = mk loc fty (Tast.Closure (Tast.Flanfn fname, a)) in let c = mk loc fty (Tast.Closure (Tast.Flanfn fname, a)) in
mk loc fty (Tast.Let ([ Option.get bind ], [ c ])) mk loc fty (Tast.Let ([ Option.get bind ], [ c ]))
in in
@ -4533,7 +4517,8 @@ and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body =
case to leave over. A handler frame is popped by the body that case to leave over. A handler frame is popped by the body that
pushed it and nothing in the language can name one, so the clause pushed it and nothing in the language can name one, so the clause
cannot be reached from anywhere the establishing frame is not cannot be reached from anywhere the establishing frame is not
alive. There is nothing here that case 3 would change. *) alive. So its copies stay on the establishing frame, in
a slot rooted with the environment's descriptor. *)
let prefix, fenv, bind, addr = let prefix, fenv, bind, addr =
close_over ~fname ctx hctx c.Ast.hloc close_over ~fname ctx hctx c.Ast.hloc
in in
@ -12288,8 +12273,82 @@ let value_sites (p : Tast.program) ?(after_fn = fun (_ : Tast.fn) -> ())
(* Over the whole program rather than at each declaration, because the type (* Over the whole program rather than at each declaration, because the type
that hides a dyn may be declared after the one that names it — and because that hides a dyn may be declared after the one that names it — and because
a struct nobody ever holds a value of costs nothing either way. *) a struct nobody ever holds a value of costs nothing either way. *)
(* Does a value of this type hold an (Fn ...) in its own storage — the
function values a collector-allocated environment may hang off. A
pointer and a slice are views of storage checked where it is declared. *)
let rec holds_fn p seen (t : Types.t) =
let go = holds_fn p seen in
match t with
| Types.Fn _ -> true
| Types.Array (_, e) | Types.Vec e | Types.Option e -> go e
| Types.Map (k, v) -> go k || go v
| Types.Named n when not (List.mem n seen) ->
let seen = n :: seen in
let field (fl : Tast.field) = holds_fn p seen fl.Tast.fty in
(match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n)
p.Tast.structs with
| Some s -> List.exists field s.Tast.fields
| None ->
match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n)
p.Tast.datas with
| Some u ->
List.exists
(fun (c : Tast.variant) -> List.exists field c.Tast.vfields)
u.Tast.cases
| None ->
match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n)
p.Tast.unions with
| Some u -> List.exists field u.Tast.fields
| None -> false)
| _ -> false
(* The first Map under this type whose values hold a function value. A
closure's environment is found by walking the storage a function value
sits in, and a Map's storage is not walked — so an (Fn ...) there would be
one the collector frees under it. A Vec's is, which is the container to
use; and a (CFn ...) carries no environment and may go in a Map freely. *)
let rec map_of_fn p seen (t : Types.t) : Types.t option =
match t with
| Types.Map (k, v) when holds_fn p [] k || holds_fn p [] v -> Some t
| Types.Array (_, e) | Types.Vec e | Types.Option e
| Types.Ptr e | Types.Slice e -> map_of_fn p seen e
| Types.Map (_, v) -> map_of_fn p seen v
| Types.Named n when not (List.mem n seen) ->
let seen = n :: seen in
let fields =
match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n)
p.Tast.structs with
| Some s -> s.Tast.fields
| None ->
match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n)
p.Tast.datas with
| Some u -> List.concat_map (fun (c : Tast.variant) -> c.Tast.vfields) u.Tast.cases
| None ->
match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n)
p.Tast.unions with
| Some u -> u.Tast.fields
| None -> []
in
List.fold_left
(fun acc (fl : Tast.field) ->
match acc with Some _ -> acc | None -> map_of_fn p seen fl.Tast.fty)
None fields
| _ -> None
let dyn_descriptors (p : Tast.program) = let dyn_descriptors (p : Tast.program) =
let check loc what (t : Types.t) = let check loc what (t : Types.t) =
(match map_of_fn p [] t with
| Some at ->
Loc.failk "check/fn-in-map" loc
"%s is %s%s, a Map whose values are function values. A function \
value's environment is found by walking the storage it sits in, \
and a Map's storage is not walked, so the collector would free an \
environment still in use. Keep the function values in a Vec, or \
make them (CFn ...) if they capture nothing"
what (Types.to_string t)
(if Types.equal t at then ""
else Printf.sprintf ", and holds %s" (Types.to_string at))
| None -> ());
(match hidden_dyn p [] t with (match hidden_dyn p [] t with
| Some at -> | Some at ->
Loc.failk "check/dyn-descriptor" loc Loc.failk "check/dyn-descriptor" loc
@ -12363,240 +12422,10 @@ let dyn_descriptors (p : Tast.program) =
"What C hands back points at storage this compiler never rooted") "What C hands back points at storage this compiler never rooted")
p.Tast.externs; p.Tast.externs;
value_sites p (fun ~slot:_ loc what t -> check loc what t) value_sites p (fun ~slot:_ loc what t -> check loc what t)
(* ── Escape, which is the other half of capture ──────────────────────── (* See lib/closures.ml. *)
spec-memory.md's case 2 is the *non-escaping* fn, and this is what makes let is_env_struct = Closures.is_env_struct
the word mean something. A captured copy lives in a slot of the frame the let heap_env = Closures.heap_env
literal was written in, so a value holding that frame's address may be let place_closures fns = Closures.place ~dev:false fns
called, passed down and copied about as much as anyone likes — and must
never outlive the frame. Case 3, the escaping closure with an environment
the collector allocates, is a separate lane; every refusal here names it,
because "this cannot be done" and "this cannot be done yet" are different
sentences and the second one is the true one.
Run over the typed IR rather than over the surface, and over every
function the program ends up with rather than only over the ones anyone
wrote. Two reasons, and both are about not having to be careful: the IR
has one node per way a value can be stored, so the list below is closed;
and a lifted body is checked by exactly the same pass as the body it came
out of, so an [fn] inside an [fn] needs no special case.
**What is suspect.** A value of function type that may carry an
environment, decided by a rule that needs no interprocedural anything:
- a capturing literal, which is a [Closure] node and is the only place one
is made;
- a *parameter* of function type, in every function, because nothing at a
definition can see what its callers will pass;
- a local bound to either of those, transitively;
- a branch or a block whose value is one.
Everything else of function type is clean: the address of a name, and the
result of any call — the second follows from the first refusal below, which
is what stops a function from returning a suspect in the first place.
**Why the parameter rule is the whole answer to the hard case.** An [fn]
that captures, passed to a function that stores it, is caught *inside that
function*: its parameter is suspect there, and the store is refused where
it is written. So no call can leak what its caller passed, and no caller
has to be analysed. What it costs is real and worth naming: [(defn id [f
(Fn [] i32)] (Fn [] i32) f)] is refused although it is harmless, and so is
holding a parameter of function type in a Vec that never leaves the frame.
Both become writable when case 3 lands, and neither is worth an analysis
before then.
**Where a suspect may stand**: an argument of a call, the callee of one, a
[let] binding, and the field of an environment another literal captures it
into — that last is the [env/] exemption below, and it is sound for the
same reason everything here is: the outer literal is itself suspect, so
the pair of environments lives and dies with one frame. *)
let rec escaping suspects (e : Tast.expr) =
(* The value of a body is its last form, which is the only part of one that
can be this expression's own value. *)
let tail body =
match List.rev body with x :: _ -> escaping suspects x | [] -> false
in
match e.Tast.ty with
| Types.Fn _ ->
(match e.Tast.e with
| Tast.Closure _ -> true
| Tast.Local s -> List.mem s !suspects
| Tast.If (_, a, b) -> escaping suspects a || escaping suspects b
| Tast.Do body | Tast.Let (_, body) -> tail body
| Tast.Match (_, arms) -> List.exists (fun (a : Tast.arm) -> tail a.Tast.abody) arms
(* The forms that establish something around a body and yield the body's
value. Easy to forget and not safe to: each of them is an expression,
so each of them is a way for a suspect to be the answer. A
restart-case yields its body's value *or* a clause's, so every clause
is a tail too. *)
| Tast.Handled (_, body) | Tast.WithAlloc (_, body) -> tail body
| Tast.RestartCase (cs, body) ->
escaping suspects body
|| List.exists (fun (c : Tast.rclause) -> tail c.Tast.rbody) cs
(* And then the clean list, which is short, closed, and stated as a list
rather than as a default — a *read* of an [Fn] from anywhere is
suspect unless it is one of these.
It used to be the other way round, with [Field], [CaseField] and
[Deref] named as suspect and everything else clean, and that spelling
had a hole in it exactly where a list like this cannot: an [(at s 0)]
over a slice of [Fn] is a [Prim], so it read as clean while the [Vec]
and pointer spellings of the same thing were refused. Nothing can
write an [Fn] into a slice today, so it was not reachable — but the
header above claims this enumeration is closed, and a default of
[false] is how that claim stops being true without anyone noticing.
What is clean, and why. The address of a name never carried an
environment. A widening carries a thunk and a code pointer, which is
not a frame address. And the result of a call cannot carry one,
because a function that would return one is refused below — that
refusal is what this arm rests on, which is why the two have to be
read together. *)
| Tast.FnAddr _ | Tast.Thicken _ | Tast.Call _ | Tast.CallPtr _ -> false
(* Everything else that can produce an [Fn]: read out of a struct — which
for a function value means read out of an *environment*, the one
aggregate a capture may be written into — out of a case, through a
pointer, or out of a container. A copy of a captured function value
carries whatever environment the original did, so it is suspect
exactly as the original was: without this, a lifted body could hand
back its copy of a captured value and the result would arrive at the
caller as an ordinary call result, which is to say as clean. *)
| _ -> true)
| _ -> false
(* The environment struct a capture built, which is the one aggregate a
suspect may be written into. See the header. *)
let is_env_struct n = String.length n >= 4 && String.sub n 0 4 = "env/"
let escape_check (fn : Tast.fn) =
let suspects = ref [] in
List.iteri
(fun i ty -> match ty with Types.Fn _ -> suspects := i :: !suspects | _ -> ())
fn.Tast.params;
(* Two refusals, because the two cases know different amounts. A literal
written here captures, full stop, and the message can name the frame its
copies are on. A function value that arrived as a parameter *may* carry
an environment and nothing at a definition can tell — so it is refused
where it is written rather than at the calls that would have been fine,
and the message says that is what happened. *)
let owner = match fn.Tast.fparent with Some p -> p | None -> fn.Tast.name in
(* Which of the two this is, found by following the same tails [escaping]
followed. The refused expression is often a form that *yields* the
suspect — a handler-bind, a branch — and the message has to describe what
is actually escaping and not the shape it arrived in. *)
let rec written_here (e : Tast.expr) =
let tail body =
match List.rev body with x :: _ -> written_here x | [] -> true
in
match e.Tast.e with
| Tast.Closure _ -> true
| Tast.If (_, a, b) -> written_here a && written_here b
| Tast.Do body | Tast.Let (_, body) | Tast.Handled (_, body)
| Tast.WithAlloc (_, body) -> tail body
| Tast.Match (_, arms) ->
List.for_all (fun (a : Tast.arm) -> tail a.Tast.abody) arms
| Tast.RestartCase (cs, body) ->
written_here body
&& List.for_all (fun (c : Tast.rclause) -> tail c.Tast.rbody) cs
(* Everything else is a *read* of a value made elsewhere — a local, a
field, an index, a load through a pointer — and the message that fits
one is the other message, about a value this definition did not make
and cannot see into. The literal is the short list here, exactly as
the clean set is the short list in [escaping]; whichever is short is
the one to write out. *)
| _ -> false
in
let refuse (e : Tast.expr) where =
if not (written_here e) then
Loc.failk "check/fn-escapes" e.Tast.loc
"this function value may carry an environment, and %s would outlive \
the frame that environment is on. A value reaching %s as a parameter \
was made by a caller this definition cannot see, so it is refused \
here rather than at the calls that would be safe. Call it, pass it \
down, or hold it in a let — an fn whose environment the collector \
owns is spec-memory.md's case 3 and is not built yet"
where owner
else
Loc.failk "check/fn-escapes" e.Tast.loc
(* No "hold it in a let" here, unlike the message above: an fn literal
takes its types from the position it is written in, so there is no
let binding to offer — see fn-no-type.flan. Every suggestion this
compiler prints has to compile. *)
"this fn captures, and %s would outlive the frame its copies are on. \
The copies are slots of %s, taken where the value was made, so a \
reader reached after that frame has gone would read whatever \
replaced them. Call it, or pass it down — an fn whose environment \
the collector owns is spec-memory.md's case 3 and is not built yet"
where owner
in
let deny where es = List.iter (fun e -> if escaping suspects e then refuse e where) es in
let go (e : Tast.expr) =
(match e.Tast.e with
| Tast.Let (bs, _) ->
(* A binding is where a suspect spreads, and one of the two places it
does. *)
List.iter
(fun (slot, v) -> if escaping suspects v then suspects := slot :: !suspects)
bs
(* And the other: an arm's pattern binds the case's fields to slots, and
the store that fills them is inside the branch rather than in a form
this walk reads as a binding. Reading the same field by hand is a
[CaseField] and suspect — a copy of a captured function value carries
whatever environment the original did — so the slot the pattern binds
it to is suspect too, or [(match o (Some f) f ...)] would hand back
through a name what [(case-field o ...)] cannot hand back at all.
Every arm's binds, not only an [Option]'s: a data type's field of
function type is written through [MakeCase], which denies suspects,
and read back through this. *)
| Tast.Match (_, arms) ->
List.iter
(fun (a : Tast.arm) ->
List.iter
(fun s ->
match fn.Tast.slots.(s) with
| Types.Fn _ -> suspects := s :: !suspects
| _ -> ())
a.Tast.binds)
arms
| Tast.Set (_, v) -> deny "a store" [ v ]
| Tast.Return (Some v) -> deny "a return" [ v ]
| Tast.Some_ v -> deny "an Option" [ v ]
| Tast.Arr es -> deny "a fixed array" es
| Tast.MakeCase (_, _, es) -> deny "a data type's field" es
| Tast.Make (n, es) -> if not (is_env_struct n) then deny "a struct field" es
| Tast.Addr (Tast.Plocal s) ->
if List.mem s !suspects then
refuse e "a pointer to it"
(* Everything the runtime takes: a push into a Vec, a put into a Map, a
box into a dyn. All of them put the value somewhere this frame does
not own — and all of them take it *by address*, because the container
runtime is type-erased, so the address is what has to be caught and
not the value beside it. *)
| Tast.Prim (Tast.Rt _, es) ->
deny "a container" es;
List.iter
(fun (a : Tast.expr) ->
match a.Tast.e with
| Tast.Prim (Tast.AddrOf, [ v ]) -> deny "a container" [ v ]
| _ -> ())
es
| Tast.Prim (Tast.AddrOf, [ v ]) -> deny "a pointer to it" [ v ]
| Tast.InvokeRestart (_, _, es, _, _, _) -> deny "a restart's argument" es
| _ -> ())
in
(* Outermost first, which is the order [Tast.walk] gives and the order a
[let] has to be seen in: a binding must be recorded before anything that
reads the slot. *)
List.iter (fun e -> Tast.walk go e) fn.Tast.body;
(* And the defers on the transfer path, which are the same forms again but
are not reachable from [body] — they hang off the function, and a store
written in one is a store. *)
List.iter (fun e -> Tast.walk go e) fn.Tast.fdefers;
(* And the tail, which is a return with nothing written. *)
(match List.rev fn.Tast.body with
| last :: _ when (match fn.Tast.ret with Types.Fn _ -> true | _ -> false) ->
deny "a return" [ last ]
| _ -> ())
let build_program ~keep_going ?tolerate (decls : Ast.decl list) : let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
Tast.program * env * string list = Tast.program * env * string list =
@ -12745,10 +12574,8 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
they are reached *by name* from arbitrary call sites, so they carry no they are reached *by name* from arbitrary call sites, so they carry no
[fparent] and a dev build gives each its own cell. *) [fparent] and a dev build gives each its own cell. *)
let fns = fns @ List.rev env.instances in let fns = fns @ List.rev env.instances in
(* Where a captured copy may go, asked of every function the program ended (* Which capturing fns outlive their frame; see [place_closures]. *)
up with. Here rather than inside [check] because it is a question about a let fns = place_closures fns in
finished body — see the header on [escaping]. *)
List.iter escape_check fns;
(* And the order the computed initialisers run in, which needs the whole (* And the order the computed initialisers run in, which needs the whole
function list: what a global reads is transitive through what it calls. *) function list: what a global reads is transitive through what it calls. *)
let globals = init_order globals fns in let globals = init_order globals fns in
@ -12854,6 +12681,21 @@ let instances_since env mark =
List.rev List.rev
(List.filteri (fun i _ -> i < fresh) env.instances) (List.filteri (fun i _ -> i < fresh) env.instances)
(* The same protocol for a body an expression lifted — an [fn] literal or a
handler clause — and the environment struct each one captured into. Both
are in [env] and in no program, and a module that calls one or lays one
out needs them. *)
let lifted_mark env = List.length env.lifted
let lifted_since env mark =
let fresh = List.length env.lifted - mark in
List.rev (List.filteri (fun i _ -> i < fresh) env.lifted)
let env_structs env (fns : Tast.fn list) =
List.filter_map
(fun (f : Tast.fn) -> Hashtbl.find_opt env.structs ("env/" ^ f.Tast.name))
fns
(* Expressions checked against a program that is already running, all of them (* Expressions checked against a program that is already running, all of them
into *one* frame. It is empty to start with — a REPL expression has no into *one* frame. It is empty to start with — a REPL expression has no
parameters and no enclosing function — so the slots it ends up with are parameters and no enclosing function — so the slots it ends up with are
@ -12925,7 +12767,7 @@ let expression env ?want (e : Ast.expr) :
let dyn_sites (p : Tast.program) : Loc.diag list = let dyn_sites (p : Tast.program) : Loc.diag list =
let found = ref [] in let found = ref [] in
let add loc what = found := (loc, what) :: !found in let add loc what = found := (loc, `Dyn what) :: !found in
(* A type that *holds* a dyn and not only the type [dyn] itself. A struct (* A type that *holds* a dyn and not only the type [dyn] itself. A struct
with a dyn field is a collected value as much as a bare one is, and since with a dyn field is a collected value as much as a bare one is, and since
the per-type descriptors it is a value a program can have without any the per-type descriptors it is a value a program can have without any
@ -12952,17 +12794,30 @@ let dyn_sites (p : Tast.program) : Loc.diag list =
&& String.length sym > 8 && String.length sym > 8
&& String.sub sym 0 8 = "flan_dyn" -> && String.sub sym 0 8 = "flan_dyn" ->
add e.Tast.loc (Printf.sprintf "this value in %s" fn.Tast.name) add e.Tast.loc (Printf.sprintf "this value in %s" fn.Tast.name)
(* A capturing fn: its environment is a collector allocation,
which is a different sentence from a dyn and has a different
fix. *)
| Tast.Closure (_, env) when heap_env env ->
found := (e.Tast.loc, `Closure) :: !found
| _ -> ())) | _ -> ()))
fn.Tast.body); fn.Tast.body);
List.rev_map List.rev_map
(fun (loc, what) -> (fun (loc, site) ->
Loc.diag ~kind:"check/no-gc" loc Loc.diag ~kind:"check/no-gc" loc
(Printf.sprintf (match site with
| `Dyn what ->
Printf.sprintf
"%s holds a dyn, and --no-gc says this program carries no \ "%s holds a dyn, and --no-gc says this program carries no \
collector. A \ collector. A \
dyn value is one the runtime allocates and the collector owns, so \ dyn value is one the runtime allocates and the collector owns, \
there is nothing smaller to compile it to — write the type" so there is nothing smaller to compile it to — write the type"
what)) what
| `Closure ->
"this fn captures and outlives the frame it was made in, and \
--no-gc says this program carries no collector. The copies of an \
fn that outlives its frame live in an environment the collector \
allocates — call it or pass it down instead of keeping it, or \
pass what it names in as parameters"))
!found !found
let no_gc (p : Tast.program) = let no_gc (p : Tast.program) =
@ -13121,9 +12976,16 @@ let memory_sites ?file (p : Tast.program) : Loc.diag list =
let found = ref [] in let found = ref [] in
let seen = Hashtbl.create 64 in let seen = Hashtbl.create 64 in
let look (e : Tast.expr) = let look (e : Tast.expr) =
let cls =
match e.Tast.e with match e.Tast.e with
| Tast.Prim (Tast.Rt sym, args) -> | Tast.Prim (Tast.Rt sym, args) -> memory_class sym args
(match memory_class sym args with | Tast.Closure (_, env) when heap_env env ->
Some ("memory/gc",
"allocates: an fn that captures and outlives its frame keeps its \
copies in an environment on the collector's heap")
| _ -> None
in
match cls with
| None -> () | None -> ()
| Some (kind, msg) -> | Some (kind, msg) ->
let loc = e.Tast.loc in let loc = e.Tast.loc in
@ -13132,8 +12994,7 @@ let memory_sites ?file (p : Tast.program) : Loc.diag list =
&& not (Hashtbl.mem seen key) then begin && not (Hashtbl.mem seen key) then begin
Hashtbl.replace seen key (); Hashtbl.replace seen key ();
found := Loc.diag ~kind loc msg :: !found found := Loc.diag ~kind loc msg :: !found
end) end
| _ -> ()
in in
(* A global's initialiser runs at startup and allocates there as much as a (* A global's initialiser runs at startup and allocates there as much as a
body does — [(defonce names (vec-new dyn))] is a heap object before main body does — [(defonce names (vec-new dyn))] is a heap object before main

242
lib/closures.ml Normal file
View File

@ -0,0 +1,242 @@
(* Where a capturing fn's environment lives: on the frame it was written in,
or on the collector's heap. A module of its own, beneath both [Check] and
the emitters, because the answer depends on the build: [Check] places
precisely, and a dev build's emitters place again under the dev rule —
see [place]. *)
(* The environment struct a capture built. [Session]'s layout guard exempts
these; see there. *)
let is_env_struct n = String.length n >= 4 && String.sub n 0 4 = "env/"
(* ── Where a closure's environment lives ───────────────────────────────
A capturing [fn] is checked with its copies on the frame it was written
in: a slot holding the environment struct, and a [Closure] carrying the
slot's address. That is right for a value that is only called, passed
down and let-bound — the frame outlives every use — and it costs nothing
the static side would notice. A value that may outlive the frame needs
its copies somewhere the frame's end does not reclaim, and for those this
pass rewrites the literal to carry the copies themselves; the backend
then allocates the environment from the collector. Only a closure that
escapes allocates: the static side does not pay for the dynamic side.
**What escapes.** The analysis follows function values back to where they
came from — a literal, a parameter, or a lifted body's copy of a captured
value — and asks whether any of those reaches a position that outlives
the frame: a [set], a [return] or a function's last form, an [Option], a
fixed array, a struct or data type field, a pointer to the slot holding
it, anything handed to the runtime (a push, a put, a box), a restart's
arguments, and any argument of a call through a function value. A call
to a named function passes the question to the callee's parameter, and a
capture passes it to the lifted body's copy — or escapes outright when
the capturing literal itself escapes. Everything only grows, so the pass
runs to a fixed point over the whole program.
A function value read out of storage — a field, an element, a case — has
no source here and needs none: nothing puts a value in storage without
going through one of the positions above, which already sent its literal
to the collector. *)
type fsrc = Lit of string | Par of int | Env of int
(* Whether a [Closure]'s environment is a collector allocation: it carries
its copies rather than the address of a frame slot holding them. *)
let heap_env (env : Tast.expr) =
match env.Tast.ty with Types.Ptr _ -> false | _ -> true
(* [dev] is a dev build's rule. There a call to a named function goes through
its cell, and a redefinition can replace the callee with a body that keeps
the value — while the caller, which is not recompiled, still made it on its
frame. So a closure handed to any named call escapes, whatever the callee
does today. A release build asks the callee. *)
let place ~dev (fns : Tast.fn list) : Tast.fn list =
let by_name = Hashtbl.create 64 in
List.iter (fun (f : Tast.fn) -> Hashtbl.replace by_name f.Tast.name f) fns;
let lits = Hashtbl.create 16 in (* escaping literals *)
let pars = Hashtbl.create 16 in (* (fn, i) escaping params *)
let envs = Hashtbl.create 16 in (* (fn, i) escaping copies *)
let changed = ref true in
let mark tbl k =
if not (Hashtbl.mem tbl k) then begin
Hashtbl.replace tbl k ();
changed := true
end
in
let is_fn (t : Types.t) = match t with Types.Fn _ -> true | _ -> false in
let pass (fn : Tast.fn) =
let slot = Hashtbl.create 16 in
let add s rs =
let old = try Hashtbl.find slot s with Not_found -> [] in
Hashtbl.replace slot s (List.sort_uniq compare (rs @ old))
in
List.iteri (fun i t -> if is_fn t then add i [ Par i ]) fn.Tast.params;
(* The environment structs this function fills, by the slot they sit
in: a literal's [Closure] and a handler frame name the slot. *)
let makes = Hashtbl.create 8 in
let escape rs =
List.iter
(function
| Lit n -> mark lits n
| Par i -> mark pars (fn.Tast.name, i)
| Env i -> mark envs (fn.Tast.name, i))
rs
in
let rec roots (e : Tast.expr) =
if not (is_fn e.Tast.ty) then []
else
let tail body =
match List.rev body with x :: _ -> roots x | [] -> []
in
match e.Tast.e with
| Tast.Closure (Tast.Flanfn n, _) -> [ Lit n ]
| Tast.Local s -> (try Hashtbl.find slot s with Not_found -> [])
| Tast.If (_, a, b) -> roots a @ roots b
| Tast.Do body | Tast.Let (_, body) | Tast.Handled (_, body)
| Tast.WithAlloc (_, body) -> tail body
| Tast.Match (_, arms) ->
List.concat_map (fun (a : Tast.arm) -> tail a.Tast.abody) arms
| Tast.RestartCase (cs, body) ->
roots body
@ List.concat_map (fun (c : Tast.rclause) -> tail c.Tast.rbody) cs
| _ -> []
in
let deny es = List.iter (fun e -> escape (roots e)) es in
(* A capture: each copy escapes when the literal does, or when the
lifted body lets its copy escape. *)
let captured (fields : Tast.expr list) outright lifted =
List.iteri
(fun j (v : Tast.expr) ->
if outright || Hashtbl.mem envs (lifted, j) then escape (roots v))
fields
in
let go (e : Tast.expr) =
match e.Tast.e with
| Tast.Let (bs, _) ->
List.iter
(fun (s, (v : Tast.expr)) ->
(match v.Tast.e with
| Tast.Make (n, es) when is_env_struct n -> Hashtbl.replace makes s es
(* A lifted body's copy of what it captured. *)
| Tast.Field
({ Tast.e = Tast.Deref { Tast.e = Tast.Local es; _ }; _ }, i)
when fn.Tast.fenv = Some es -> add s [ Env i ]
| _ -> ());
add s (roots v))
bs
| Tast.Set (_, v) | Tast.Return (Some v) | Tast.Some_ v -> deny [ v ]
| Tast.Arr es | Tast.MakeCase (_, _, es)
| Tast.InvokeRestart (_, _, es, _, _, _) -> deny es
| Tast.Make (n, es) -> if not (is_env_struct n) then deny es
| Tast.Addr (Tast.Plocal s) ->
escape (try Hashtbl.find slot s with Not_found -> [])
| Tast.Prim (Tast.Rt _, es) | Tast.Prim (Tast.AddrOf, es) -> deny es
| Tast.CallPtr (_, es) -> deny es
| Tast.Call (name, es) ->
if Hashtbl.mem by_name name && not dev then
List.iteri (fun i a -> if Hashtbl.mem pars (name, i) then deny [ a ]) es
else deny es
| Tast.Closure (Tast.Flanfn n, { Tast.e = Tast.Addr (Tast.Plocal s); _ }) ->
(match Hashtbl.find_opt makes s with
| Some fields -> captured fields (Hashtbl.mem lits n) n
| None -> ())
| Tast.Handled (hs, _) ->
List.iter
(fun (h : Tast.hframe) ->
match h.Tast.henv with
| Some { Tast.e = Tast.Addr (Tast.Plocal s); _ } ->
(match Hashtbl.find_opt makes s with
| Some fields -> captured fields false h.Tast.hfn
| None -> ())
| _ -> ())
hs
| _ -> ()
in
(* Twice over the body: an environment struct is bound around the form
that names it, and a slot's sources are complete before a use of it
elsewhere in a loop is asked about. *)
for _ = 1 to 2 do
List.iter (Tast.walk go) fn.Tast.body;
List.iter (Tast.walk go) fn.Tast.fdefers
done;
if is_fn fn.Tast.ret then
match List.rev fn.Tast.body with x :: _ -> escape (roots x) | [] -> ()
in
while !changed do
changed := false;
List.iter pass fns
done;
if Hashtbl.length lits = 0 then fns
else begin
let rec rw (e : Tast.expr) : Tast.expr =
let r = rw and rs = List.map rw in
let e' =
match e.Tast.e with
| Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit
| Tast.Zero _ | Tast.Uninit _ | Tast.Local _ | Tast.Global _
| Tast.None_ | Tast.FnAddr _ | Tast.Break _ | Tast.Continue _ -> e.Tast.e
| Tast.Fill (t, b) -> Tast.Fill (t, r b)
| Tast.DeadBeef (t, b) -> Tast.DeadBeef (t, r b)
| Tast.Prim (p, es) -> Tast.Prim (p, rs es)
| Tast.Call (n, es) -> Tast.Call (n, rs es)
| Tast.Do es -> Tast.Do (rs es)
| Tast.Make (n, es) -> Tast.Make (n, rs es)
| Tast.MakeCase (a, b, es) -> Tast.MakeCase (a, b, rs es)
| Tast.Arr es -> Tast.Arr (rs es)
| Tast.InvokeRestart (a, b, es, c, d, l) ->
Tast.InvokeRestart (a, b, rs es, c, d, l)
| Tast.CallPtr (c, es) -> Tast.CallPtr (r c, rs es)
(* The rewrite itself: the store of the copies into this frame and
the value carrying their address become the value carrying the
copies, which the backend stores into a collector allocation. *)
| Tast.Let
([ (_, make) ], [ { Tast.e = Tast.Closure ((Tast.Flanfn n as fr), _); _ } ])
when Hashtbl.mem lits n ->
Tast.Closure (fr, r make)
| Tast.Let (bs, body) ->
Tast.Let (List.map (fun (s, v) -> (s, r v)) bs, rs body)
| Tast.If (a, b, c) -> Tast.If (r a, r b, r c)
| Tast.While (c, body, latch) -> Tast.While (r c, rs body, rs latch)
| Tast.Return v -> Tast.Return (Option.map r v)
| Tast.Set (p, v) -> Tast.Set (rp p, r v)
| Tast.Addr p -> Tast.Addr (rp p)
| Tast.Field (t, i) -> Tast.Field (r t, i)
| Tast.Deref t -> Tast.Deref (r t)
| Tast.CaseField (t, c, i) -> Tast.CaseField (r t, c, i)
| Tast.Some_ t -> Tast.Some_ (r t)
| Tast.UnwrapSome t -> Tast.UnwrapSome (r t)
| Tast.Signal (k, i, t) -> Tast.Signal (k, i, r t)
| Tast.Closure (f, t) -> Tast.Closure (f, r t)
| Tast.Thicken (n, t) -> Tast.Thicken (n, r t)
| Tast.Match (sc, arms) ->
Tast.Match
(r sc,
List.map (fun (a : Tast.arm) -> { a with Tast.abody = rs a.Tast.abody }) arms)
| Tast.Handled (hs, body) ->
Tast.Handled
(List.map
(fun (h : Tast.hframe) -> { h with Tast.henv = Option.map r h.Tast.henv })
hs,
rs body)
| Tast.RestartCase (cs, body) ->
Tast.RestartCase
(List.map (fun (c : Tast.rclause) -> { c with Tast.rbody = rs c.Tast.rbody }) cs,
r body)
| Tast.WithAlloc (a, body) -> Tast.WithAlloc (r a, rs body)
in
if e' == e.Tast.e then e else { e with Tast.e = e' }
and rp (p : Tast.place) : Tast.place =
match p with
| Tast.Plocal _ | Tast.Pglobal _ -> p
| Tast.Pfield (t, i) -> Tast.Pfield (rw t, i)
| Tast.Pderef t -> Tast.Pderef (rw t)
| Tast.Pindex (t, idx) -> Tast.Pindex (rw t, List.map rw idx)
in
List.map
(fun (f : Tast.fn) ->
{ f with Tast.body = List.map rw f.Tast.body;
fdefers = List.map rw f.Tast.fdefers })
fns
end
let dev_program (p : Tast.program) =
{ p with Tast.fns = place ~dev:true p.Tast.fns }

505
lib/emit.ml
View File

@ -428,6 +428,34 @@ let dfile d path =
let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a
(* One word inside an instance that the collector follows, located twice.
[goff] is the byte offset under [lay]'s numbers, which are x86-64's and are
what the hand-written backend writes. [gpath] is the same place as a walk
an LLVM [getelementptr] can take — each step a type and its indices — so
the LLVM backend can write the offset as a constant expression and let the
target's own layout answer it. That is the difference on wasm32, where a
pointer is four bytes and [goff] would name the wrong word. *)
type gcword = { goff : int; gpath : (string * string list) list }
(* Every word of an instance the collector follows, by kind — the three
tables of runtime/flan_dyn.h's [flan_desc]. [gvec] carries each Vec's
element type, whose own descriptor the entry points at. *)
type gclayout = {
gdyn : gcword list;
genv : gcword list;
gvec : (gcword * Types.t) list;
}
(* A descriptor this module has to write out: its symbol, the words, the
instance size, and the symbol of each Vec entry's element descriptor in
[gvec]'s order. *)
type desc = {
dsym : string;
dlay : gclayout;
dsize : int;
dvecs : string list;
}
(* ── Module-level state ────────────────────────────────────────────── *) (* ── Module-level state ────────────────────────────────────────────── *)
type m = { type m = {
@ -450,6 +478,16 @@ type m = {
externs : (string, string) Hashtbl.t; externs : (string, string) Hashtbl.t;
checks : bool; (* emit bounds checks *) checks : bool; (* emit bounds checks *)
dev : bool; (* call through cells (below) *) dev : bool; (* call through cells (below) *)
(* Whether an [(Fn ...)] value may carry an environment the collector owns,
which is what makes its second word something to root and to mark. True
when the program has a capturing [fn] that outlives its frame (see
[Check.place_closures]), and always in a dev
build — a redefinition can add the first one, and the frames of the
running program would then hold function values nobody had rooted. When
it is false every [Fn] word is a code address or null, and nothing roots
one or starts the collector for it: the static side does not pay for the
dynamic one. See [gc_layout]. *)
gcfn : bool;
(* Was this name in the build the running process came from? False only in a (* Was this name in the build the running process came from? False only in a
redefinition module, and only for a name introduced since. *) redefinition module, and only for a name introduced since. *)
known : string -> bool; known : string -> bool;
@ -505,8 +543,10 @@ type m = {
the entries that named it came off when the frames that pushed them did, the entries that named it came off when the frames that pushed them did,
and no value of any type points at one. A redefinition module naming a and no value of any type points at one. A redefinition module naming a
type the base program already named therefore gets its own copy, which is type the base program already named therefore gets its own copy, which is
harmless — a descriptor is read-only and has no identity. *) harmless — a descriptor is read-only and has no identity. A closure's
descs : (string, string * int list * int) Hashtbl.t; environment is the exception: it points at its descriptor for as long as
it lives, which is why making one counts in [nstr]. *)
descs : (string, desc) Hashtbl.t;
(* Every Flan function in the program, by name, with its parameters and its (* Every Flan function in the program, by name, with its parameters and its
return: what a dev call site compares the cell's signature word against. return: what a dev call site compares the cell's signature word against.
Filled from the program the module is built from, which in a Filled from the program the module is built from, which in a
@ -730,20 +770,198 @@ let desc_mangle (t : Types.t) =
order is deterministic. Private or local in both backends, so a redefinition order is deterministic. Private or local in both backends, so a redefinition
module naming the same type as the program it patches is not a duplicate module naming the same type as the program it patches is not a duplicate
symbol. *) symbol. *)
let desc_of m (t : Types.t) : string option = let rec desc_of m (t : Types.t) : string option =
match dyn_offsets m t with let l = gc_layout m t in
| [] -> None if l.gdyn = [] && l.genv = [] && l.gvec = [] then None
| offs -> else
let key = Types.to_string t in let key = Types.to_string t in
match Hashtbl.find_opt m.descs key with match Hashtbl.find_opt m.descs key with
| Some (sym, _, _) -> Some sym | Some d -> Some d.dsym
| None -> | None ->
let sym = let sym =
Printf.sprintf "flan.desc.%s.%d" (desc_mangle t) (Hashtbl.length m.descs) Printf.sprintf "flan.desc.%s.%d" (desc_mangle t) (Hashtbl.length m.descs)
in in
Hashtbl.replace m.descs key (sym, offs, fst (lay m t)); (* Claimed before the elements are asked for, so the counter a nested
element's symbol takes cannot be this one's. *)
Hashtbl.replace m.descs key
{ dsym = sym; dlay = l; dsize = fst (lay m t); dvecs = [] };
let dvecs =
List.map
(fun (_, e) ->
match desc_of m e with
| Some s -> s
| None -> internal "a Vec entry whose element has no words")
l.gvec
in
Hashtbl.replace m.descs key
{ dsym = sym; dlay = l; dsize = fst (lay m t); dvecs };
Some sym Some sym
(* ── The words the collector follows ─────────────────────────────────
What [dyn_offsets] answers, widened by the two words closures added: the
environment half of an [(Fn ...)] value, and a [(Vec T)] whose elements hold
one. Both only when [m.gcfn] — a program that never makes a capturing [fn]
has no environment anywhere for the collector to find, so its [Fn] values
are code addresses and null and are rooted by nothing, exactly as before.
The dyn words are gathered where [dyn_offsets] gathers them and nowhere
else: a dyn inside an [Option], a data type's payload, a union or a Vec is
refused by [Check.hidden_dyn], so there is nothing more to find.
The environment words are gathered through all of those as well. An
[(Option (Fn ...))] is how a struct field or a global holds a function
value — a bare one would be zeroed — and a data type or a union overlays
its cases, so which bytes are a function value depends on a tag this table
cannot read. Naming every case's word is sound here, and would not be for
a dyn, because the collector never reads *through* an environment word it
did not allocate: it asks its own set first (runtime/flan_dyn.c's
[mark_env]). The word of a case that is not the live one is an integer or
half of something else, it is not in the set, and it is passed over.
Duplicates are kept apart by path, not by offset. Two cases can put a word
at the same x86-64 offset and at different wasm32 ones, and marking a word
twice costs nothing. *)
and gc_layout m (t : Types.t) : gclayout =
let dyn = ref [] and env = ref [] and vec = ref [] in
let step ty idx path = path @ [ (ty, idx) ] in
let rec go ~full seen off path (t : Types.t) =
match t with
| Types.Dyn -> if full then dyn := { goff = off; gpath = path } :: !dyn
| Types.Fn _ when m.gcfn ->
env := { goff = off + 8; gpath = step "%fnv" [ "i32 0"; "i32 1" ] path }
:: !env
(* Asked with [reaches_fn] and not by laying the element out: a data type
may hold a Vec of itself, and the element's own descriptor, which
[desc_of] claims before it recurses, is what closes that loop. *)
| Types.Vec e when m.gcfn ->
if reaches_fn m [] e then vec := ({ goff = off; gpath = path }, e) :: !vec
| Types.Array (n, e) ->
let s, _ = lay m e in
for i = 0 to Int64.to_int n - 1 do
go ~full seen (off + (i * s))
(step (ll t) [ "i32 0"; Printf.sprintf "i64 %d" i ] path) e
done
| Types.Option e when m.gcfn ->
let _, _, offs = lay_fields m [ Types.Int Types.I8; e ] in
go ~full:false seen (off + List.nth offs 1)
(step (ll t) [ "i32 0"; "i32 1" ] path) e
| Types.Named nm when not (List.mem nm seen) ->
let seen = nm :: seen in
(match Hashtbl.find_opt m.structs nm with
| Some st ->
let tys = List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields in
let _, _, offs = lay_fields m tys in
List.iteri
(fun i (ty, o) ->
go ~full seen (off + o)
(step (sname nm) [ "i32 0"; Printf.sprintf "i32 %d" i ] path) ty)
(List.combine tys offs)
| None when not m.gcfn -> ()
| None ->
match Hashtbl.find_opt m.datas nm with
| Some u ->
let size, align = payload_lay m u in
if size > 0 then begin
let _, _, poffs =
lay_fields m
[ Types.Int Types.I32;
Types.Array (Int64.of_int (size / align),
Types.Int (int_kind (align * 8))) ]
in
let poff = off + List.nth poffs 1 in
let ppath = step (sname nm) [ "i32 0"; "i32 1" ] path in
List.iter
(fun (c : Tast.variant) ->
let tys =
List.map (fun (fl : Tast.field) -> fl.Tast.fty) c.Tast.vfields
in
let _, _, offs = lay_fields m tys in
List.iteri
(fun i (ty, o) ->
go ~full:false seen (poff + o)
(step (sname (nm ^ "." ^ c.Tast.vname))
[ "i32 0"; Printf.sprintf "i32 %d" i ] ppath) ty)
(List.combine tys offs))
u.Tast.cases
end
| None ->
match Hashtbl.find_opt m.unions nm with
| Some u ->
(* Every member starts where the union does, so the walk goes on
from the same place with the member's own type. *)
List.iter
(fun (fl : Tast.field) -> go ~full:false seen off path fl.Tast.fty)
u.Tast.fields
| None -> ())
| _ -> ()
in
go ~full:true [] 0 [] t;
let order (a : gcword) (b : gcword) =
match compare a.goff b.goff with 0 -> compare a.gpath b.gpath | c -> c
in
let uniq l = List.sort_uniq order l in
{ gdyn = uniq !dyn; genv = uniq !env;
gvec = List.sort_uniq (fun (a, _) (b, _) -> order a b) !vec }
(* Whether an [(Fn ...)] is anywhere in a value's storage, a Vec's elements
included. A type met again on the way contributes nothing more, which
terminates a data type holding a Vec of itself without losing a function
value found along another path. *)
and reaches_fn m seen (t : Types.t) =
match t with
| Types.Fn _ -> true
| Types.Array (_, e) | Types.Vec e | Types.Option e -> reaches_fn m seen e
| Types.Named nm when not (List.mem nm seen) ->
let seen = nm :: seen in
let fields =
match Hashtbl.find_opt m.structs nm with
| Some st -> st.Tast.fields
| None ->
match Hashtbl.find_opt m.datas nm with
| Some u -> List.concat_map (fun (c : Tast.variant) -> c.Tast.vfields) u.Tast.cases
| None ->
match Hashtbl.find_opt m.unions nm with
| Some u -> u.Tast.fields
| None -> []
in
List.exists (fun (fl : Tast.field) -> reaches_fn m seen fl.Tast.fty) fields
| _ -> false
(* Whether the collector has anything to follow in a value of this type —
the question every rooting decision asks. [dyn_offsets <> []] was that
question until an [Fn] could hold an environment. *)
let traced m (t : Types.t) =
t = Types.Dyn
|| (let l = gc_layout m t in l.gdyn <> [] || l.genv <> [] || l.gvec <> [])
(* The words to clear before an instance at a pushed root can be marked, as
x86-64 byte offsets of eight-byte words: each dyn word, each environment
word, and each Vec header's pointer and length. The LLVM backend walks
[gpath] instead; see [zero_words]. *)
let gc_zero_offsets m (t : Types.t) : int list =
if t = Types.Dyn then [ 0 ]
else
let l = gc_layout m t in
List.map (fun w -> w.goff) l.gdyn
@ List.map (fun w -> w.goff) l.genv
@ List.concat_map (fun (w, _) -> [ w.goff; w.goff + 8 ]) l.gvec
(* A [gpath] as an LLVM constant expression over [base]: nested constant
[getelementptr]s, one per step. Over [ptr null] and through [ptrtoint] it
is the word's byte offset on whatever target the module is compiled for. *)
let path_const base path =
List.fold_left
(fun acc (ty, idx) ->
Printf.sprintf "getelementptr (%s, ptr %s, %s)" ty acc
(String.concat ", " idx))
base path
let offset_const (w : gcword) =
match w.gpath with
| [] -> "0"
| p -> Printf.sprintf "ptrtoint (ptr %s to i64)" (path_const "null" p)
(* A DWARF type node for a Flan type, memoised by the type's printed form so (* A DWARF type node for a Flan type, memoised by the type's printed form so
the pool holds one node per distinct type. *) the pool holds one node per distinct type. *)
let rec dty m d (t : Types.t) : int = let rec dty m d (t : Types.t) : int =
@ -1323,11 +1541,15 @@ type rootplan = {
exactly as they spill a call's result. For an operand taken by address the exactly as they spill a call's result. For an operand taken by address the
node pinned is the temporary under it, found by [addr_base]; a place under node pinned is the temporary under it, found by [addr_base]; a place under
it needs nothing, and neither backend evaluates one through either hook. *) it needs nothing, and neither backend evaluates one through either hook. *)
let held_operands m (e : Tast.expr) : Tast.expr list = let held_operands m ?(fn_params = fun _ -> false) (e : Tast.expr) :
Tast.expr list =
let holds (x : Tast.expr) = let holds (x : Tast.expr) =
(x.Tast.ty = Types.Dyn || dyn_offsets m x.Tast.ty <> []) traced m x.Tast.ty
&& (match x.Tast.e with && (match x.Tast.e with
| Tast.Call _ | Tast.CallPtr _ -> false | Tast.Call _ | Tast.CallPtr _ -> false
(* A parameter of function type cannot be assigned, so no sibling can
take the value away from under it; its caller holds it. *)
| Tast.Local s when fn_params s -> false
| Tast.Prim (Tast.Rt _, _) -> x.Tast.ty <> Types.Dyn | Tast.Prim (Tast.Rt _, _) -> x.Tast.ty <> Types.Dyn
| Tast.Zero _ | Tast.Uninit _ | Tast.None_ | Tast.Unit -> false | Tast.Zero _ | Tast.Uninit _ | Tast.None_ | Tast.Unit -> false
| _ -> true) | _ -> true)
@ -1361,24 +1583,57 @@ let held_operands m (e : Tast.expr) : Tast.expr list =
let is_array (x : Tast.expr) = let is_array (x : Tast.expr) =
match x.Tast.ty with Types.Array _ -> true | _ -> false match x.Tast.ty with Types.Array _ -> true | _ -> false
in in
(* A function value handed to a call is held by the caller for the whole of
the call, because the callee does not root a parameter of function type
(see [root_plan]). A read of a rooted local is held already; anything
else — a field, an element, a global the callee could overwrite, a fresh
closure — is pinned whatever its siblings are. *)
let fn_args es =
if not m.gcfn then []
else
List.filter
(fun (x : Tast.expr) ->
(match x.Tast.ty with Types.Fn _ -> true | _ -> false)
&& (match x.Tast.e with
| Tast.Local _ | Tast.Call _ | Tast.CallPtr _ | Tast.FnAddr _
| Tast.Thicken _ -> false
| Tast.Closure (_, env) ->
(match env.Tast.ty with Types.Ptr _ -> false | _ -> true)
| _ -> true))
es
in
let with_fn_args es picked =
picked @ List.filter (fun x -> not (List.memq x picked)) (fn_args es)
in
match e.Tast.e with match e.Tast.e with
| Tast.Call (_, es) -> with_fn_args es (pick (by_value es))
| Tast.CallPtr (c, es) -> with_fn_args es (pick (by_value (c :: es)))
| Tast.Prim (Tast.Rt _, es) -> pick (List.map (fun x -> (x, is_array x)) es) | Tast.Prim (Tast.Rt _, es) -> pick (List.map (fun x -> (x, is_array x)) es)
| Tast.Prim ((Tast.At | Tast.Slice), t :: rest) -> | Tast.Prim ((Tast.At | Tast.Slice), t :: rest) ->
pick ((t, true) :: by_value rest) pick ((t, true) :: by_value rest)
| Tast.Prim (_, es) | Tast.Call (_, es) | Tast.Make (_, es) | Tast.Prim (_, es) | Tast.Make (_, es)
| Tast.MakeCase (_, _, es) | Tast.Arr es -> pick (by_value es) | Tast.MakeCase (_, _, es) | Tast.Arr es -> pick (by_value es)
| Tast.CallPtr (c, es) -> pick (by_value (c :: es))
| _ -> [] | _ -> []
let root_plan m (fn : Tast.fn) : rootplan = let root_plan m (fn : Tast.fn) : rootplan =
let rslots = ref [] in let rslots = ref [] in
let nparams = List.length fn.Tast.params in
Array.iteri Array.iteri
(fun i t -> (fun i t ->
if t = Types.Dyn || dyn_offsets m t <> [] then (* A parameter of function type is not rooted here: a parameter
cannot be assigned, so it holds what the caller passed for the whole
call, and the caller holds that — in a rooted slot, or pinned by
[held_operands]. This is what keeps a higher-order function such as
the prelude's [map] free of root pushes in a program that makes an
escaping closure somewhere else. *)
let fn_param =
i < nparams && (match t with Types.Fn _ -> true | _ -> false)
in
if traced m t && not fn_param then
rslots := (i, t) :: !rslots) rslots := (i, t) :: !rslots)
fn.Tast.slots; fn.Tast.slots;
let dyn = ref 0 and agg = ref [] in let dyn = ref 0 and agg = ref [] in
let want (t : Types.t) = t <> Types.Dyn && dyn_offsets m t <> [] in let want (t : Types.t) = t <> Types.Dyn && traced m t in
(* The pinned operands first, as a set of nodes. The checker shares a node (* The pinned operands first, as a set of nodes. The checker shares a node
between two positions now and then — the same [Local] read in two places between two positions now and then — the same [Local] read in two places
— and the backends spill by identity, so a node pinned in one position is — and the backends spill by identity, so a node pinned in one position is
@ -1389,7 +1644,10 @@ let root_plan m (fn : Tast.fn) : rootplan =
let collect (e : Tast.expr) = let collect (e : Tast.expr) =
List.iter List.iter
(fun x -> if not (List.memq x !pins) then pins := x :: !pins) (fun x -> if not (List.memq x !pins) then pins := x :: !pins)
(held_operands m e) (held_operands m ~fn_params:(fun s ->
s < List.length fn.Tast.params
&& (match fn.Tast.slots.(s) with Types.Fn _ -> true | _ -> false))
e)
in in
List.iter (Tast.walk collect) fn.Tast.body; List.iter (Tast.walk collect) fn.Tast.body;
List.iter (Tast.walk collect) fn.Tast.fdefers; List.iter (Tast.walk collect) fn.Tast.fdefers;
@ -2248,7 +2506,36 @@ and value_at f (e : Tast.expr) : string =
let code, env = let code, env =
match e.Tast.e with match e.Tast.e with
| Tast.FnAddr r -> fnaddr f ~loc:e.Tast.loc r, "null" | Tast.FnAddr r -> fnaddr f ~loc:e.Tast.loc r, "null"
| Tast.Closure (r, env) -> fnaddr f ~loc:e.Tast.loc r, value f env (* The copies, made here as a struct value and stored into an
environment the collector allocates. Built before the allocation:
every field is a read of a slot, and those slots are still rooted
while the allocation collects. The fresh object is in the
runtime's allocation ring until this value reaches a root. *)
(* A closure that does not outlive this frame: its copies are in a
slot of it, and the value carries that slot's address. *)
| Tast.Closure (r, env)
when (match env.Tast.ty with Types.Ptr _ -> true | _ -> false) ->
fnaddr f ~loc:e.Tast.loc r, value f env
| Tast.Closure (r, copies) ->
(* The environment will point at this module's descriptor, and the
value at this module's code, for as long as the collector keeps it.
Counted with the string literals so an expression thunk that makes
one keeps its mapping rather than being unloaded under it. *)
f.md.nstr <- f.md.nstr + 1;
let v = value f copies in
let ety = copies.Tast.ty in
let desc =
match desc_of f.md ety with
| Some s -> Printf.sprintf "@\"%s\"" s
| None -> "null"
in
let p = fresh f in
ins f
"%s = call ptr @flan_dyn_env_new(i64 ptrtoint (ptr getelementptr (%s, \
ptr null, i32 1) to i64), ptr %s)"
p (ll ety) desc;
ins f "store %s %s, ptr %s" (ll ety) v p;
fnaddr f ~loc:e.Tast.loc r, p
(* The widening: the thunk's code, with the bare address stored where (* The widening: the thunk's code, with the bare address stored where
an environment would be. The thunk reads it back out and calls it, an environment would be. The thunk reads it back out and calls it,
which is what keeps every indirect call exactly typed. *) which is what keeps every indirect call exactly typed. *)
@ -2487,7 +2774,7 @@ and addr f (e : Tast.expr) : string =
unrooted copy. [root_plan] counts exactly these two callers. *) unrooted copy. [root_plan] counts exactly these two callers. *)
and addr_rooted f (e : Tast.expr) : string = and addr_rooted f (e : Tast.expr) : string =
if addr_is_place e || e.Tast.ty = Types.Dyn if addr_is_place e || e.Tast.ty = Types.Dyn
|| dyn_offsets f.md e.Tast.ty = [] then addr f e || not (traced f.md e.Tast.ty) then addr f e
else begin else begin
let tmp = agg_tmp f e.Tast.ty in let tmp = agg_tmp f e.Tast.ty in
let v = value f e in let v = value f e in
@ -2798,7 +3085,7 @@ and call_through f ?env ret callee vs =
let slot = dyn_tmp f in let slot = dyn_tmp f in
ins f "store i64 %s, ptr %s" t slot ins f "store i64 %s, ptr %s" t slot
end end
else if dyn_offsets f.md ret <> [] then begin else if traced f.md ret then begin
let slot = agg_tmp f ret in let slot = agg_tmp f ret in
ins f "store %s %s, ptr %s" (ll ret) t slot ins f "store %s %s, ptr %s" (ll ret) t slot
end; end;
@ -3840,22 +4127,39 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
in in
if nroots > 0 then begin if nroots > 0 then begin
let nparams = List.length fn.Tast.params in let nparams = List.length fn.Tast.params in
(* Zeroing the dyn words at [base], which is the whole of the contract (* Zeroing the words the collector reads at [base], which is the whole of
runtime/flan_dyn.h states for a pushed root. *) the contract runtime/flan_dyn.h states for a pushed root: each dyn
word, each environment word, and each Vec header's pointer and length.
Reached through the word's [gpath], so the store lands where the
target lays the word out and not where x86-64 would. *)
let zero_dyn base (ty : Types.t) = let zero_dyn base (ty : Types.t) =
if ty = Types.Dyn then if ty = Types.Dyn then
Buffer.add_string f.allocas (Printf.sprintf " store i64 0, ptr %s\n" base) Buffer.add_string f.allocas (Printf.sprintf " store i64 0, ptr %s\n" base)
else else begin
List.iter let at path =
(fun off -> List.fold_left
(fun acc (sty, idx) ->
let p = Printf.sprintf "%%z%d" f.n in let p = Printf.sprintf "%%z%d" f.n in
f.n <- f.n + 1; f.n <- f.n + 1;
Buffer.add_string f.allocas Buffer.add_string f.allocas
(Printf.sprintf " %s = getelementptr inbounds i8, ptr %s, i64 %d\n" (Printf.sprintf " %s = getelementptr inbounds %s, ptr %s, %s\n"
p base off); p sty acc (String.concat ", " idx));
p)
base path
in
let store what path =
Buffer.add_string f.allocas Buffer.add_string f.allocas
(Printf.sprintf " store i64 0, ptr %s\n" p)) (Printf.sprintf " store %s, ptr %s\n" what (at path))
(dyn_offsets m ty) in
let l = gc_layout m ty in
List.iter (fun w -> store "i64 0" w.gpath) l.gdyn;
List.iter (fun w -> store "ptr null" w.gpath) l.genv;
List.iter
(fun ((w : gcword), _) ->
store "ptr null" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 0" ]) ]);
store "i64 0" (w.gpath @ [ ("%vec", [ "i32 0"; "i32 1" ]) ]))
l.gvec
end
in in
let push base (ty : Types.t) = let push base (ty : Types.t) =
match (if ty = Types.Dyn then None else desc_of m ty) with match (if ty = Types.Dyn then None else desc_of m ty) with
@ -4528,6 +4832,8 @@ declare i64 @flan_dyn_view_vec(ptr, i32)
declare i64 @flan_dyn_view_flat(ptr, i64, i32) declare i64 @flan_dyn_view_flat(ptr, i64, i32)
declare void @flan_dyn_root_push(ptr) declare void @flan_dyn_root_push(ptr)
declare void @flan_dyn_root_push_desc(ptr, ptr) declare void @flan_dyn_root_push_desc(ptr, ptr)
declare ptr @flan_dyn_env_new(i64, ptr)
declare void @flan_dyn_track_vecs()
declare void @flan_dyn_root_pop(i64) declare void @flan_dyn_root_pop(i64)
declare void @flan_dyn_root_globals_begin() declare void @flan_dyn_root_globals_begin()
declare void @flan_dyn_root_globals_end() declare void @flan_dyn_root_globals_end()
@ -4612,7 +4918,29 @@ declare i8 @flan_slurp_into(ptr, ptr, i64, i64, ptr, i64)
Every shape a dyn can take is one of these: a global of that type, a Every shape a dyn can take is one of these: a global of that type, a
signature that mentions it, a slot that holds one, or an expression that signature that mentions it, a slot that holds one, or an expression that
produces one. *) produces one. *)
(* Whether any closure in the program has its environment allocated by the
collector. *)
let makes_closures (p : Tast.program) =
let found = ref false in
let see (e : Tast.expr) =
match e.Tast.e with
| Tast.Closure (_, env)
when (match env.Tast.ty with Types.Ptr _ -> false | _ -> true) ->
found := true
| _ -> ()
in
List.iter
(fun (fn : Tast.fn) ->
List.iter (Tast.walk see) fn.Tast.body;
List.iter (Tast.walk see) fn.Tast.fdefers)
p.Tast.fns;
List.iter (fun (g : Tast.global) -> Tast.walk see g.Tast.ginit) p.Tast.globals;
!found
(* A program that makes a capturing [fn] allocates its environments from the
collector, so it has a heap to set up even if no dyn is ever written. *)
let uses_dyn (p : Tast.program) = let uses_dyn (p : Tast.program) =
makes_closures p ||
let structs = Hashtbl.create 16 in let structs = Hashtbl.create 16 in
List.iter List.iter
(fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s) (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s)
@ -4658,6 +4986,12 @@ let emit_main m ?(startup = false) ?(gc = false) ?(dyn_globals = []) (fn : Tast.
dyn global's initialiser runs in the startup function below, and the very dyn global's initialiser runs in the startup function below, and the very
first thing it does is allocate. *) first thing it does is allocate. *)
if gc then Buffer.add_string b " call void @flan_gc_init()\n"; if gc then Buffer.add_string b " call void @flan_gc_init()\n";
(* Before anything can allocate a Vec block: a program that can make a
collector-owned closure environment has flan_rt.c report every Vec block
to the collector, which reads a Vec's elements only through a block it
knows to be live (runtime/flan_dyn.c, "The Vec blocks a marker may
read"). *)
if m.gcfn then Buffer.add_string b " call void @flan_dyn_track_vecs()\n";
(* The dyn globals, rooted here and never popped, which is the whole of what (* The dyn globals, rooted here and never popped, which is the whole of what
a global's extent means. They go on the stack *before* the startup a global's extent means. They go on the stack *before* the startup
function runs, because that function is what fills them and its first function runs, because that function is what fills them and its first
@ -4795,7 +5129,8 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
unions = Hashtbl.create 16; unions = Hashtbl.create 16;
globals = Hashtbl.create 16; globals = Hashtbl.create 16;
externs = Hashtbl.create 32; externs = Hashtbl.create 32;
checks; dev; known; nstr = 0; nfi = 0; sanitize; ann = annotate; checks; dev; gcfn = dev || makes_closures p;
known; nstr = 0; nfi = 0; sanitize; ann = annotate;
descs = Hashtbl.create 8; descs = Hashtbl.create 8;
dbg = (if debug then Some (new_dbg p) else None); dbg = (if debug then Some (new_dbg p) else None);
fsigs = fsigs_of p; fsigs = fsigs_of p;
@ -4898,35 +5233,61 @@ let dmodule d =
Buffer.add_buffer b d.dout; Buffer.add_buffer b d.dout;
Buffer.contents b Buffer.contents b
(* The per-type dyn descriptors, as runtime/flan_dyn.h's [flan_desc] laid out (* The per-type descriptors, as runtime/flan_dyn.h's [flan_desc] laid out by
by hand: two i64s and a pointer to the offset table. [private] because a hand: the size, then a count and a table for each of the three kinds of
redefinition module may name a type the program it patches already named, word. An empty table is a null pointer rather than a zero-length array.
and a private constant has no symbol for the two to collide over. Sorted, so [private] because a redefinition module may name a type the program it
the .ll is reproducible build to build. *) patches already named, and a private constant has no symbol for the two to
collide over. Sorted, so the .ll is reproducible build to build.
Every offset is a constant expression over the word's [gpath] rather than
a number, so the offset is the one the target lays the type out with — on
wasm32 a pointer is four bytes, and [goff]'s x86-64 number would name the
wrong word. [size] stays [lay]'s number: it is only read as a Vec's
element stride, and a Vec's elements are placed at that stride by the
[SizeOf] every push is handed. *)
let descriptors m = let descriptors m =
let b = Buffer.create 256 in let b = Buffer.create 256 in
let table sym suffix ty rows =
if rows = [] then "null"
else begin
Buffer.add_string b
(Printf.sprintf "@\"%s.%s\" = private unnamed_addr constant [%d x %s] [%s]\n"
sym suffix (List.length rows) ty (String.concat ", " rows));
Printf.sprintf "@\"%s.%s\"" sym suffix
end
in
let word (w : gcword) = "i64 " ^ offset_const w in
Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs [] Hashtbl.fold (fun k v acc -> (k, v) :: acc) m.descs []
|> List.sort (fun (a, _) (c, _) -> String.compare a c) |> List.sort (fun (a, _) (c, _) -> String.compare a c)
|> List.iter |> List.iter
(fun (_, (sym, offs, size)) -> (fun (_, d) ->
let l = d.dlay in
let offs = table d.dsym "offs" "i64" (List.map word l.gdyn) in
let envs = table d.dsym "envs" "i64" (List.map word l.genv) in
let vecs =
table d.dsym "vecs" "{ i64, ptr }"
(List.map2
(fun ((w : gcword), _) e ->
Printf.sprintf "{ i64, ptr } { i64 %s, ptr @\"%s\" }"
(offset_const w) e)
l.gvec d.dvecs)
in
Buffer.add_string b Buffer.add_string b
(Printf.sprintf (Printf.sprintf
"@\"%s.offs\" = private unnamed_addr constant [%d x i64] [%s]\n" "@\"%s\" = private unnamed_addr constant \
sym (List.length offs) { i64, i64, ptr, i64, ptr, i64, ptr } \
(String.concat ", " { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s }\n"
(List.map (Printf.sprintf "i64 %d") offs))); d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv)
Buffer.add_string b envs (List.length l.gvec) vecs));
(Printf.sprintf
"@\"%s\" = private unnamed_addr constant { i64, i64, ptr } \
{ i64 %d, i64 %d, ptr @\"%s.offs\" }\n"
sym size (List.length offs) sym));
Buffer.contents b Buffer.contents b
(* The same table in the other backend's syntax. It lives here rather than in (* The same table in the other backend's syntax. It lives here rather than in
x86.ml so that the two renderings sit beside each other and the layout the x86.ml so that the two renderings sit beside each other and the layout the
runtime reads is agreed in one place. [.L] so the labels never reach the runtime reads is agreed in one place. [.L] so the labels never reach the
symbol table, which is what lets a redefinition module name a type the symbol table, which is what lets a redefinition module name a type the
program it patches already named. *) program it patches already named. The offsets are [goff]'s numbers, which
are this backend's own layout. *)
let descriptors_asm m = let descriptors_asm m =
let b = Buffer.create 256 in let b = Buffer.create 256 in
let rows = let rows =
@ -4935,10 +5296,11 @@ let descriptors_asm m =
in in
if rows <> [] then if rows <> [] then
Buffer.add_string b Buffer.add_string b
"\n# The per-type dyn descriptors — runtime/flan_dyn.h's flan_desc: the\n\ "\n# The per-type descriptors — runtime/flan_dyn.h's flan_desc: the size\n\
# size of one instance, how many dyn words it holds, and where they are.\n\ # of one instance, then the dyn words, the environment words of its\n\
# Read by the collector through flan_dyn_root_push_desc and by nothing\n\ # function values, and the Vec headers whose elements hold either, each\n\
# else; no value points at one.\n\ # as a count and a table. Read by the collector through\n\
# flan_dyn_root_push_desc and flan_dyn_env_new and by nothing else.\n\
#\n\ #\n\
# .data.rel.ro and not .rodata, because a descriptor holds the address\n\ # .data.rel.ro and not .rodata, because a descriptor holds the address\n\
# of its own offset table. That is a relocation, and a relocation in a\n\ # of its own offset table. That is a relocation, and a relocation in a\n\
@ -4948,20 +5310,41 @@ let descriptors_asm m =
# for exactly this: relocated at load and read-only from then on.\n\ # for exactly this: relocated at load and read-only from then on.\n\
\t.section\t.data.rel.ro,\"aw\",@progbits\n"; \t.section\t.data.rel.ro,\"aw\",@progbits\n";
List.iter List.iter
(fun (_, (sym, offs, size)) -> (fun (_, d) ->
Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym); let l = d.dlay in
List.iter let table suffix lines =
(fun o -> Buffer.add_string b (Printf.sprintf "\t.quad\t%d\n" o)) if lines = [] then "0"
offs; else begin
Buffer.add_string b
(Printf.sprintf "\t.align\t8\n.L%s.%s:\n" d.dsym suffix);
List.iter (fun s -> Buffer.add_string b ("\t.quad\t" ^ s ^ "\n")) lines;
Printf.sprintf ".L%s.%s" d.dsym suffix
end
in
let offs = table "offs" (List.map (fun w -> string_of_int w.goff) l.gdyn) in
let envs = table "envs" (List.map (fun w -> string_of_int w.goff) l.genv) in
let vecs =
table "vecs"
(List.concat
(List.map2
(fun ((w : gcword), _) e -> [ string_of_int w.goff; ".L" ^ e ])
l.gvec d.dvecs))
in
Buffer.add_string b Buffer.add_string b
(Printf.sprintf (Printf.sprintf
"\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t.L%s.offs\n" "\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t%s\n\
sym size (List.length offs) sym)) \t.quad\t%d\n\t.quad\t%s\n\t.quad\t%d\n\t.quad\t%s\n"
d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) envs
(List.length l.gvec) vecs))
rows; rows;
Buffer.contents b Buffer.contents b
(* The descriptors go after the body, because their offsets are constant
expressions over the module's named types and LLVM wants a type defined
before a [getelementptr] can size it. A global may be named before it is
defined, so the functions that push them are unaffected. *)
let finish m = let finish m =
header ^ Buffer.contents m.strs ^ descriptors m ^ "\n" ^ Buffer.contents m.out header ^ Buffer.contents m.strs ^ Buffer.contents m.out ^ "\n" ^ descriptors m
^ (if m.sanitize then "\nattributes #0 = { sanitize_address }\n" else "") ^ (if m.sanitize then "\nattributes #0 = { sanitize_address }\n" else "")
^ (match m.dbg with None -> "" | Some d -> dmodule d) ^ (match m.dbg with None -> "" | Some d -> dmodule d)
@ -5034,6 +5417,10 @@ let macro_thunk m (fn : Tast.fn) =
let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = []) let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
?(sanitize = false) ?(macros = []) ?(hidden = false) ?(annotate = false) ?(sanitize = false) ?(macros = []) ?(hidden = false) ?(annotate = false)
(p : Tast.program) : string = (p : Tast.program) : string =
(* A dev build places closures under the dev rule: a named callee can be
replaced by a redefinition that keeps what it was handed. See
[Closures.place]. *)
let p = if dev then Closures.dev_program p else p in
(* [hidden] and [dev] are opposites and the refusal is here so that they (* [hidden] and [dev] are opposites and the refusal is here so that they
cannot be written together by accident. A dev build's whole point is that cannot be written together by accident. A dev build's whole point is that
its cells, its globals and [flan.abi.*] are in the dynamic symbol table its cells, its globals and [flan.abi.*] are in the dynamic symbol table
@ -5137,7 +5524,7 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
~dyn_globals: ~dyn_globals:
(List.filter_map (List.filter_map
(fun (g : Tast.global) -> (fun (g : Tast.global) ->
if g.Tast.gty = Types.Dyn || dyn_offsets m g.Tast.gty <> [] if traced m g.Tast.gty
then Some (g.Tast.gname, g.Tast.gty) else None) then Some (g.Tast.gname, g.Tast.gty) else None)
p.Tast.globals) p.Tast.globals)
fn fn
@ -5184,6 +5571,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
?(known = fun _ -> true) ?(retains = true) ?(known = fun _ -> true) ?(retains = true)
?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns ?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns
: string = : string =
(* A dev build places closures under the dev rule: a named callee can be
replaced by a redefinition that keeps what it was handed. See
[Closures.place]. *)
let p = if dev then Closures.dev_program p else p in
let target name = let target name =
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> f | Some f -> f

38
lib/session.ml
View File

@ -561,13 +561,16 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) =
(fun (s : Tast.structure) -> (fun (s : Tast.structure) ->
(* An environment the checker synthesised for a capturing fn is not (* An environment the checker synthesised for a capturing fn is not
subject to this rule, and that is not a loophole. The layout rule is subject to this rule, and that is not a loophole. The layout rule is
about values the running program is *holding*: every other struct can about values the running program reads with code newer than the code
be in a global, in a container, in a frame that is on the stack right that wrote them. An environment is only ever read by the lifted body
now. An environment can be in exactly one place — a slot of the frame that was compiled beside the literal that made it: a function value
the literal was written in — and it is written there by the same carries that body's own symbol, not a cell, and a redefinition module
module that reads it, on every entry. So editing which locals an fn carries its own copy of every lifted body it replaces. A value made
names is an ordinary body change, and demanding a restart for it before the reload keeps calling the old body over the old layout —
would take the dev loop away from the feature it was built for. *) and each environment carries the descriptor it was allocated with —
so editing which locals an fn names is an ordinary body change, and
demanding a restart for it would take the dev loop away from the
feature it was built for. *)
if Check.is_env_struct s.Tast.sname then () else if Check.is_env_struct s.Tast.sname then () else
match match
List.find_opt List.find_opt
@ -2378,8 +2381,10 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
below — without this the thunk calls a symbol the module never defines below — without this the thunk calls a symbol the module never defines
and the host has no cell for. *) and the host has no cell for. *)
let mark = Check.instance_mark t.env in let mark = Check.instance_mark t.env in
let lmark = Check.lifted_mark t.env in
let checked, base, bnames = Check.expression t.env parsed in let checked, base, bnames = Check.expression t.env parsed in
let fresh = Check.instances_since t.env mark in let fresh = Check.instances_since t.env mark in
let lifted = Check.lifted_since t.env lmark in
(* The thunk's frame starts at whatever [Check.expression] needed and grows (* The thunk's frame starts at whatever [Check.expression] needed and grows
as the walk finds slices in it, so the slots the renderer asks for are as the walk finds slices in it, so the slots the renderer asks for are
appended past [base] and collected here to size the frame below. *) appended past [base] and collected here to size the frame below. *)
@ -2415,9 +2420,26 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
(* Built against the program but never spliced into it: an evaluation is not (* Built against the program but never spliced into it: an evaluation is not
a declaration, and adding one would leave the session carrying an eval/N a declaration, and adding one would leave the session carrying an eval/N
for every expression ever typed. *) for every expression ever typed. *)
(* A body the expression lifted — an [fn] literal, a handler clause — is
reached by address from the thunk, so it goes into the module with it:
parented on the thunk, which is what makes [redefinition] carry it, and
with the environment struct it captured into, which is what lays it out.
Placed like any other capturing fn, against the whole program, so a
closure the expression keeps gets an environment the collector owns. *)
let lifted =
List.map (fun (f : Tast.fn) -> { f with Tast.fparent = Some name }) lifted
in
let placed =
Check.place_closures (t.program.Tast.fns @ fresh @ lifted @ [ thunk ])
in
let own = List.map (fun (f : Tast.fn) -> f.Tast.name) (lifted @ [ thunk ]) in
let placed =
List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed
in
let program = let program =
{ t.program with { t.program with
Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ]; Tast.fns = t.program.Tast.fns @ fresh @ placed;
structs = t.program.Tast.structs @ Check.env_structs t.env lifted;
externs = t.program.Tast.externs @ externs } externs = t.program.Tast.externs @ externs }
in in
let ir = let ir =

25
lib/tast.ml
View File

@ -112,22 +112,23 @@ and expr_kind =
dev build is not the symbol but whatever the indirection cell holds, and dev build is not the symbol but whatever the indirection cell holds, and
carries the Flan type [Fn]. *) carries the Flan type [Fn]. *)
| FnAddr of fnref | FnAddr of fnref
(* A function value with an environment: the lifted body, and the address of (* A function value with an environment: the lifted body, and one of two
the copies the enclosing frame is holding for it. The environment is a things, told apart by the second expression's type.
[Make] of a struct the checker synthesised, stored into a slot of the
frame the literal was written in, so this node's second half is an - A pointer: the address of a slot of this frame holding the copies, filled
[Addr (Plocal _)] and the copies were taken where the value was made. by the [Let] around this node. A value that never outlives its frame.
- The environment struct itself — a [Make] of the struct the checker
synthesised, every field a read of a local. The backend allocates the
environment from the collector ([flan_dyn_env_new], with the struct's
descriptor), stores the copies into it, and pairs its address with the
code. A value that may outlive its frame: spec-memory.md's case 3.
[Check.place_closures] decides which, once the whole program is checked.
Its own node rather than a field on [FnAddr] because the two answer Its own node rather than a field on [FnAddr] because the two answer
different questions: [FnAddr] is an address, and is asked for by three different questions: [FnAddr] is an address, and is asked for by three
unrelated readers that want a bare symbol ([Alloc]-typed, see [fnref]), unrelated readers that want a bare symbol ([Alloc]-typed, see [fnref]),
while this is a *value* of type [Fn] and can never be anything else. while this is a *value* of type [Fn] and can never be anything else. *)
What stops it dangling is the checker, not this node: a value carrying an
environment may not leave the frame that owns it, so every position that
would outlive the frame is refused. spec-memory.md's case 2, and the
escaping half — an environment the collector allocates — is the case the
refusals name. *)
| Closure of fnref * expr | Closure of fnref * expr
(* A (CFn ...) value where a (Fn ...) is wanted. The one coercion between (* A (CFn ...) value where a (Fn ...) is wanted. The one coercion between
the two function types, and it goes this way only: there is nowhere for the two function types, and it goes this way only: there is nowhere for

57
lib/x86.ml
View File

@ -489,7 +489,8 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m =
p.Tast.globals; p.Tast.globals;
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions; { Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions;
globals; externs = Hashtbl.create 1; checks; globals; externs = Hashtbl.create 1; checks;
dev; known = (fun _ -> true); dbg = None; sanitize = false; ann = false; dev; gcfn = dev || Emit.makes_closures p;
known = (fun _ -> true); dbg = None; sanitize = false; ann = false;
nstr = 0; nfi = 0; descs = Hashtbl.create 8; fsigs = Emit.fsigs_of p } nstr = 0; nfi = 0; descs = Hashtbl.create 8; fsigs = Emit.fsigs_of p }
let sizeof md t = fst (Emit.lay md t) let sizeof md t = fst (Emit.lay md t)
@ -1806,17 +1807,43 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
let env = let env =
match e.Tast.e with match e.Tast.e with
| Tast.FnAddr r -> fnaddr_at f ~loc:e.Tast.loc ~reg:rax r; None | Tast.FnAddr r -> fnaddr_at f ~loc:e.Tast.loc ~reg:rax r; None
| Tast.Closure (r, env) -> fnaddr_at f ~loc:e.Tast.loc ~reg:rax r; Some env (* The environment first, into a frame temporary: allocated by the
collector, then filled with the copies — every field a read of a
slot, so nothing between the allocation and the last store can
collect. The object is in the runtime's allocation ring until the
value reaches a root. *)
(* A closure that does not outlive this frame: its copies are in a
slot of it, and the value carries that slot's address. *)
| Tast.Closure (r, env)
when (match env.Tast.ty with Types.Ptr _ -> true | _ -> false) ->
fnaddr_at f ~loc:e.Tast.loc ~reg:rax r; Some (`Expr env)
| Tast.Closure (r, copies) ->
(* See [Emit]'s arm: the environment points into this module. *)
f.md.Emit.nstr <- f.md.Emit.nstr + 1;
let ety = copies.Tast.ty in
let p = ptmp f in
imm_into f ~reg:rdi (Int64.of_int (sizeof f.md ety));
(match desc_label f.md ety with
| Some l -> lea f.b ~dst:rsi ~mm:(Sym (l, 0))
| None -> xor_rr f.b ~dst:rsi ~src:rsi);
xor_rr f.b ~dst:rax ~src:rax;
call_sym f.b "flan_dyn_env_new";
store_int f.b ~src:rax ~mm:(Frame p) ~size:8;
lower f copies (Lp (p, 0));
fnaddr_at f ~loc:e.Tast.loc ~reg:rax r;
Some (`Made p)
(* The widening: the thunk's code, with the bare address stored where (* The widening: the thunk's code, with the bare address stored where
an environment would be. The thunk reads it back out and calls it, an environment would be. The thunk reads it back out and calls it,
which is what keeps every indirect call exactly typed. *) which is what keeps every indirect call exactly typed. *)
| Tast.Thicken (n, p) -> addr_sym f ~dst:rax (fsym n); Some p | Tast.Thicken (n, p) -> addr_sym f ~dst:rax (fsym n); Some (`Expr p)
| _ -> assert false | _ -> assert false
in in
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8;
(match env with (match env with
| None -> xor_rr f.b ~dst:rax ~src:rax | None -> xor_rr f.b ~dst:rax ~src:rax
| Some ev -> let l = eval f ev in load_loc f ~reg:rax l (Types.Ptr Types.Unit)); | Some (`Made p) -> load_int f.b ~dst:rax ~mm:(Frame p) ~size:8 ~signed:false
| Some (`Expr ev) ->
let l = eval f ev in load_loc f ~reg:rax l (Types.Ptr Types.Unit));
store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8 store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8
| Tast.FnAddr r -> | Tast.FnAddr r ->
fnaddr_at f ~loc:e.Tast.loc ~reg:rax r; fnaddr_at f ~loc:e.Tast.loc ~reg:rax r;
@ -2482,7 +2509,7 @@ and lvalue f (e : Tast.expr) : loc =
decided how many of these slots to mint asked that same function. *) decided how many of these slots to mint asked that same function. *)
and lvalue_rooted f (e : Tast.expr) : loc = and lvalue_rooted f (e : Tast.expr) : loc =
if Emit.addr_is_place e || e.Tast.ty = Types.Dyn if Emit.addr_is_place e || e.Tast.ty = Types.Dyn
|| Emit.dyn_offsets f.md e.Tast.ty = [] then lvalue f e || not (Emit.traced f.md e.Tast.ty) then lvalue f e
else begin else begin
let o = agg_tmp f e.Tast.ty in let o = agg_tmp f e.Tast.ty in
lower f e (Lf o); lower f e (Lf o);
@ -3018,7 +3045,7 @@ and call_flan f ?env ~target ~args ~rty dst =
let o = dyn_tmp f in let o = dyn_tmp f in
store_int f.b ~src:rax ~mm:(Frame o) ~size:8 store_int f.b ~src:rax ~mm:(Frame o) ~size:8
end end
else if (not (is_void rty)) && Emit.dyn_offsets f.md rty <> [] then begin else if (not (is_void rty)) && Emit.traced f.md rty then begin
let o = agg_tmp f rty in let o = agg_tmp f rty in
copy_loc f ~dst:(Lf o) ~src:dst (sizeof f.md rty) copy_loc f ~dst:(Lf o) ~src:dst (sizeof f.md rty)
end end
@ -4000,7 +4027,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
else else
List.iter List.iter
(fun d -> store_int f.b ~src:rax ~mm:(Frame (off + d)) ~size:8) (fun d -> store_int f.b ~src:rax ~mm:(Frame (off + d)) ~size:8)
(Emit.dyn_offsets f.md ty)) (Emit.gc_zero_offsets f.md ty))
!droot_zero; !droot_zero;
List.iter List.iter
(fun (off, ty) -> (fun (off, ty) ->
@ -4398,6 +4425,12 @@ let emit_main ?(ann = false) ?(startup = false) ?(gc = false)
xor_rr b ~dst:rax ~src:rax; xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_gc_init" call_sym b "flan_gc_init"
end; end;
(* A program that can make a collector-owned closure environment has the
collector told of every Vec block from here on; see [Emit.emit_main]. *)
if md.Emit.gcfn then begin
xor_rr b ~dst:rax ~src:rax;
call_sym b "flan_dyn_track_vecs"
end;
(* The dyn globals, rooted here and never popped, which is the whole of what (* The dyn globals, rooted here and never popped, which is the whole of what
a global's extent means. They go on the root stack *before* the startup a global's extent means. They go on the root stack *before* the startup
function runs, because that function is what fills them and its first function runs, because that function is what fills them and its first
@ -4840,6 +4873,10 @@ let emit_dwarf (dw : dwarf) ~cufile ~tbeg ~tend =
(* A whole program as one assembly file. *) (* A whole program as one assembly file. *)
let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
(p : Tast.program) : string = (p : Tast.program) : string =
(* A dev build places closures under the dev rule: a named callee can be
replaced by a redefinition that keeps what it was handed. See
[Closures.place]. *)
let p = if dev then Closures.dev_program p else p in
let md = layout_ctx ~checks ~dev p in let md = layout_ctx ~checks ~dev p in
let externs = Hashtbl.create 16 in let externs = Hashtbl.create 16 in
List.iter List.iter
@ -4979,7 +5016,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
~dyn_globals: ~dyn_globals:
(List.filter_map (List.filter_map
(fun (g : Tast.global) -> (fun (g : Tast.global) ->
if g.Tast.gty = Types.Dyn || Emit.dyn_offsets md g.Tast.gty <> [] if Emit.traced md g.Tast.gty
then Some (g.Tast.gname, g.Tast.gty) else None) then Some (g.Tast.gname, g.Tast.gty) else None)
p.Tast.globals) p.Tast.globals)
md fn) md fn)
@ -5130,6 +5167,10 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
?(retains = true) ?(consts = []) ?call ?(annotate = false) ?(retains = true) ?(consts = []) ?call ?(annotate = false)
(p : Tast.program) ~fns : string = (p : Tast.program) ~fns : string =
(* A dev build places closures under the dev rule: a named callee can be
replaced by a redefinition that keeps what it was handed. See
[Closures.place]. *)
let p = if dev then Closures.dev_program p else p in
if not dev then if not dev then
unsupported unsupported
"x86 redefinition without cells: there is nothing to publish a body \ "x86 redefinition without cells: there is nothing to publish a body \

3
plan.org
View File

@ -276,7 +276,8 @@ and on a managed ~class~ instance. An ordinary ~struct~ never carries one.
pointer with no environment — the only kind that crosses FFI or sits in a reload pointer with no environment — the only kind that crosses FFI or sits in a reload
cell; a *non-escaping* ~fn~ captures enclosing locals by value into a stack cell; a *non-escaping* ~fn~ captures enclosing locals by value into a stack
environment, which is what ~reduce~ callbacks and ~handler-bind~ handlers use; environment, which is what ~reduce~ callbacks and ~handler-bind~ handlers use;
an *escaping* closure needs a heap environment and is still an open decision. an *escaping* closure's environment is allocated by the collector (built
2026-09-25; every capturing ~fn~ takes that path now, see docs/BUILT.md).
- No monads, no HKTs, no type classes. Effects are direct; error handling is - No monads, no HKTs, no type classes. Effects are direct; error handling is
conditions plus ~Option~ and ~or-else~. Monadic sequencing, if ever wanted, is a conditions plus ~Option~ and ~or-else~. Monadic sequencing, if ever wanted, is a
macro. macro.

351
runtime/flan_dyn.c
View File

@ -111,15 +111,40 @@ int8_t flan_vec_push(void *v, const void *elem, int64_t size, int64_t align,
typedef uint64_t flan_dyn; typedef uint64_t flan_dyn;
/* A type's dyn map: where the dyn words are inside one instance of it. The /* A type's map of the words the collector follows: where they are inside one
* compiler emits one of these per type that has any, as static data, and hands * instance of it. The compiler emits one of these per type that has any, as
* a pointer to it to [flan_dyn_root_push_desc]. Nothing here ever writes one. * static data, and hands a pointer to it to [flan_dyn_root_push_desc] or
* [size] is not read by the collector; it is the stride an array of the type * [flan_dyn_env_new]. Nothing here ever writes one.
* has, which is what the typed-container view will need. */ *
* Three kinds of word, one table each:
*
* - [offs]: a dyn word, marked by [mark_value].
* - [envs]: the environment half of an (Fn ...) value, pointer-sized. It holds
* a collector-allocated environment, null, or — for a named function widened
* into an Fn — that function's code address. [mark_env] follows only the
* first, and tells them apart by asking [envset] rather than by reading the
* word, so a code address is never dereferenced.
* - [vecs]: a (Vec T) header whose elements hold words of their own, with the
* element's descriptor. The marker reads the header's pointer and length
* where they are, so a push that reallocated is seen.
*
* [size] is the stride of one instance as the compiler's element-size
* arithmetic counts it, which is what a Vec's elements are laid out at. The
* collector reads it only through a [vecs] entry's element descriptor. */
struct flan_desc;
typedef struct flan_desc_vec {
int64_t off;
const struct flan_desc *elem;
} flan_desc_vec;
typedef struct flan_desc { typedef struct flan_desc {
int64_t size; int64_t size;
int64_t n; int64_t n;
const int64_t *offs; const int64_t *offs;
int64_t nenv;
const int64_t *envs;
int64_t nvec;
const flan_desc_vec *vecs;
} flan_desc; } flan_desc;
#define DYN_QNAN 0xFFF8000000000000ULL #define DYN_QNAN 0xFFF8000000000000ULL
@ -188,6 +213,10 @@ static inline flan_dyn dyn_make(unsigned tag, uint64_t payload) {
#define OBJ_INT 2 /* an i64 too wide for the payload */ #define OBJ_INT 2 /* an i64 too wide for the payload */
#define OBJ_MAP 3 /* keys and values interleaved: k0 v0 k1 v1 ... */ #define OBJ_MAP 3 /* keys and values interleaved: k0 v0 k1 v1 ... */
#define OBJ_VIEW 4 /* a typed container crossing into dyn as a view */ #define OBJ_VIEW 4 /* a typed container crossing into dyn as a view */
#define OBJ_ENV 5 /* a closure's environment: bytes after the header,
marked through the descriptor it was made with.
Never a dyn value — nothing boxes one — so no tag
word, printer or operation ever sees this kind. */
/* flan_vec, restated. This file must not name flan_rt.c's [flan_vec] — see /* flan_vec, restated. This file must not name flan_rt.c's [flan_vec] — see
* the "if either table changes, change both" note above [flan_vec_push] — * the "if either table changes, change both" note above [flan_vec_push] —
@ -295,6 +324,10 @@ typedef struct flan_obj {
at the crossing, for a slice or a fixed array, neither of which moves. at the crossing, for a slice or a fixed array, neither of which moves.
[elem] is one of FLAN_VIEW_I64/F64/BOOL. */ [elem] is one of FLAN_VIEW_I64/F64/BOOL. */
struct { void *base; int64_t len; int32_t elem; int32_t is_vec; } view; struct { void *base; int64_t len; int32_t elem; int32_t is_vec; } view;
/* OBJ_ENV: the descriptor the environment's bytes are marked through,
or NULL when it holds nothing the collector follows. [len] is the
byte count, and the bytes trail the header as a text's do. */
struct { const struct flan_desc *desc; } env;
/* OBJ_TEXT's bytes trail the header; see [obj_text_bytes]. */ /* OBJ_TEXT's bytes trail the header; see [obj_text_bytes]. */
} u; } u;
} flan_obj; } flan_obj;
@ -311,7 +344,7 @@ typedef struct flan_obj {
* is what keeps a future change to the marking gate from silently trusting * is what keeps a future change to the marking gate from silently trusting
* this function's default arm instead of failing loudly. */ * this function's default arm instead of failing loudly. */
static inline int64_t obj_words(flan_obj *o) { static inline int64_t obj_words(flan_obj *o) {
if (o->kind == OBJ_VIEW) return 0; if (o->kind == OBJ_VIEW || o->kind == OBJ_ENV) return 0;
return o->kind == OBJ_MAP ? o->len * 2 : o->len; return o->kind == OBJ_MAP ? o->len * 2 : o->len;
} }
@ -971,9 +1004,11 @@ static int64_t mstack_n, mstack_cap;
static void mark_push(flan_obj *o) { static void mark_push(flan_obj *o) {
if (o == NULL || o->mark) return; if (o == NULL || o->mark) return;
o->mark = 1; o->mark = 1;
/* Only a vec and a map have anything to trace. A text and a boxed int are /* Only a vec, a map and an environment with a descriptor have anything to
* leaves, and marking them is the whole of their visit. */ * trace. A text and a boxed int are leaves, and marking them is the whole
if (o->kind != OBJ_VEC && o->kind != OBJ_MAP) return; * of their visit. */
if (o->kind != OBJ_VEC && o->kind != OBJ_MAP
&& !(o->kind == OBJ_ENV && o->u.env.desc != NULL)) return;
if (mstack_n == mstack_cap) { if (mstack_n == mstack_cap) {
int64_t cap = mstack_cap ? mstack_cap * 2 : 64; int64_t cap = mstack_cap ? mstack_cap * 2 : 64;
flan_obj **m = (flan_obj **)realloc(mstack, (size_t)cap * sizeof *m); flan_obj **m = (flan_obj **)realloc(mstack, (size_t)cap * sizeof *m);
@ -988,22 +1023,289 @@ static void mark_value(flan_dyn v) {
if (dyn_boxed(v) && dyn_box(v) == BOX_OBJ) mark_push(dyn_obj(v)); if (dyn_boxed(v) && dyn_box(v) == BOX_OBJ) mark_push(dyn_obj(v));
} }
/* ── Environments ──────────────────────────────────────────────────────
*
* The second word of an (Fn ...) value is one of three things: null, for a
* value made from a name or from an fn that captured nothing; the address of
* an environment this file allocated; or, for a named function widened into
* an Fn, that function's code address, which the widening thunk reads back
* and calls. The marker meets all three at the same offset and must follow
* only the second.
*
* Nothing in the word says which. A code address can have any low bits — on
* wasm32 it is a table index, a small integer — so no tag bit is free on that
* side, and dereferencing one to look for a header would read code or trap.
* So the collector keeps the set of environment addresses it has handed out
* and follows a word only when the set has it. An address that is not an
* environment is never read through, which also makes a stale or unwritten
* word harmless: at worst it keeps a live environment alive a little longer.
*
* Open addressing with linear probing. The sweep deletes each environment it
* frees, and shrinks the table once it is mostly empty. */
static uintptr_t *envset;
static int64_t envset_cap, envset_n;
static inline uint64_t ptr_hash(uintptr_t p) {
uint64_t x = (uint64_t)p;
x ^= x >> 33;
x *= 0xff51afd7ed558ccdULL;
x ^= x >> 33;
return x;
}
static void envset_put(uintptr_t p);
/* A fresh table of [cap] slots, a power of two, filled from [old]. */
static void envset_resize(int64_t cap) {
uintptr_t *old = envset;
int64_t oldcap = envset_cap, i;
envset = (uintptr_t *)calloc((size_t)cap, sizeof *envset);
if (envset == NULL) trap_oom(NULL, 0, cap * (int64_t)sizeof *envset);
envset_cap = cap;
envset_n = 0;
for (i = 0; i < oldcap; i++)
if (old[i] != 0) envset_put(old[i]);
free(old);
}
static void envset_put(uintptr_t p) {
uint64_t h;
if ((envset_n + 1) * 2 > envset_cap)
envset_resize(envset_cap ? envset_cap * 2 : 64);
h = ptr_hash(p) & (uint64_t)(envset_cap - 1);
while (envset[h] != 0) {
if (envset[h] == p) return;
h = (h + 1) & (uint64_t)(envset_cap - 1);
}
envset[h] = p;
envset_n++;
}
static int envset_has(uintptr_t p) {
uint64_t h;
if (envset_cap == 0 || p == 0) return 0;
h = ptr_hash(p) & (uint64_t)(envset_cap - 1);
while (envset[h] != 0) {
if (envset[h] == p) return 1;
h = (h + 1) & (uint64_t)(envset_cap - 1);
}
return 0;
}
/* One environment freed. Backward-shift deletion, so the table needs no
* tombstones: every entry after the hole that could have been placed in it
* moves back. */
static void envset_del(uintptr_t p) {
uint64_t mask, i, j, k;
if (envset_cap == 0) return;
mask = (uint64_t)(envset_cap - 1);
i = ptr_hash(p) & mask;
while (envset[i] != p) {
if (envset[i] == 0) return;
i = (i + 1) & mask;
}
j = i;
for (;;) {
j = (j + 1) & mask;
if (envset[j] == 0) break;
k = ptr_hash(envset[j]) & mask;
/* Move [j] back into the hole at [i] unless its home lies cyclically
in (i, j]. */
if ((i <= j) ? (i < k && k <= j) : (i < k || k <= j)) continue;
envset[i] = envset[j];
i = j;
}
envset[i] = 0;
envset_n--;
}
/* After a sweep: a table that has emptied to an eighth of its size is
* rebuilt at a size for what is left, so a program that once held a million
* environments does not keep a million-slot table. */
static int64_t envs_made; /* environments allocated since the last sweep */
static void envset_shrink(void) {
int64_t cap = 64, want = envset_n * 4;
/* Room for as many as the last cycle made, so a program that makes and
drops closures at a steady rate does not shrink and regrow the table
every cycle. */
if (envs_made * 2 > want) want = envs_made * 2;
envs_made = 0;
if (envset_cap <= 64 || envset_n * 8 > envset_cap) return;
while (cap < want) cap *= 2;
if (cap < envset_cap) envset_resize(cap);
}
static void mark_env(uintptr_t w) {
if (envset_has(w)) mark_push((flan_obj *)w - 1);
}
/* ── The Vec blocks a marker may read ──────────────────────────────────
*
* A (Vec T) header is copied by value, so the one the marker is handed may be
* a stale copy whose block another copy's push has since reallocated and
* freed. Reading its elements would read freed memory — and a block large
* enough for malloc to have unmapped it faults. So the marker never trusts a
* header's pointer: flan_rt.c reports every Vec block it allocates, moves or
* frees through [flan_vec_block_hook], this table keeps the live ones with
* their byte size and the allocator epoch they were made at, and a header is
* followed only when its pointer is a live block — for no more elements than
* the block holds, and not after its allocator has been reset past that
* epoch. A stale header whose pointer malloc has since reused for another Vec
* is bounded by that Vec's block and its words go through the same checks as
* any other, so nothing outside a live block is ever read.
*
* The hook is installed by [flan_dyn_track_vecs], which a program that can
* make a collector-owned environment calls first thing in main; blocks made
* before it cannot hold one. Allocator headers are never freed (flan_rt.c's
* [flan_arena_destroy]), so reading one's epoch is always safe.
*
* Open addressing with tombstones, since blocks come and go all the time. */
typedef struct {
uintptr_t ptr; /* 0 empty, 1 deleted */
int64_t bytes;
void *alloc;
int64_t epoch;
} vblock;
static vblock *vblocks;
static int64_t vblocks_cap, vblocks_n, vblocks_used;
extern void (*flan_vec_block_hook)(void *old, void *fresh, int64_t bytes,
void *alloc, int64_t epoch);
static void vblock_put(uintptr_t p, int64_t bytes, void *alloc, int64_t epoch);
static void vblock_resize(int64_t cap) {
vblock *old = vblocks;
int64_t oldcap = vblocks_cap, i;
vblocks = (vblock *)calloc((size_t)cap, sizeof *vblocks);
if (vblocks == NULL) trap_oom(NULL, 0, cap * (int64_t)sizeof *vblocks);
vblocks_cap = cap;
vblocks_n = 0;
vblocks_used = 0;
for (i = 0; i < oldcap; i++)
if (old[i].ptr > 1)
vblock_put(old[i].ptr, old[i].bytes, old[i].alloc, old[i].epoch);
free(old);
}
static vblock *vblock_find(uintptr_t p) {
uint64_t h;
if (vblocks_cap == 0 || p <= 1) return NULL;
h = ptr_hash(p) & (uint64_t)(vblocks_cap - 1);
while (vblocks[h].ptr != 0) {
if (vblocks[h].ptr == p) return &vblocks[h];
h = (h + 1) & (uint64_t)(vblocks_cap - 1);
}
return NULL;
}
static void vblock_put(uintptr_t p, int64_t bytes, void *alloc, int64_t epoch) {
uint64_t h;
vblock *hit = vblock_find(p);
if (hit != NULL) {
hit->bytes = bytes; hit->alloc = alloc; hit->epoch = epoch;
return;
}
if ((vblocks_used + 1) * 2 > vblocks_cap) {
int64_t cap = 64;
while (cap < (vblocks_n + 1) * 4) cap *= 2;
vblock_resize(cap);
}
h = ptr_hash(p) & (uint64_t)(vblocks_cap - 1);
while (vblocks[h].ptr > 1) h = (h + 1) & (uint64_t)(vblocks_cap - 1);
if (vblocks[h].ptr == 0) vblocks_used++;
vblocks[h].ptr = p;
vblocks[h].bytes = bytes;
vblocks[h].alloc = alloc;
vblocks[h].epoch = epoch;
vblocks_n++;
}
static void vblock_drop(uintptr_t p) {
vblock *hit = vblock_find(p);
if (hit != NULL) { hit->ptr = 1; vblocks_n--; }
}
static void vblock_hook(void *old, void *fresh, int64_t bytes, void *alloc,
int64_t epoch) {
if (old != NULL) vblock_drop((uintptr_t)old);
if (fresh != NULL) vblock_put((uintptr_t)fresh, bytes, alloc, epoch);
}
void flan_dyn_track_vecs(void) { flan_vec_block_hook = vblock_hook; }
/* Vecs still to walk, as (live block, element count, element descriptor).
* Explicit for the mark stack's reason: a data type can hold a Vec of itself,
* so how deep Vecs nest is the data's and not the type's, and recursion would
* put it on the C stack. */
typedef struct { char *p; int64_t n; const flan_desc *e; } vec_work;
static vec_work *vstack;
static int64_t vstack_n, vstack_cap;
/* The words [d] names inside the instance at [base]. A Vec entry is checked
* against the live blocks above and queued; [mark_desc] drains the queue
* before it returns. */
static void mark_words(char *base, const flan_desc *d) {
int64_t j;
for (j = 0; j < d->n; j++) mark_value(*(flan_dyn *)(base + d->offs[j]));
for (j = 0; j < d->nenv; j++) mark_env(*(uintptr_t *)(base + d->envs[j]));
for (j = 0; j < d->nvec; j++) {
flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)(base + d->vecs[j].off);
const flan_desc *e = d->vecs[j].elem;
vblock *b;
int64_t n;
if (e == NULL || e->size <= 0 || h->len <= 0) continue;
b = vblock_find((uintptr_t)h->ptr);
if (b == NULL) continue;
if (b->alloc != NULL
&& (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch)
continue;
n = b->bytes / e->size;
if (h->len < n) n = h->len;
if (vstack_n == vstack_cap) {
int64_t cap = vstack_cap ? vstack_cap * 2 : 16;
vec_work *v = (vec_work *)realloc(vstack, (size_t)cap * sizeof *v);
if (v == NULL) trap_oom(NULL, 0, cap * (int64_t)sizeof *v);
vstack = v;
vstack_cap = cap;
}
vstack[vstack_n].p = (char *)h->ptr;
vstack[vstack_n].n = n;
vstack[vstack_n].e = e;
vstack_n++;
}
}
static void mark_desc(char *base, const flan_desc *d) {
mark_words(base, d);
while (vstack_n > 0) {
vec_work w = vstack[--vstack_n];
int64_t i;
for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e);
}
}
static void gc_mark_all(void) { static void gc_mark_all(void) {
int64_t i; int64_t i;
unsigned k; unsigned k;
for (i = 0; i < roots_n; i++) { for (i = 0; i < roots_n; i++) {
const flan_desc *d = roots[i].desc; const flan_desc *d = roots[i].desc;
if (d == NULL) mark_value(*(flan_dyn *)roots[i].base); if (d == NULL) mark_value(*(flan_dyn *)roots[i].base);
else { else mark_desc((char *)roots[i].base, d);
int64_t j;
for (j = 0; j < d->n; j++)
mark_value(*(flan_dyn *)((char *)roots[i].base + d->offs[j]));
}
} }
for (k = 0; k < RING; k++) mark_push(ring[k]); for (k = 0; k < RING; k++) mark_push(ring[k]);
while (mstack_n > 0) { while (mstack_n > 0) {
flan_obj *o = mstack[--mstack_n]; flan_obj *o = mstack[--mstack_n];
int64_t n = obj_words(o); int64_t n;
if (o->kind == OBJ_ENV) {
mark_desc((char *)(o + 1), o->u.env.desc);
continue;
}
n = obj_words(o);
for (i = 0; i < n; i++) mark_value(o->u.v.items[i]); for (i = 0; i < n; i++) mark_value(o->u.v.items[i]);
} }
} }
@ -1018,7 +1320,8 @@ static void gc_sweep(void) {
link = &o->next; link = &o->next;
} else { } else {
int64_t held = (int64_t)sizeof(flan_obj); int64_t held = (int64_t)sizeof(flan_obj);
if (o->kind == OBJ_TEXT) held += o->len; if (o->kind == OBJ_TEXT || o->kind == OBJ_ENV) held += o->len;
if (o->kind == OBJ_ENV) envset_del((uintptr_t)(o + 1));
if (o->kind == OBJ_VEC || o->kind == OBJ_MAP) { if (o->kind == OBJ_VEC || o->kind == OBJ_MAP) {
int64_t per = o->kind == OBJ_MAP ? 2 : 1; int64_t per = o->kind == OBJ_MAP ? 2 : 1;
held += o->u.v.cap * per * (int64_t)sizeof(flan_dyn); held += o->u.v.cap * per * (int64_t)sizeof(flan_dyn);
@ -1031,6 +1334,20 @@ static void gc_sweep(void) {
} }
o = next; o = next;
} }
/* A freed environment's address left the set above, before malloc can hand
it out again as something else. */
envset_shrink();
}
void *flan_dyn_env_new(int64_t size, const flan_desc *d) {
flan_obj *o = gc_alloc(OBJ_ENV, size);
o->len = size;
o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0))
? d : NULL;
memset(o + 1, 0, (size_t)size);
envset_put((uintptr_t)(o + 1));
envs_made++;
return (void *)(o + 1);
} }
static void root_add(void *base, const flan_desc *d) { static void root_add(void *base, const flan_desc *d) {
@ -1054,7 +1371,7 @@ void flan_dyn_root_push(flan_dyn *slot) { root_add(slot, NULL); }
* compiler found no dyn in — but it still occupies an entry, because the count * compiler found no dyn in — but it still occupies an entry, because the count
* is what the epilogue knows, and it is turned into an empty descriptor rather * is what the epilogue knows, and it is turned into an empty descriptor rather
* than stored as NULL, which on this stack means something else. */ * than stored as NULL, which on this stack means something else. */
static const flan_desc desc_empty = { 0, 0, NULL }; static const flan_desc desc_empty = { 0, 0, NULL, 0, NULL, 0, NULL };
void flan_dyn_root_push_desc(void *base, const flan_desc *d) { void flan_dyn_root_push_desc(void *base, const flan_desc *d) {
root_add(base, d == NULL ? &desc_empty : d); root_add(base, d == NULL ? &desc_empty : d);

41
runtime/flan_dyn.h
View File

@ -48,16 +48,33 @@ typedef uint64_t flan_dyn;
* outer offset plus the inner one, and there is no walking of a type graph at * outer offset plus the inner one, and there is no walking of a type graph at
* run time and no second descriptor to follow. * run time and no second descriptor to follow.
* *
* [size] is the stride of one instance. The collector does not read it; the * [size] is the stride of one instance, which is what a [vecs] entry's
* typed-container view will, which is the reason it is here now rather than * element descriptor is read for.
* being added later to data both lanes already emit.
* *
* Nothing in this ABI ever writes a descriptor, and no value ever points at * Besides the dyn words, two more kinds of word the collector follows:
* one. See [flan_dyn_root_push_desc]. */ * [envs], the environment half of each (Fn ...) value inside the instance —
* pointer-sized, holding a collector-allocated environment, null, or a
* widened function's code address, told apart by the collector's own set of
* environments and never by dereferencing — and [vecs], each a (Vec T)
* header at [off] whose live elements are marked through [elem]. A descriptor
* with only dyn words leaves the last four fields zero.
*
* Nothing in this ABI ever writes a descriptor. See [flan_dyn_root_push_desc]
* and [flan_dyn_env_new]. */
struct flan_desc;
typedef struct flan_desc_vec {
int64_t off;
const struct flan_desc *elem;
} flan_desc_vec;
typedef struct flan_desc { typedef struct flan_desc {
int64_t size; int64_t size;
int64_t n; int64_t n;
const int64_t *offs; const int64_t *offs;
int64_t nenv;
const int64_t *envs;
int64_t nvec;
const flan_desc_vec *vecs;
} flan_desc; } flan_desc;
/* ── Constructors ──────────────────────────────────────────────────── */ /* ── Constructors ──────────────────────────────────────────────────── */
@ -365,6 +382,20 @@ void flan_dyn_root_pop(int64_t n);
* lifetime of the program; nothing copies it. */ * lifetime of the program; nothing copies it. */
void flan_dyn_root_push_desc(void *base, const flan_desc *d); void flan_dyn_root_push_desc(void *base, const flan_desc *d);
/* A closure's environment: [size] zeroed bytes the collector owns, marked
* through [d] (NULL when the environment holds nothing to follow). Answers
* the address of the first byte, which is what an (Fn ...) value carries as
* its second word. The object is in the allocation ring until 64 more
* allocations have happened, so the caller has that long to store the
* address somewhere rooted. [d] is static data and must outlive the object. */
void *flan_dyn_env_new(int64_t size, const flan_desc *d);
/* From here on, the collector is told of every Vec block the runtime
* allocates, moves or frees, and reads a Vec's elements only through a block
* it knows to be live. Called first thing in main by a program that can make
* a collector-owned environment. */
void flan_dyn_track_vecs(void);
/* ── Extensions ──────────────────────────────────────────────────────── /* ── Extensions ────────────────────────────────────────────────────────
* *
* Additions to the agreed ABI, none of which the compiler lane has to emit. * Additions to the agreed ABI, none of which the compiler lane has to emit.

14
runtime/flan_rt.c
View File

@ -1871,6 +1871,16 @@ void flan_vec_region_only(flan_vec *v, const uint8_t *loc, int64_t loclen) {
loc, loclen); loc, loclen);
} }
/* Told of every Vec block this file allocates, moves or frees: the old block
* (or NULL), the new one (or NULL), its size in bytes, and the allocator and
* epoch it was made under. NULL unless flan_dyn.c's [flan_dyn_track_vecs] has
* installed its own — a program that can make a collector-owned closure
* environment, which may sit in a Vec, installs it so the collector never
* reads a block a stale header copy still names. A pointer rather than a
* call so this file names nothing in flan_dyn.c. */
void (*flan_vec_block_hook)(void *old, void *fresh, int64_t bytes, void *alloc,
int64_t epoch) = NULL;
static int8_t flan_vec_grow(flan_vec *v, int64_t want, int64_t size, static int8_t flan_vec_grow(flan_vec *v, int64_t want, int64_t size,
int64_t align) { int64_t align) {
flan_allocator *a = flan_vec_adopt(v); flan_allocator *a = flan_vec_adopt(v);
@ -1903,6 +1913,8 @@ static int8_t flan_vec_grow(flan_vec *v, int64_t want, int64_t size,
else else
p = a->proc(a, FLAN_ALLOC_ALLOC, NULL, 0, bytes, align); p = a->proc(a, FLAN_ALLOC_ALLOC, NULL, 0, bytes, align);
if (!p) return 0; if (!p) return 0;
if (flan_vec_block_hook)
flan_vec_block_hook(v->ptr, p, bytes, v->alloc, v->epoch);
v->ptr = p; v->ptr = p;
v->cap = cap; v->cap = cap;
/* Any slice taken before this points at storage that may have moved. The /* Any slice taken before this points at storage that may have moved. The
@ -2004,6 +2016,8 @@ void flan_vec_free(flan_vec *v, int64_t size, int64_t align,
flan_vec_check(v, loc, loclen); flan_vec_check(v, loc, loclen);
if (v->ptr && v->alloc && (v->alloc->caps & FLAN_CAN_FREE)) if (v->ptr && v->alloc && (v->alloc->caps & FLAN_CAN_FREE))
v->alloc->proc(v->alloc, FLAN_ALLOC_FREE, v->ptr, v->cap * size, 0, align); v->alloc->proc(v->alloc, FLAN_ALLOC_FREE, v->ptr, v->cap * size, 0, align);
if (v->ptr && flan_vec_block_hook)
flan_vec_block_hook(v->ptr, NULL, 0, NULL, 0);
(void)align; (void)align;
v->ptr = NULL; v->ptr = NULL;
v->len = 0; v->len = 0;

2
test/dyn_ops.c
View File

@ -896,7 +896,7 @@ static void desc(void) {
(int64_t)offsetof(desc_row, tail) (int64_t)offsetof(desc_row, tail)
}; };
static const flan_desc row_desc = { static const flan_desc row_desc = {
(int64_t)sizeof(desc_row), 3, offs (int64_t)sizeof(desc_row), 3, offs, 0, NULL, 0, NULL
}; };
desc_row row; desc_row row;
flan_dyn was_label, was_note; flan_dyn was_label, was_note;

9
test/programs/fn-capture-dyn.flan
View File

@ -1,9 +1,6 @@
;; A dyn is the one thing a capture refuses outright, and for the reason a ;; A dyn captured by an fn. The copy lives in the fn's environment, which the
;; struct field of dyn already refuses: the collector's roots are frames, and ;; collector allocated and marks through the environment's descriptor, so the
;; nothing pushes the fields of the environment struct a capture synthesises. ;; value it names stays alive for as long as the function value does.
;; A copy in there would be a live value reachable only through memory the
;; marker never walks. Milestone 2's per-type descriptors lift it, alongside
;; the condition payload's and the struct field's.
(defn run [f (Fn [] i64)] i64 (f)) (defn run [f (Fn [] i64)] i64 (f))
;; [d] is unannotated, which is what makes it a dyn. ;; [d] is unannotated, which is what makes it a dyn.

8
test/programs/fn-dev-escape.flan Normal file
View File

@ -0,0 +1,8 @@
;; [store] only calls what it is handed, so in a release build [go]'s closure
;; stays on go's frame. In a dev build [store] can be redefined to keep it —
;; (set kept (Some f)) — and only [store] is recompiled, so [go] must already
;; have made its closure on the collector's heap.
(defonce kept (Option (Fn [i64] i64)))
(defn store [f (Fn [i64] i64)] () (println (f 0)))
(defn go [n i64] () (store (fn [x] (+ x n))))
(defn main [] i32 (go 5) 0)

13
test/programs/fn-escape-at.flan
View File

@ -1,13 +0,0 @@
;; An index read is a read, and the escape check's clean list has to be a
;; list. A function value out of a slice is refused exactly as one out of a
;; Vec, a struct or a pointer is — the four are the same act and there is no
;; reason for a reader to have to remember which spellings were enumerated.
;;
;; Not reachable today: nothing can write an Fn into a slice, because every
;; position that would have to hold one is refused. It is here so that the
;; day one can, this is already true — the alternative was a default of
;; "clean" for anything the enumeration had not thought of, which is how a
;; closed list quietly stops being closed.
(defn leak [s [(Fn [] i32)]] (Fn [] i32) (at s 0))
(defn main [] i32 0)

19
test/programs/fn-escape-copy.flan
View File

@ -1,19 +0,0 @@
;; The hole a capture could otherwise be laundered through, and the reason
;; "the result of a call is clean" is a rule and not a hope.
;;
;; [sneak]'s literal captures [g], so its body holds a *copy* of a function
;; value that may itself carry an environment — and the copy is read out of an
;; environment, which is the one aggregate a function value is ever stored in.
;; If a copy read back out were treated as clean, the literal could return it,
;; the return would arrive at [sneak]'s caller as an ordinary call result, and
;; a capturing value would be out of the frame that owns it with nothing
;; having refused anything.
;;
;; So a function value read out of a struct, a case or a pointer is suspect,
;; and the refusal lands inside the lifted body where the return is written.
(defn getf [f (Fn [] (Fn [] i32))] (Fn [] i32) (f))
(defn sneak [g (Fn [] i32)] (Fn [] i32)
(getf (fn [] g)))
(defn main [] i32 0)

12
test/programs/fn-escape-handled.flan
View File

@ -1,12 +0,0 @@
;; A handler-bind is an expression and its value is its body's, so it is a way
;; for a function value to be a function's answer — and it would have walked
;; straight past a check that only looked at [return] and at the last form of
;; a block. with-allocator and restart-case are the same shape and are checked
;; the same way.
(defstruct C [id i32])
(defonce seen i32)
(defn keep [f (Fn [] i32)] (Fn [] i32)
(handler-bind [(C [c] (set seen (.id c)))] f))
(defn main [] i32 0)

16
test/programs/fn-escape-match.flan
View File

@ -1,16 +0,0 @@
;; A match arm's binding is a binding, and the escape check has to see it.
;;
;; Reading the payload by hand is a case-field read, which is suspect: a copy
;; of a function value carries whatever environment the original did. Binding
;; it to a name in an arm is the same read, and the store that fills the arm's
;; slot is inside the branch rather than in any form the walk reads as a
;; binding — so without the arm's slots being taken as suspect too, the Vec,
;; slice, struct and pointer spellings of this were all refused while the one
;; that goes through Option and a name was not.
(defn leak [o (Option (Fn [] i32))] (Fn [] i32)
(match o
(Some f) f
None (fn [] 0)))
(defn main [] i32 0)

11
test/programs/fn-escape-param.flan
View File

@ -1,11 +0,0 @@
;; The hard case, answered without looking at a single call site: a function
;; value that arrives as a parameter may carry an environment on its caller's
;; frame, so a function that *stores* one is refused where it is written.
;;
;; That is what makes passing a capturing fn down safe everywhere — no callee
;; can keep it — and it is also the conservative half: this particular [keep]
;; would be harmless for a caller that passed a name, and there is no way for
;; the definition to know that it did.
(defn keep [f (Fn [] i32)] (Fn [] i32) f)
(defn main [] i32 (println ((keep (fn [] 1)))) 0)

10
test/programs/fn-escape-return.flan
View File

@ -1,10 +0,0 @@
;; The refusal that defines "non-escaping". The copies live in a slot of
;; [make]'s frame, and the value would still be pointing at them after that
;; frame has gone.
;;
;; A returned function value is still fine when it captures nothing —
;; fn-values.flan returns one — so this is about the environment and not about
;; the shape of the value.
(defn make [n i32] (Fn [] i32) (fn [] n))
(defn main [] i32 (println ((make 3))) 0)

7
test/programs/fn-escape-store.flan
View File

@ -1,7 +0,0 @@
;; A store through a pointer is the same escape wearing a different hat: the
;; pointer names storage this frame does not own, so the value would outlive
;; the environment it carries.
(defn stash [p (Ptr (Fn [] i32)) f (Fn [] i32)] ()
(set (deref p) f))
(defn main [] i32 0)

9
test/programs/fn-escape-vec.flan
View File

@ -1,9 +0,0 @@
;; A Vec's elements are in a block the allocator owns and the frame does not,
;; so a function value pushed into one outlives whatever environment it
;; carries. Refused for that, and not for the shape of the element type: a Vec
;; of function values is a perfectly good thing to want, and is what case 3
;; is for.
(defn stash [v (Vec (Fn [] i32)) f (Fn [] i32)] ()
(push v f))
(defn main [] i32 0)

215
test/programs/fn-escape.flan Normal file
View File

@ -0,0 +1,215 @@
;; Closures that outlive the frame they were made in. The environment is
;; allocated by the collector, so a capturing fn may be returned, kept in a
;; Vec, an Option field of a struct or a global, and called after any number
;; of collections. Every line below is called after a forced collection that
;; would have freed an environment nobody rooted.
;;
;; Capture is by value: the environment holds copies of the locals taken when
;; the fn was made. A counter shares state through a captured dyn map, which
;; is a reference to one object on the collector's heap.
(declare gc-collect [] () "flan_gc_collect")
(defn churn [] ()
(let [i 0]
(while (< i 2000)
(let [v (vec-new dyn)] (push v i) (push v "junk"))
(set i (+ i 1))))
(gc-collect))
(defn make-adder [n i64] (Fn [i64] i64)
(fn [x] (+ x n)))
;; Two captures deep: the inner fn captures the outer one's copy of [base],
;; and the returned value captures a function value that captures.
(defn make-scaled [base i64 k i64] (Fn [i64] i64)
(let [add (make-adder base)]
(fn [x] (* k (add x)))))
(defn keep [f (Fn [i64] i64)] (Fn [i64] i64) f)
;; A function value read back out of an environment and handed on: [sneak]'s
;; literal captures [g], and [getf] returns the copy.
(defn getf [f (Fn [] (Fn [i64] i64))] (Fn [i64] i64) (f))
(defn sneak [g (Fn [i64] i64)] (Fn [i64] i64) (getf (fn [] g)))
;; Stored through a pointer into a slot of the caller's frame.
(defn stash [p (Ptr (Fn [i64] i64)) f (Fn [i64] i64)] () (set (deref p) f))
(defn make-counter [] (Fn [] i64)
(let [st {:n 0}]
(fn []
(put st :n (+ (get st :n) 1))
(i64 (get st :n)))))
;; A dyn captured and returned: the text is on the collector's heap and
;; reachable only through the environment.
(defn make-greeter [who] (Fn [] i64)
(let [msg (vec-new dyn)]
(push msg who)
(push msg "and")
(push msg who)
(fn [] (i64 (length msg)))))
(defstruct Button [label string on-click (Option (Fn [] i64))])
(defonce handler (Option (Fn [i64] i64)))
(defn call-opt [o (Option (Fn [i64] i64)) x i64] i64
(match o
(Some f) (f x)
None -1))
(defn double [x i64] i64 (* 2 x))
;; A closure made as an argument and held while the next argument collects —
;; kept by the callee, so it is one the collector owns — and one collected
;; for while the callee runs, before the callee has put it anywhere. A
;; parameter of function type is not rooted by the callee; the caller holds
;; it.
(defn apply-to [f (Fn [i64] i64) x i64] i64 (f x))
(defn churn-1 [] i64 (churn) 1)
(defonce last-fn (Option (Fn [i64] i64)))
(defn remember [f (Fn [i64] i64) x i64] i64
(churn)
(set last-fn (Some f))
(f x))
;; A handler clause keeps its copies on the establishing frame, and may now
;; capture a dyn and a closure like an fn may.
(defstruct Ping [n i64])
(defonce heard i64)
(defn pinged [x i64] i64 (signal (Ping {.n x})) x)
(defn keep-handled [f (Fn [i64] i64)] (Fn [i64] i64)
(handler-bind [(Ping [c] (set heard 0))] f))
(defn handled [] ()
(let [names (vec-new dyn)
f (make-adder 50)]
(push names "a")
(push names "b")
(handler-bind [(Ping [c] (churn) (set heard (+ (f (.n c)) (i64 (length names)))))]
(pinged 1))
(println heard)))
;; A data type's case holding a function value, in a Vec, and a Vec of Vecs.
;; The collector names every case's function-value word and follows only the
;; ones that hold an environment it made.
(defdata Action
[Idle
(Run [f (Option (Fn [i64] i64)) n i64])
(Pair [k i64 g (Option (Fn [i64] i64))])])
(defn act [a Action x i64] i64
(match a
Idle 0
(Run f n) (+ n (call-opt f x))
(Pair k g) (+ k (call-opt g x))))
(defn shapes [] ()
(let [acts (vec-new Action)
a (arena-new 65536)
outer (vec-new (Vec (Fn [i64] i64)) a)]
(push acts (Action.Run {.f (Some (make-adder 1)) .n 10}))
(push acts (Action.Pair {.k 20 .g (Some (make-adder 2))}))
(push acts Action.Idle)
(let [inner (vec-new (Fn [i64] i64) a)]
(push inner (make-adder 3))
(push outer inner))
(churn)
(println (+ (act (at acts 0) 1) (+ (act (at acts 1) 1) (act (at acts 2) 1)))
((at (at outer 0) 0) 1))))
;; A data type holding a Vec of itself: the collector walks as deep as the
;; data goes, and the function value two levels down is still found.
(defdata Tree [(Node [f (Option (Fn [i64] i64)) kids (Vec Tree)])])
(defn tree-sum [t Tree x i64] i64
(match t
(Node f kids)
(let [s (call-opt f x)
i 0]
(while (< i (length kids))
(set s (+ s (tree-sum (at kids i) x)))
(set i (+ i 1)))
s)))
(defn trees [] ()
(let [a (arena-new 65536)
leaf-kids (vec-new Tree a)
kids (vec-new Tree a)]
(push kids (Tree.Node {.f (Some (make-adder 5)) .kids leaf-kids}))
(let [root (Tree.Node {.f None .kids kids})]
(churn)
(println (tree-sum root 1)))))
;; Environments nobody holds are collected: a hundred thousand of them made
;; and dropped leave the heap as small as it was.
(declare gc-live-bytes [] i64 "flan_gc_live_bytes")
(defn many [] ()
(let [sum (i64 0)]
(dotimes [i 100000]
(set sum (+ sum ((make-adder 1) 0))))
(gc-collect)
(println sum (< (gc-live-bytes) 1000000))))
(defn main [] i32
;; Returned, then called after a collection.
(let [add5 (make-adder 5)]
(churn)
(println (add5 10)))
;; Nested, and passed through a function that hands its parameter back.
(let [f (keep (make-scaled 1 3))]
(churn)
(println (f 4)))
;; Out of an environment, through a handler-bind's value, and through a
;; pointer.
(let [f (keep-handled (sneak (make-adder 20)))
slot (make-adder 0)]
(stash (addr slot) (make-adder 7))
(churn)
(println (f 1) (slot 1)))
;; Held beside a sibling operand that collects.
(let [n 40]
(println (apply-to (fn [x] (+ x n)) (churn-1))
(remember (fn [x] (+ x n)) 1)))
;; A Vec of function values, one capture per iteration plus a widened name.
(let [fs (vec-new (Fn [i64] i64))]
(let [i 0]
(while (< i 5)
(push fs (make-adder (* i 100)))
(set i (+ i 1))))
(push fs double)
(churn)
(let [total (i64 0)]
(let [i 0]
(while (< i (length fs))
(set total (+ total ((at fs i) 1)))
(set i (+ i 1))))
(println total)))
;; A counter over a captured dyn map: two calls on one value see one state.
(let [c (make-counter)]
(c)
(churn)
(c)
(println (c)))
;; A captured dyn.
(let [g (make-greeter "world")]
(churn)
(println (g)))
;; A struct field and a global, both through Option.
(let [b (Button {.label "ok" .on-click (Some (make-counter))})]
(churn)
(match (.on-click b)
(Some f) (do (f) (println (f)))
None (println "none")))
(set handler (Some (make-adder 1000)))
(churn)
(println (call-opt handler 7))
(handled)
(shapes)
(trees)
(many)
0)

9
test/programs/fn-in-map.flan Normal file
View File

@ -0,0 +1,9 @@
;; A closure's environment is found by walking the storage its function value
;; sits in — a frame slot, a global, a struct, an Option, a Vec's elements —
;; and a Map's storage is not walked. An (Fn ...) as a Map's value would hold
;; an environment the collector cannot see and would free. A Vec holds them,
;; and a (CFn ...) carries no environment and may go in a Map.
(defn main [] i32
(let [ops (map-new string (Fn [i32] i32))]
(put ops "id" (fn [x] x))
0))

8
test/programs/fn-in-struct.flan
View File

@ -5,11 +5,9 @@
;; left to crash at the call, and the same rule covers a global, a fixed ;; left to crash at the call, and the same rule covers a global, a fixed
;; array's element and (zeroed). ;; array's element and (zeroed).
;; ;;
;; Capture sharpened the reason behind this one without changing it. A struct ;; The zero is the whole objection: a capturing value's environment belongs to
;; outlives the frame it was built on, so a field could not hold a value ;; the collector and may be kept anywhere, and (Option (Fn ...)) is the field
;; carrying an environment either — see fn-escape-*.flan. The zero is still ;; that holds one — see fn-escape.flan.
;; what the message names, because it is the objection that applies to every
;; function value and not only to a capturing one.
;; ;;
;; Which means a (CFn ...) field is refused too, and for the zero alone — ;; Which means a (CFn ...) field is refused too, and for the zero alone —
;; a table of function pointers is exactly what that type is for, and nothing ;; a table of function pointers is exactly what that type is for, and nothing

5
test/programs/fn-values.flan
View File

@ -1,7 +1,6 @@
;; Function values, and specifically the ones with no environment. Nothing ;; Function values, and specifically the ones with no environment. Nothing
;; here captures, which is what makes every one of these safe to return and to ;; here captures — fn-capture.flan is the other half, and fn-escape.flan is a
;; hand around — fn-capture.flan is the other half, and fn-escape-*.flan is ;; capturing value outliving the frame that made it.
;; the line between them.
;; ;;
;; Every signature below says (Fn ...), which is the wide one: it admits a ;; Every signature below says (Fn ...), which is the wide one: it admits a
;; capturing value and so pays for a two-word value and a widening thunk where ;; capturing value and so pays for a two-word value and a widening thunk where

40
test/programs/fn-vec-stale.flan Normal file
View File

@ -0,0 +1,40 @@
;; A Vec header is copied by value, so a copy goes stale when another copy's
;; push moves the block, and the old block is freed — large enough here that
;; malloc hands it back to the system. The collector marks through every
;; header it can see, the stale copy included, and must read only a block it
;; knows to be live: a Vec of closures, and a Vec of Vecs of closures, whose
;; freed elements would otherwise be read as headers.
(declare gc-collect [] () "flan_gc_collect")
(defn make-adder [n i64] (Fn [i64] i64) (fn [x] (+ x n)))
(defn counter [v (Vec (Fn [i64] i64))] (Fn [] i64) (fn [] (i64 (length v))))
(defn flat [] ()
(let [fs (vec-new (Fn [i64] i64))]
(dotimes [i 20000] (push fs (make-adder i)))
(let [c (counter fs)
old fs]
(dotimes [i 200000] (push fs (make-adder i)))
(gc-collect)
(println (c) (length old) (length fs) ((at fs 219999) 1)))))
(defn nested [] ()
(let [a (arena-new 67108864)
outer (vec-new (Vec (Fn [i64] i64)) a)]
(dotimes [i 20000]
(let [inner (vec-new (Fn [i64] i64) a)]
(push inner (make-adder i))
(push outer inner)))
(let [old outer]
(dotimes [i 200000]
(let [inner (vec-new (Fn [i64] i64) a)]
(push inner (make-adder i))
(push outer inner)))
(gc-collect)
(println (length old) (length outer) ((at (at outer 219999) 0) 1)))))
(defn main [] i32
(flat)
(nested)
0)

188
test/test_acceptance.ml
View File

@ -3471,6 +3471,10 @@ let () =
local: kept 42\naggregate: kept 42\nnested: kept 42\n\ local: kept 42\naggregate: kept 42\nnested: kept 42\n\
fn value: kept 42\nindex: kept 42\nfield index: kept 42\n" fn value: kept 42\nindex: kept 42\nfield index: kept 42\n"
in in
(* And [programs/fn-escape.flan]'s, for the same reason. *)
let fn_escape_out =
"15\n15\n21 8\n41 41\n1007\n3\n3\n2\n1007\n53\n35 4\n5\n100000 true\n"
in
(* ── wasm32 ──────────────────────────────────────────────────────── (* ── wasm32 ────────────────────────────────────────────────────────
TODO.org, "The web target does not reach four things". TODO.org, "The web target does not reach four things".
@ -3590,7 +3594,15 @@ let () =
value held beside a sibling that collects is rooted through the value held beside a sibling that collects is rooted through the
same explicit slots there as natively. *) same explicit slots there as natively. *)
wasm_case "dyn: an operand held while a sibling collects, wasm32" wasm_case "dyn: an operand held while a sibling collects, wasm32"
"programs/dyn-held-operand.flan" dyn_held_out)); "programs/dyn-held-operand.flan" dyn_held_out;
(* Closures under collection, where a pointer is four bytes: an
Fn's environment word is at offset 4, and a descriptor written
with x86-64's numbers marks the wrong word — the counter line
then reads a freed map. *)
wasm_case "an fn that outlives its frame, wasm32"
"programs/fn-escape.flan" fn_escape_out;
wasm_case "an fn that outlives its frame, wasm32, -O0" ~opt:"-O0"
"programs/fn-escape.flan" fn_escape_out));
(* The EDN tokenizer, and the struct reader written by hand against it (* The EDN tokenizer, and the struct reader written by hand against it
(vendor/edn, test/programs/edn.flan). The expected output is a raw (vendor/edn, test/programs/edn.flan). The expected output is a raw
@ -4300,11 +4312,9 @@ level "1"
outputs ~opt:"-O0" "the prelude's map, filter, reduce and sort-by, -O0" outputs ~opt:"-O0" "the prelude's map, filter, reduce and sort-by, -O0"
"programs/higher-order.flan" higher_order_out; "programs/higher-order.flan" higher_order_out;
(* Capture by value into a stack environment — spec-memory.md's case 2. (* Capture by value. Three opt levels for the reason the case above has
Three opt levels for the reason the case above has them, and for one them, and for one more: the value carries the address of the copies,
more: the environment is a struct in the frame and the value carries which is exactly the shape -O2 is entitled to make disappear. -O0 is what proves there is a real store and a real load
its address, which is exactly the shape -O2 is entitled to make
disappear. -O0 is what proves there is a real store and a real load
behind it. A dev build is here because the value's code half still behind it. A dev build is here because the value's code half still
comes out of the indirection cell and the environment half must not comes out of the indirection cell and the environment half must not
have disturbed that. have disturbed that.
@ -4378,32 +4388,43 @@ level "1"
outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan" outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan"
fn_capture_out; fn_capture_out;
(* What function values do *not* include, each refused by name. Escape is (* Closures that outlive their frame: spec-memory.md's case 3. The
the headline now that capture is not: the copies live in the frame the environment is allocated by the collector, so a capturing fn is
literal was written in, so a value carrying their address may be returned, passed through a function that hands it back, held as an
called, passed down and copied about, and may not outlive that frame. argument while the next one collects, read back out
Each of these names case 3 — the collector-allocated environment — of another fn's environment, stored through a pointer, pushed into a
because "not yet" is the true sentence. *) Vec beside a widened name, kept in an Option field and an Option
refuses "a captured fn cannot be returned" "programs/fn-escape-return.flan" global, and called after a forced collection every time. The counter
"a return would outlive the frame"; shares state through a captured dyn map; a handler clause captures a
refuses "a function value parameter cannot be kept" dyn and a closure; and a hundred thousand dropped environments leave
"programs/fn-escape-param.flan" "may carry an environment"; the heap small, which is the line that fails if they are never freed.
refuses "a function value cannot be stored through a pointer" With the collector not marking environments, valgrind reports reads of
"programs/fn-escape-store.flan" "a store would outlive the frame"; freed blocks on this program and the counter line traps. *)
refuses "a function value cannot be pushed into a Vec" outputs "an fn that outlives its frame" "programs/fn-escape.flan"
"programs/fn-escape-vec.flan" "a container would outlive the frame"; fn_escape_out;
(* The two an escape check written by eye would have missed. A function outputs ~opt:"-O0" "an fn that outlives its frame, -O0"
value read back out of an environment is a copy of something that may "programs/fn-escape.flan" fn_escape_out;
carry one, and a handler-bind is an expression whose value is its outputs ~x86:true "an fn that outlives its frame, --x86"
body's — so both are ways for a suspect to be a function's answer. *) "programs/fn-escape.flan" fn_escape_out;
refuses "an index read is a read like any other" outputs ~dev:true "an fn that outlives its frame, dev"
"programs/fn-escape-at.flan" "may carry an environment"; "programs/fn-escape.flan" fn_escape_out;
refuses "a match arm's binding is a binding" outputs "an fn captures a dyn" "programs/fn-capture-dyn.flan" "7\n";
"programs/fn-escape-match.flan" "may carry an environment"; outputs ~x86:true "an fn captures a dyn, --x86"
refuses "a captured function value cannot be handed back" "programs/fn-capture-dyn.flan" "7\n";
"programs/fn-escape-copy.flan" "a return would outlive the frame"; (* A stale copy of a Vec of closures, and of a Vec of Vecs of them, whose
refuses "a handler-bind's value is a return too" block a push on another copy moved and freed. With the marker trusting
"programs/fn-escape-handled.flan" "a return would outlive the frame"; the header's pointer this segfaults in the collector. *)
let fn_vec_stale_out =
"20000 20000 220000 200000\n20000 220000 200000\n"
in
outputs "a stale Vec header is not marked through"
"programs/fn-vec-stale.flan" fn_vec_stale_out;
outputs ~x86:true "a stale Vec header is not marked through, --x86"
"programs/fn-vec-stale.flan" fn_vec_stale_out;
refuses "a Map cannot hold function values" "programs/fn-in-map.flan"
"a Map's storage is not walked";
(* Capture is by value, and a store into a copy is refused rather than
left to change the copy and not the local. *)
refuses "a captured local is a copy and cannot be assigned" refuses "a captured local is a copy and cannot be assigned"
"programs/fn-capture-set.flan" "cannot assign to n"; "programs/fn-capture-set.flan" "cannot assign to n";
(* The two function types, and the line between them. A CFn is the bare (* The two function types, and the line between them. A CFn is the bare
@ -4413,8 +4434,6 @@ level "1"
"programs/fn-cfn-captures.flan" "and not a (CFn [i32] i32)"; "programs/fn-cfn-captures.flan" "and not a (CFn [i32] i32)";
refuses "an Fn does not narrow to a CFn" refuses "an Fn does not narrow to a CFn"
"programs/fn-cfn-narrow.flan" "expected (CFn [i32] i32)"; "programs/fn-cfn-narrow.flan" "expected (CFn [i32] i32)";
refuses "an fn cannot capture a dyn" "programs/fn-capture-dyn.flan"
"the collector finds its roots by frame";
refuses "an fn with no type to take" "programs/fn-no-type.flan" refuses "an fn with no type to take" "programs/fn-no-type.flan"
"nothing here says what this fn"; "nothing here says what this fn";
refuses "a function value would be zeroed" "programs/fn-in-struct.flan" refuses "a function value would be zeroed" "programs/fn-in-struct.flan"
@ -5255,7 +5274,7 @@ level "1"
(List.filter (List.filter
(fun line -> (fun line ->
contains line prefix contains line prefix
&& contains line "constant { i64, i64, ptr }") && contains line "constant { i64, i64, ptr, i64, ptr, i64, ptr }")
(String.split_on_char '\n' ir)) (String.split_on_char '\n' ir))
in in
if n <> want then begin if n <> want then begin
@ -5354,6 +5373,105 @@ level "1"
[the global ...] sites and two [the return type of ...] ones, which a [the global ...] sites and two [the return type of ...] ones, which a
walk over function bodies alone would never have found. *) walk over function bodies alone would never have found. *)
no_gc_sites "programs/dyn-global.flan" 6; no_gc_sites "programs/dyn-global.flan" 6;
(* A capturing fn allocates its environment from the collector, so it is
a site too, with its own sentence. The file has more than one. *)
no_gc_sites "programs/fn-escape.flan" 2;
(* A dev build cannot trust what a named callee does with a closure: a
redefinition of the callee recompiles the callee alone. So [go]'s
closure is on the heap in both dev backends and on the frame in a
release build. The text between go's entry and the next function is
asked, which is enough to tell the two apart. *)
(let path = "programs/fn-dev-escape.flan" in
let l = Load.program ~file:path (Reader.read_file path) in
let p = Check.program_all l.Load.decls in
(* From go's entry to the end of its body. *)
let go_part key text =
let n = String.length text and k = String.length key in
let rec find i =
if i + k > n then None
else if String.sub text i k = key then Some i else find (i + 1)
in
match find 0 with
| None -> ""
| Some i ->
let rest = String.sub text i (n - i) in
let m = String.length rest in
let rec close j =
if j + 2 > m then m
else if rest.[j] = '\n' && rest.[j + 1] = '}' then j
else close (j + 1)
in
if key.[0] = 'd' then String.sub rest 0 (close 0)
else String.sub rest 0 (min 4000 m)
in
let heap_ll text = contains (go_part "define {} @\"flan.go\"" text) "flan_dyn_env_new" in
let heap_x86 text = contains (go_part "\"flan.go\":" text) "flan_dyn_env_new" in
if heap_ll (Emit.program ~dev:false p) then begin
incr failures;
print_endline "FAIL a release build moved a frame closure to the heap"
end;
if not (heap_ll (Emit.program ~dev:true p)) then begin
incr failures;
print_endline "FAIL a dev build left a closure handed to a named call on the frame"
end;
if not (heap_x86 (X86.program ~checks:true ~dev:true p)) then begin
incr failures;
print_endline
"FAIL a dev --x86 build left a closure handed to a named call on the frame"
end);
(* In a program that does make a collector-owned environment, a function
whose only function value is a parameter still roots nothing: the
caller holds what it passed. This is what keeps the prelude's
higher-order functions as cheap as they were. *)
(let path = "programs/fn-escape.flan" in
let l = Load.program ~file:path (Reader.read_file path) in
let ir = Emit.program (Check.program_all l.Load.decls) in
let body =
match String.split_on_char '\n' ir with
| lines ->
let rec from = function
| [] -> []
| x :: rest when contains x "define" && contains x "@\"flan.apply-to\"" ->
let rec upto = function
| [] -> []
| "}" :: _ -> []
| y :: r -> y :: upto r
in
upto rest
| _ :: rest -> from rest
in
String.concat "\n" (from lines)
in
if body = "" || contains body "flan_dyn_root_push" then begin
incr failures;
Printf.printf "FAIL apply-to roots its function parameter (or was not found)\n"
end);
(* And a capturing fn that is only called and passed down keeps its
copies on its frame, so --no-gc has nothing to say about it. *)
(let path = "programs/fn-capture.flan" in
let l = Load.program ~file:path (Reader.read_file path) in
match Check.no_gc (Check.program_all l.Load.decls) with
| () -> ()
| exception Loc.Errors ds ->
incr failures;
Printf.printf "FAIL --no-gc refused %s: %s\n" path
(String.concat "; " (List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds)));
(* And the price closures do not charge: a program whose function values
capture nothing roots none of them and sets up no heap, so its IR has
no root push and no collector start-up in it. *)
List.iter
(fun path ->
let l = Load.program ~file:path (Reader.read_file path) in
let ir = Emit.program (Check.program_all l.Load.decls) in
if contains ir "call void @flan_dyn_root_push"
|| contains ir "call void @flan_gc_init" then begin
incr failures;
Printf.printf
"FAIL %s roots or starts the collector with no capture in it\n"
path
end)
[ "programs/fn-values.flan"; "programs/higher-order.flan" ];
(* The other half, and the reason the flag is a pass and not a parameter of (* The other half, and the reason the flag is a pass and not a parameter of
[Emit]: a program with nothing to refuse compiles to the same bytes with [Emit]: a program with nothing to refuse compiles to the same bytes with

12
test/test_dev.ml
View File

@ -7045,6 +7045,18 @@ let () =
if not (await ~ms:20000 (fun () -> value "(> seen 0)" = Some "true")) if not (await ~ms:20000 (fun () -> value "(> seen 0)" = Some "true"))
then fail "--%s: the stale fixture never ran step" backend then fail "--%s: the stale fixture never ran step" backend
else begin else begin
(* A capturing fn typed at the prompt: the body it lifts and the
environment it captures into go into the evaluation's module
with it. *)
(match
value
"(let [k (i64 1000) xs [(i64 1) (i64 2)]] \
(reduce (slice xs 0 2) (i64 0) (fn [a b] (+ a (+ b k)))))"
with
| Some "2003" -> ()
| v ->
fail "--%s: a capturing fn at the prompt answered %s" backend
(Option.value ~default:"nothing" v));
let r = eval "(defn scale [x i64 k i64] i64 (* x k))" in let r = eval "(defn scale [x i64 k i64] i64 (* x k))" in
if status r <> "ok" then if status r <> "ok" then
fail "--%s: a signature change was refused: %s" backend (said r) fail "--%s: a signature change was refused: %s" backend (said r)

16
test/test_flan.ml
View File

@ -6410,6 +6410,22 @@ let () =
"may allocate: a push past the Vec's capacity grows it through its \ "may allocate: a push past the Vec's capacity grows it through its \
allocator") ]; allocator") ];
(* A capturing fn that outlives its frame allocates its environment on the
collected heap. One only called or passed down keeps its copies on the
frame, and one that captures nothing is a code address; neither
allocates. *)
memory "a capturing fn that escapes, one that does not, and one that captures nothing"
"(defn apply1 [f (Fn [i32] i32) x i32] i32 (f x))\n\
(defn make [n i32] (Fn [i32] i32) (fn [x] (+ x n)))\n\
(defn main [] ()\n\
\ (let [n 3]\n\
\ (print (apply1 (fn [x] (+ x n)) 1))\n\
\ (print (apply1 (fn [x] x) 1))\n\
\ (print ((make 2) 1))))"
[ (2, 35, gc,
"allocates: an fn that captures and outlives its frame keeps its \
copies in an environment on the collector's heap") ];
(* The allocator side, and the two shapes of [flan_vec_init]: [slurp] sizes (* The allocator side, and the two shapes of [flan_vec_init]: [slurp] sizes
the Vec to the file and takes a block here, [(vec-new i32 a)] passes a the Vec to the file and takes a block here, [(vec-new i32 a)] passes a
capacity of zero and takes none. Same runtime entry point, two answers, capacity of zero and takes none. Same runtime entry point, two answers,