diff --git a/TODO.org b/TODO.org index ceb797c9..cc99b747 100644 --- a/TODO.org +++ b/TODO.org @@ -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, Func, Fnptr. -** NEXT Escaping closures, allocated on the GC side -Decided 2026-09-25: start it. It must work on wasm32. -The second half of "do both". What changes is where the environment points — a -frame slot today, a collector allocation then — and the escape check goes away -with it, along with the refusals on returning, storing, pointing at and pushing a -capturing value. Two things for it to know: a widening thunk's environment holds a -code pointer rather than a GC object, and capturing a dyn stays refused until a -synthesised environment has a descriptor. +** DONE Escaping closures, allocated on the GC side +CLOSED: [2026-09-25] +Only a capturing =fn= that may outlive its frame gets a collector environment; one +only called or passed down keeps its stack environment, as every handler does. +Capture stays by value, and a =Map= of function values is refused. Rules out a +tag bit on the environment word and a heap environment for every closure. ** WAIT CFn and C's calling convention Decided 2026-09-25: waits with C callbacks, until a program needs one. @@ -1089,7 +1087,7 @@ An unknown call whose near miss is a value — =(context-allocator)= against =context/allocator=, or a global — says the name is a value written without parentheses, and names no call at all when the call had arguments. -** NEXT (max-of T) and (min-of T) +** NEXT (max-value T) and (min-value T) Decided 2026-09-25: the type-limit constants as a form taking a type, Odin's max(T), valid at any numeric type or a numeric?-bounded variable. For a float, min-of is the most negative finite value. @@ -1204,6 +1202,8 @@ the buffer. ** 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 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. ** NEXT A sliced string loses the trailing NUL @@ -1276,6 +1276,13 @@ lowering buffer annotates all four sections, the two =llc= ones from a =--debug= copy of the IR. Rules out writing a disassembler, and reading the source off disk at disassembly time. +** NEXT A temporary allocator, wiped each frame +Decided 2026-09-25: Odin's context.temp_allocator. i64->bytes, f64->bytes and +other quick formatting allocate from it, so a number drawn every frame no longer +leaks from the default allocator. A dev build wipes it at each frame boundary; +otherwise the program calls (free-temp) once per frame. Text kept past the frame +is cloned. + * Runtime ** DONE An index out of range is a condition diff --git a/docs/BUILT.md b/docs/BUILT.md index 8d646bd9..440ab170 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -4332,7 +4332,8 @@ implemented. **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 - 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. - **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 @@ -4358,8 +4359,9 @@ feature. This compiles: (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, -and the lifted body reads the copy. Not a reference: `fn-capture.flan` changes the local through a pointer *after* +`bonus` is **copied** into an environment at the instant the `fn` value is made, and the lifted body reads the copy. +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 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 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, -stored, pointed at, or pushed into a container**. The check runs over the typed IR of every function the program -ends up with — including the lifted ones, so an `fn` inside an `fn` needs no special case — and classifies -function-typed values as *suspect* or clean: +spec-memory.md's **case 3**. A capturing `fn` is checked with its copies on the frame it was written in, and +`Check.place_closures` moves them to an environment the collector allocates (`flan_dyn_env_new`) only for a value +that may outlive that frame. A closure that is only called, passed down or let-bound keeps its stack environment, +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 - every function; an `Fn` read back out of a struct, a case or a pointer; a local bound to any of those, - transitively; a branch or a valued form whose value is one. -- clean: the address of a name, the result of any call, and **everything of type `CFn`** — the last for free, - because a `CFn` has no environment to dangle and the type says so. The second follows from the first refusal, - which is what stops a function from returning a suspect at all. +**What escapes** is decided over the whole program, to a fixed point: a function value is followed back to a +literal, a parameter or a lifted body's copy of a captured value, and escapes when one of those reaches a `set`, a +return, an `Option`, an array, a struct or case field, a pointer to its slot, the runtime (a push, a put), a +restart's arguments or an argument of a call through a function value. A call to a named function asks the callee +whether that parameter escapes; a capture asks the lifted body whether its copy escapes, and escapes outright when the +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 -`CFn` has already promised what the analysis would otherwise have to prove, and nothing written against one is -ever examined. +**Capture stays by value.** A store into a captured name is still refused (`fn-capture-set.flan`); shared state goes +through something that is itself a reference, such as a captured dyn map. -**The clean set is the enumeration, not the suspect set**, and that is a correction. It read the other way round — -`Field`, `CaseField` and `Deref` named as suspect, everything else clean — and had a hole exactly where a list like -this cannot: `(at s 0)` over a slice of `Fn` is a `Prim`, so it came out clean while the `Vec`, struct and pointer -spellings of the same act were refused. Nothing can write an `Fn` into a slice today, so it was unreachable; but -the pass claims its enumeration is closed, and a default of "clean" is how that claim stops being true without -anyone noticing. `fn-escape-at.flan` pins it. The same inversion fixed which of the two refusal messages an index -read gets. +**Three things can be in an `Fn`'s second word** — null, an environment (on a frame or on the heap), or a widened +name's code address — and nothing in the word says which; on wasm32 a code address is a small table index, so no tag +bit is free. The collector keeps the **set of environments it allocated** and follows a word only when the set has +it, so it never reads through a code address or a frame address. The sweep deletes freed environments from the set +and shrinks it once it is mostly empty. -Two of those arms are there because leaving them out is unsound rather than merely conservative, and each has a -program. **A function value read out of an environment** (`fn-escape-copy.flan`): a lifted body holds *copies* of -what it captured, read back with `Field(Deref env, i)`, so a copy of a captured function value carries whatever -environment the original did. Treat it as clean and the lifted body can return it, the return arrives at the outer -caller as an ordinary call result, and the whole "a call result is clean" rule has been walked around from inside. -**A valued form's tail** (`fn-escape-handled.flan`): `handler-bind`, `with-allocator` and `restart-case` are -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. +**Descriptors** gained two tables beside the dyn words: environment words, and `Vec` headers whose elements hold +function values, with the element's descriptor. Environment words are named through `Option`, data type payloads and +unions — every case's word, since the live case is a tag the table cannot read — which is sound only because of the +set. The LLVM offsets are constant `getelementptr` expressions over the type, so wasm32's 4-byte pointers are laid +out by the target (`gcword.gpath`); x86 writes numbers. The descriptors follow the function bodies in the module, +because LLVM sizes a named type only after its definition. -**The parameter rule is the whole answer to the hard case.** A capturing `fn` 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: -`(defn keep [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. `fn-escape-param.flan` is that refusal, written down as a -refusal of something that would sometimes have been fine. +**A `Vec` header is not trusted.** It is copied by value, so a copy goes stale when another copy's push moves the +block, and the freed block may be unmapped. flan_rt.c reports every Vec block it allocates, moves or frees through +`flan_vec_block_hook`; `flan_dyn_track_vecs`, called first thing in `main` by a program that can make a heap +environment, installs the collector's table of live blocks, and the marker reads a header's elements only when its +pointer is a live block, no further than the block's size, and not after its allocator's epoch has moved. +`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 -suspect into a clean value and the return refusal has been walked around. Treating the `deref` itself as suspect is -the other half of that door, and it is free: nothing a `(Ptr (Fn ...))` can point at is anywhere but a frame, since -a global and a struct field of function type are both refused already. +**The static side does not pay.** `Emit.m.gcfn` is true when some closure's environment is on the heap, or in a dev +build. Otherwise an `Fn` holds nothing the collector owns and nothing roots one. When it is true, a *parameter* of +function type is still not rooted — it cannot be assigned, so it holds what the caller passed, and the caller holds +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 -deliberate tightening: inside the enclosing function a local shadows a global of the same name, so a body lifted out -of it must mean the same thing. The old order was an accident of where the refusal sat. +**What is refused.** A `Map` whose values hold a function value (`fn-in-map.flan`): a `Map`'s storage is not walked. +A bare `Fn` field, global or array element is still refused for its zero; `(Option (Fn ...))` holds one. -Every one of these messages names **case 3** — the escaping closure, with an environment the collector owns — -because "this cannot be done" and "this cannot be done yet" are different sentences and the second is the true one. -Five programs: `fn-escape-return.flan`, `fn-escape-param.flan`, `fn-escape-store.flan`, `fn-escape-vec.flan`, and -`fn-capture-set.flan`. +**A module that makes a heap closure is never unloaded**: the environment points at the module's descriptor and +code, so making one counts toward the same gate a string literal does. A capturing `fn` typed at the dev prompt takes +its lifted body and environment struct into the evaluation's module. ### 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` -header copy as their words, aliasing whatever they pointed at — which is exactly right while the value cannot -outlive the frame that owns the storage, and is exactly what would break under escape. A function value copies as a -function value, environment included; capturing one into another `fn`'s environment is the one place a suspect may -be written into an aggregate, and it is sound because the outer literal is itself suspect, so the pair of -environments lives and dies with one frame. - -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`. +Anything. A scalar, a struct and a fixed array copy whole. A string, a slice and a `Vec` or `Map` header copy as their +words and alias what they point at — the same borrow a struct holding a slice has when it is returned, which the +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, and the environment's descriptor names the copy's environment word, so a +closure capturing a closure keeps it alive. A **dyn** copies as a dyn word and the descriptor names it +(`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. ### 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 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 symbol used to stand alone; two `extractvalue`s at a call through an `Fn`; one appended operand on that call and on diff --git a/lib/ast.ml b/lib/ast.ml index 67c17a62..6b8c529d 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -127,7 +127,7 @@ and expr_kind = | ArrayFill of len list * expr | ArrayGen of len list * expr (* 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 [i start stop step] ...). The bounds are a record rather than three positional fields because the one-bound form is the common one and diff --git a/lib/check.ml b/lib/check.ml index de1745ea..8188fefb 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -741,19 +741,7 @@ let rec capture ctx loc name = | None -> if ctx.outer_what = None then None else from_parent () in match ctx.outer_what, outer with - | Some what, 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; + | Some _, Some (outer : binding) -> let slot = bind ctx name outer.bty ~assignable:false in ctx.caught <- ctx.caught @ [ (name, (outer, slot)) ]; Some { slot; bty = outer.bty; assignable = false; bwhat = None } @@ -1077,12 +1065,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 they are all the same position: something zeroes it. - Since capture arrived there is a second reason standing behind the first, - and it is the sharper one: every position on this list outlives the frame - a captured environment is on, so even a value nobody zeroed could not be - 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. + The zero is the whole reason: a capturing value's environment belongs to + the collector and may be kept anywhere, and [(Option (Fn ...))] is how a + field or a global holds one. 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 @@ -1211,9 +1196,9 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = (resolve env ~seen v) (* (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 - of an [fn] that captures carries the address of the copies on the frame - it was written in, and [escape_check] is what stops that address - outliving the frame. + of an [fn] that captures carries the address of its copies: a slot of + the frame it was written in, or an environment the collector allocated + when the value outlives that frame (see [place_closures]). (CFn [T ...] R) is the address alone, one word, and nothing that can capture — see [Types] for why the C is information rather than @@ -2310,7 +2295,6 @@ let close_over ~fname (octx : ctx) (fctx : ctx) loc = caught in let prefix body = [ mk loc fctx.ret (Tast.Let (binds, body)) ] in - let mslot = fresh_slot octx ety in let make = mk loc ety (Tast.Make (ename, @@ -2319,6 +2303,7 @@ let close_over ~fname (octx : ctx) (fctx : ctx) loc = mk loc b.bty (Tast.Local b.slot)) caught)) in + let mslot = fresh_slot octx ety in prefix, Some eslot, Some (mslot, make), Some (mk loc (Types.Ptr ety) (Tast.Addr (Tast.Plocal mslot))) @@ -4464,15 +4449,13 @@ and block ctx ?want ?(defer_ok = false) loc body = landed, and the surface feature is that machinery given a name rather than a second one invented beside it. - **Capture is by value, and the value may not escape.** The body sees its - parameters, the program's globals, and the locals of the function it was - written in — those last copied into an environment on that function's - frame at the instant the value is made (see [capture] and [close_over]). - So the value is two words, the second of them an address into a frame, and - what keeps that address good is [escape_check]: it may be called, passed - down and let-bound, and may not be returned, stored or pushed anywhere. - 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. + **Capture is by value.** The body sees its parameters, the program's + globals, and the locals of the function it was written in — those last + copied into an environment at the instant the value is made (see + [capture] and [close_over]). The copies go on that function's frame, and + [place_closures] moves them to an environment the collector allocates for + a value that may outlive the frame — so it may be returned, stored or + pushed like any other value: spec-memory.md's case 3. **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 @@ -4622,11 +4605,12 @@ and check_fn ctx ~want ?gen loc (params : string list) body = let v = match addr with | 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 -> - (* 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 mk loc fty (Tast.Let ([ Option.get bind ], [ c ])) in @@ -4713,7 +4697,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 pushed it and nothing in the language can name one, so the clause 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 = close_over ~fname ctx hctx c.Ast.hloc in @@ -12481,8 +12466,82 @@ let value_sites (p : Tast.program) ?(after_fn = fun (_ : Tast.fn) -> ()) (* 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 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 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 | Some at -> Loc.failk "check/dyn-descriptor" loc @@ -12556,240 +12615,10 @@ let dyn_descriptors (p : Tast.program) = "What C hands back points at storage this compiler never rooted") p.Tast.externs; value_sites p (fun ~slot:_ loc what t -> check loc what t) -(* ── Escape, which is the other half of capture ──────────────────────── - spec-memory.md's case 2 is the *non-escaping* fn, and this is what makes - the word mean something. A captured copy lives in a slot of the frame the - literal was written in, so a value holding that frame's address may be - 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 ] - | _ -> ()) +(* See lib/closures.ml. *) +let is_env_struct = Closures.is_env_struct +let heap_env = Closures.heap_env +let place_closures fns = Closures.place ~dev:false fns let build_program ~keep_going ?tolerate (decls : Ast.decl list) : Tast.program * env * string list = @@ -12938,10 +12767,8 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : they are reached *by name* from arbitrary call sites, so they carry no [fparent] and a dev build gives each its own cell. *) let fns = fns @ List.rev env.instances in - (* Where a captured copy may go, asked of every function the program ended - up with. Here rather than inside [check] because it is a question about a - finished body — see the header on [escaping]. *) - List.iter escape_check fns; + (* Which capturing fns outlive their frame; see [place_closures]. *) + let fns = place_closures fns in (* And the order the computed initialisers run in, which needs the whole function list: what a global reads is transitive through what it calls. *) let globals = init_order globals fns in @@ -13047,6 +12874,21 @@ let instances_since env mark = List.rev (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 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 @@ -13118,7 +12960,7 @@ let expression env ?want (e : Ast.expr) : let dyn_sites (p : Tast.program) : Loc.diag list = 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 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 @@ -13145,17 +12987,30 @@ let dyn_sites (p : Tast.program) : Loc.diag list = && String.length sym > 8 && String.sub sym 0 8 = "flan_dyn" -> 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); List.rev_map - (fun (loc, what) -> + (fun (loc, site) -> Loc.diag ~kind:"check/no-gc" loc - (Printf.sprintf - "%s holds a dyn, and --no-gc says this program carries no \ - collector. A \ - dyn value is one the runtime allocates and the collector owns, so \ - there is nothing smaller to compile it to — write the type" - what)) + (match site with + | `Dyn what -> + Printf.sprintf + "%s holds a dyn, and --no-gc says this program carries no \ + collector. A \ + dyn value is one the runtime allocates and the collector owns, \ + so there is nothing smaller to compile it to — write the type" + 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 let no_gc (p : Tast.program) = @@ -13314,19 +13169,25 @@ let memory_sites ?file (p : Tast.program) : Loc.diag list = let found = ref [] in let seen = Hashtbl.create 64 in let look (e : Tast.expr) = - match e.Tast.e with - | Tast.Prim (Tast.Rt sym, args) -> - (match memory_class sym args with - | None -> () - | Some (kind, msg) -> - let loc = e.Tast.loc in - let key = (loc.Loc.file, loc.Loc.line, loc.Loc.col, kind) in - if (match file with None -> true | Some f -> String.equal f loc.Loc.file) - && not (Hashtbl.mem seen key) then begin - Hashtbl.replace seen key (); - found := Loc.diag ~kind loc msg :: !found - end) - | _ -> () + let cls = + match e.Tast.e with + | Tast.Prim (Tast.Rt sym, args) -> memory_class sym args + | 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 -> () + | Some (kind, msg) -> + let loc = e.Tast.loc in + let key = (loc.Loc.file, loc.Loc.line, loc.Loc.col, kind) in + if (match file with None -> true | Some f -> String.equal f loc.Loc.file) + && not (Hashtbl.mem seen key) then begin + Hashtbl.replace seen key (); + found := Loc.diag ~kind loc msg :: !found + end in (* 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 diff --git a/lib/closures.ml b/lib/closures.ml new file mode 100644 index 00000000..2042f619 --- /dev/null +++ b/lib/closures.ml @@ -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 } diff --git a/lib/emit.ml b/lib/emit.ml index cea599bc..57c92886 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -428,6 +428,34 @@ let dfile d path = 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 ────────────────────────────────────────────── *) type m = { @@ -450,6 +478,16 @@ type m = { externs : (string, string) Hashtbl.t; checks : bool; (* emit bounds checks *) 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 redefinition module, and only for a name introduced since. *) known : string -> bool; @@ -505,8 +543,10 @@ type m = { 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 type the base program already named therefore gets its own copy, which is - harmless — a descriptor is read-only and has no identity. *) - descs : (string, string * int list * int) Hashtbl.t; + harmless — a descriptor is read-only and has no identity. A closure's + 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 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 @@ -730,20 +770,198 @@ let desc_mangle (t : Types.t) = 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 symbol. *) -let desc_of m (t : Types.t) : string option = - match dyn_offsets m t with - | [] -> None - | offs -> +let rec desc_of m (t : Types.t) : string option = + let l = gc_layout m t in + if l.gdyn = [] && l.genv = [] && l.gvec = [] then None + else let key = Types.to_string t in match Hashtbl.find_opt m.descs key with - | Some (sym, _, _) -> Some sym + | Some d -> Some d.dsym | None -> let sym = Printf.sprintf "flan.desc.%s.%d" (desc_mangle t) (Hashtbl.length m.descs) 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 +(* ── 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 the pool holds one node per distinct type. *) 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 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. *) -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) = - (x.Tast.ty = Types.Dyn || dyn_offsets m x.Tast.ty <> []) + traced m x.Tast.ty && (match x.Tast.e with | 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.Zero _ | Tast.Uninit _ | Tast.None_ | Tast.Unit -> false | _ -> true) @@ -1361,24 +1583,57 @@ let held_operands m (e : Tast.expr) : Tast.expr list = let is_array (x : Tast.expr) = match x.Tast.ty with Types.Array _ -> true | _ -> false 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 + | 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.At | Tast.Slice), t :: 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.CallPtr (c, es) -> pick (by_value (c :: es)) | _ -> [] let root_plan m (fn : Tast.fn) : rootplan = let rslots = ref [] in + let nparams = List.length fn.Tast.params in Array.iteri (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) fn.Tast.slots; 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 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 @@ -1389,7 +1644,10 @@ let root_plan m (fn : Tast.fn) : rootplan = let collect (e : Tast.expr) = List.iter (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 List.iter (Tast.walk collect) fn.Tast.body; List.iter (Tast.walk collect) fn.Tast.fdefers; @@ -2248,7 +2506,36 @@ and value_at f (e : Tast.expr) : string = let code, env = match e.Tast.e with | 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 an environment would be. The thunk reads it back out and calls it, 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. *) and addr_rooted f (e : Tast.expr) : string = 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 let tmp = agg_tmp f e.Tast.ty 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 ins f "store i64 %s, ptr %s" t slot 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 ins f "store %s %s, ptr %s" (ll ret) t slot end; @@ -3840,22 +4127,39 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = in if nroots > 0 then begin let nparams = List.length fn.Tast.params in - (* Zeroing the dyn words at [base], which is the whole of the contract - runtime/flan_dyn.h states for a pushed root. *) + (* Zeroing the words the collector reads at [base], which is the whole of + 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) = if ty = Types.Dyn then Buffer.add_string f.allocas (Printf.sprintf " store i64 0, ptr %s\n" base) - else + else begin + let at path = + List.fold_left + (fun acc (sty, idx) -> + let p = Printf.sprintf "%%z%d" f.n in + f.n <- f.n + 1; + Buffer.add_string f.allocas + (Printf.sprintf " %s = getelementptr inbounds %s, ptr %s, %s\n" + p sty acc (String.concat ", " idx)); + p) + base path + in + let store what path = + Buffer.add_string f.allocas + (Printf.sprintf " store %s, ptr %s\n" what (at path)) + 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 off -> - let p = Printf.sprintf "%%z%d" f.n in - f.n <- f.n + 1; - Buffer.add_string f.allocas - (Printf.sprintf " %s = getelementptr inbounds i8, ptr %s, i64 %d\n" - p base off); - Buffer.add_string f.allocas - (Printf.sprintf " store i64 0, ptr %s\n" p)) - (dyn_offsets m ty) + (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 let push base (ty : Types.t) = match (if ty = Types.Dyn then None else desc_of m ty) with @@ -4532,6 +4836,8 @@ declare i64 @flan_dyn_view_vec(ptr, i32) declare i64 @flan_dyn_view_flat(ptr, i64, i32) declare void @flan_dyn_root_push(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_globals_begin() declare void @flan_dyn_root_globals_end() @@ -4616,7 +4922,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 signature that mentions it, a slot that holds one, or an expression that 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) = + makes_closures p || let structs = Hashtbl.create 16 in List.iter (fun (s : Tast.structure) -> Hashtbl.replace structs s.Tast.sname s) @@ -4662,6 +4990,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 first thing it does is allocate. *) 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 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 @@ -4799,7 +5133,8 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false) unions = Hashtbl.create 16; globals = Hashtbl.create 16; 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; dbg = (if debug then Some (new_dbg p) else None); fsigs = fsigs_of p; @@ -4902,35 +5237,61 @@ let dmodule d = Buffer.add_buffer b d.dout; Buffer.contents b -(* The per-type dyn descriptors, as runtime/flan_dyn.h's [flan_desc] laid out - by hand: two i64s and a pointer to the offset table. [private] because a - redefinition module may name a type the program it 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. *) +(* The per-type descriptors, as runtime/flan_dyn.h's [flan_desc] laid out by + hand: the size, then a count and a table for each of the three kinds of + word. An empty table is a null pointer rather than a zero-length array. + [private] because a redefinition module may name a type the program it + 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 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 [] |> List.sort (fun (a, _) (c, _) -> String.compare a c) |> 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 (Printf.sprintf - "@\"%s.offs\" = private unnamed_addr constant [%d x i64] [%s]\n" - sym (List.length offs) - (String.concat ", " - (List.map (Printf.sprintf "i64 %d") offs))); - Buffer.add_string b - (Printf.sprintf - "@\"%s\" = private unnamed_addr constant { i64, i64, ptr } \ - { i64 %d, i64 %d, ptr @\"%s.offs\" }\n" - sym size (List.length offs) sym)); + "@\"%s\" = private unnamed_addr constant \ + { i64, i64, ptr, i64, ptr, i64, ptr } \ + { i64 %d, i64 %d, ptr %s, i64 %d, ptr %s, i64 %d, ptr %s }\n" + d.dsym d.dsize (List.length l.gdyn) offs (List.length l.genv) + envs (List.length l.gvec) vecs)); Buffer.contents b (* 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 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 - 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 b = Buffer.create 256 in let rows = @@ -4939,10 +5300,11 @@ let descriptors_asm m = in if rows <> [] then Buffer.add_string b - "\n# The per-type dyn descriptors — runtime/flan_dyn.h's flan_desc: the\n\ - # size of one instance, how many dyn words it holds, and where they are.\n\ - # Read by the collector through flan_dyn_root_push_desc and by nothing\n\ - # else; no value points at one.\n\ + "\n# The per-type descriptors — runtime/flan_dyn.h's flan_desc: the size\n\ + # of one instance, then the dyn words, the environment words of its\n\ + # function values, and the Vec headers whose elements hold either, each\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\ # .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\ @@ -4952,20 +5314,41 @@ let descriptors_asm m = # for exactly this: relocated at load and read-only from then on.\n\ \t.section\t.data.rel.ro,\"aw\",@progbits\n"; List.iter - (fun (_, (sym, offs, size)) -> - Buffer.add_string b (Printf.sprintf "\t.align\t8\n.L%s.offs:\n" sym); - List.iter - (fun o -> Buffer.add_string b (Printf.sprintf "\t.quad\t%d\n" o)) - offs; + (fun (_, d) -> + let l = d.dlay in + let table suffix lines = + if lines = [] then "0" + 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 (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" - sym size (List.length offs) sym)) + "\t.align\t8\n.L%s:\n\t.quad\t%d\n\t.quad\t%d\n\t.quad\t%s\n\ + \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; 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 = - 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 "") ^ (match m.dbg with None -> "" | Some d -> dmodule d) @@ -5038,6 +5421,10 @@ let macro_thunk m (fn : Tast.fn) = let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = []) ?(sanitize = false) ?(macros = []) ?(hidden = false) ?(annotate = false) (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 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 @@ -5141,7 +5528,7 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = []) ~dyn_globals: (List.filter_map (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) p.Tast.globals) fn @@ -5188,6 +5575,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) ?(known = fun _ -> true) ?(retains = true) ?call ?(consts = []) ?(annotate = false) (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 let target name = match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with | Some f -> f diff --git a/lib/session.ml b/lib/session.ml index 30811e2e..065094f7 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -455,13 +455,16 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) = (fun (s : Tast.structure) -> (* 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 - about values the running program is *holding*: every other struct can - be in a global, in a container, in a frame that is on the stack right - now. An environment can be in exactly one place — a slot of the frame - the literal was written in — and it is written there by the same - module that reads it, on every entry. 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. *) + about values the running program reads with code newer than the code + that wrote them. An environment is only ever read by the lifted body + that was compiled beside the literal that made it: a function value + carries that body's own symbol, not a cell, and a redefinition module + carries its own copy of every lifted body it replaces. A value made + before the reload keeps calling the old body over the old layout — + 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 match List.find_opt @@ -2274,8 +2277,10 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = below — without this the thunk calls a symbol the module never defines and the host has no cell for. *) 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 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 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. *) @@ -2311,9 +2316,26 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = (* 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 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 = { 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 } in let ir = diff --git a/lib/tast.ml b/lib/tast.ml index 7f1aa9af..aacfa5e7 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -112,22 +112,23 @@ and expr_kind = dev build is not the symbol but whatever the indirection cell holds, and carries the Flan type [Fn]. *) | FnAddr of fnref - (* A function value with an environment: the lifted body, and the address of - the copies the enclosing frame is holding for it. The environment is a - [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 - [Addr (Plocal _)] and the copies were taken where the value was made. + (* A function value with an environment: the lifted body, and one of two + things, told apart by the second expression's type. + + - A pointer: the address of a slot of this frame holding the copies, filled + 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 different questions: [FnAddr] is an address, and is asked for by three 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. - - 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. *) + while this is a *value* of type [Fn] and can never be anything else. *) | Closure of fnref * expr (* 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 diff --git a/lib/x86.ml b/lib/x86.ml index 3ed43185..de4665cf 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -489,7 +489,8 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m = p.Tast.globals; { Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions; 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 } 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 = match e.Tast.e with | 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 an environment would be. The thunk reads it back out and calls it, 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 in store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; (match env with | 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 | Tast.FnAddr 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. *) and lvalue_rooted f (e : Tast.expr) : loc = 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 let o = agg_tmp f e.Tast.ty in lower f e (Lf o); @@ -3018,7 +3045,7 @@ and call_flan f ?env ~target ~args ~rty dst = let o = dyn_tmp f in store_int f.b ~src:rax ~mm:(Frame o) ~size:8 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 copy_loc f ~dst:(Lf o) ~src:dst (sizeof f.md rty) end @@ -4000,7 +4027,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) else List.iter (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; List.iter (fun (off, ty) -> @@ -4398,6 +4425,12 @@ let emit_main ?(ann = false) ?(startup = false) ?(gc = false) xor_rr b ~dst:rax ~src:rax; call_sym b "flan_gc_init" 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 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 @@ -4840,6 +4873,10 @@ let emit_dwarf (dw : dwarf) ~cufile ~tbeg ~tend = (* A whole program as one assembly file. *) let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) (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 externs = Hashtbl.create 16 in List.iter @@ -4979,7 +5016,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) ~dyn_globals: (List.filter_map (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) p.Tast.globals) md fn) @@ -5130,6 +5167,10 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) ?(retains = true) ?(consts = []) ?call ?(annotate = false) (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 unsupported "x86 redefinition without cells: there is nothing to publish a body \ diff --git a/plan.org b/plan.org index e8b45efd..060ad2dd 100644 --- a/plan.org +++ b/plan.org @@ -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 cell; a *non-escaping* ~fn~ captures enclosing locals by value into a stack 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 conditions plus ~Option~ and ~or-else~. Monadic sequencing, if ever wanted, is a macro. diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index 190b616e..c54dfebf 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -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; -/* A type's dyn map: where the dyn words are inside one instance of it. The - * compiler emits one of these per type that has any, as static data, and hands - * a pointer to it to [flan_dyn_root_push_desc]. Nothing here ever writes one. - * [size] is not read by the collector; it is the stride an array of the type - * has, which is what the typed-container view will need. */ +/* A type's map of the words the collector follows: where they are inside one + * instance of it. The compiler emits one of these per type that has any, as + * static data, and hands a pointer to it to [flan_dyn_root_push_desc] or + * [flan_dyn_env_new]. Nothing here ever writes one. + * + * 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 { - int64_t size; - int64_t n; - const int64_t *offs; + int64_t size; + int64_t n; + const int64_t *offs; + int64_t nenv; + const int64_t *envs; + int64_t nvec; + const flan_desc_vec *vecs; } flan_desc; #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_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_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 * 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. [elem] is one of FLAN_VIEW_I64/F64/BOOL. */ 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]. */ } u; } flan_obj; @@ -311,7 +344,7 @@ typedef struct flan_obj { * is what keeps a future change to the marking gate from silently trusting * this function's default arm instead of failing loudly. */ 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; } @@ -971,9 +1004,11 @@ static int64_t mstack_n, mstack_cap; static void mark_push(flan_obj *o) { if (o == NULL || o->mark) return; o->mark = 1; - /* Only a vec and a map have anything to trace. A text and a boxed int are - * leaves, and marking them is the whole of their visit. */ - if (o->kind != OBJ_VEC && o->kind != OBJ_MAP) return; + /* Only a vec, a map and an environment with a descriptor have anything to + * trace. A text and a boxed int are leaves, and marking them is the whole + * 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) { int64_t cap = mstack_cap ? mstack_cap * 2 : 64; 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)); } +/* ── 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) { int64_t i; unsigned k; for (i = 0; i < roots_n; i++) { const flan_desc *d = roots[i].desc; if (d == NULL) mark_value(*(flan_dyn *)roots[i].base); - else { - int64_t j; - for (j = 0; j < d->n; j++) - mark_value(*(flan_dyn *)((char *)roots[i].base + d->offs[j])); - } + else mark_desc((char *)roots[i].base, d); } for (k = 0; k < RING; k++) mark_push(ring[k]); while (mstack_n > 0) { 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]); } } @@ -1018,7 +1320,8 @@ static void gc_sweep(void) { link = &o->next; } else { 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) { int64_t per = o->kind == OBJ_MAP ? 2 : 1; held += o->u.v.cap * per * (int64_t)sizeof(flan_dyn); @@ -1031,6 +1334,20 @@ static void gc_sweep(void) { } 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) { @@ -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 * 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. */ -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) { root_add(base, d == NULL ? &desc_empty : d); diff --git a/runtime/flan_dyn.h b/runtime/flan_dyn.h index 077107a1..33ca96b2 100644 --- a/runtime/flan_dyn.h +++ b/runtime/flan_dyn.h @@ -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 * run time and no second descriptor to follow. * - * [size] is the stride of one instance. The collector does not read it; the - * typed-container view will, which is the reason it is here now rather than - * being added later to data both lanes already emit. + * [size] is the stride of one instance, which is what a [vecs] entry's + * element descriptor is read for. * - * Nothing in this ABI ever writes a descriptor, and no value ever points at - * one. See [flan_dyn_root_push_desc]. */ + * Besides the dyn words, two more kinds of word the collector follows: + * [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 { - int64_t size; - int64_t n; - const int64_t *offs; + int64_t size; + int64_t n; + const int64_t *offs; + int64_t nenv; + const int64_t *envs; + int64_t nvec; + const flan_desc_vec *vecs; } flan_desc; /* ── Constructors ──────────────────────────────────────────────────── */ @@ -390,6 +407,20 @@ void flan_dyn_root_pop(int64_t n); * lifetime of the program; nothing copies it. */ 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 ──────────────────────────────────────────────────────── * * Additions to the agreed ABI, none of which the compiler lane has to emit. diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index db54a660..838767fb 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -1891,6 +1891,16 @@ void flan_vec_region_only(flan_vec *v, const uint8_t *loc, int64_t 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, int64_t align) { flan_allocator *a = flan_vec_adopt(v); @@ -1923,6 +1933,8 @@ static int8_t flan_vec_grow(flan_vec *v, int64_t want, int64_t size, else p = a->proc(a, FLAN_ALLOC_ALLOC, NULL, 0, bytes, align); 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->cap = cap; /* Any slice taken before this points at storage that may have moved. The @@ -2024,6 +2036,8 @@ void flan_vec_free(flan_vec *v, int64_t size, int64_t align, flan_vec_check(v, loc, loclen); 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); + if (v->ptr && flan_vec_block_hook) + flan_vec_block_hook(v->ptr, NULL, 0, NULL, 0); (void)align; v->ptr = NULL; v->len = 0; diff --git a/test/dyn_ops.c b/test/dyn_ops.c index 70f05f61..8fcbf923 100644 --- a/test/dyn_ops.c +++ b/test/dyn_ops.c @@ -896,7 +896,7 @@ static void desc(void) { (int64_t)offsetof(desc_row, tail) }; 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; flan_dyn was_label, was_note; diff --git a/test/programs/fn-capture-dyn.flan b/test/programs/fn-capture-dyn.flan index 03ee5b6d..a1a8e047 100644 --- a/test/programs/fn-capture-dyn.flan +++ b/test/programs/fn-capture-dyn.flan @@ -1,9 +1,6 @@ -;; A dyn is the one thing a capture refuses outright, and for the reason a -;; struct field of dyn already refuses: the collector's roots are frames, and -;; nothing pushes the fields of the environment struct a capture synthesises. -;; 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. +;; A dyn captured by an fn. The copy lives in the fn's environment, which the +;; collector allocated and marks through the environment's descriptor, so the +;; value it names stays alive for as long as the function value does. (defn run [f (Fn [] i64)] i64 (f)) ;; [d] is unannotated, which is what makes it a dyn. diff --git a/test/programs/fn-dev-escape.flan b/test/programs/fn-dev-escape.flan new file mode 100644 index 00000000..32b15ab1 --- /dev/null +++ b/test/programs/fn-dev-escape.flan @@ -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) diff --git a/test/programs/fn-escape-at.flan b/test/programs/fn-escape-at.flan deleted file mode 100644 index 33e7816e..00000000 --- a/test/programs/fn-escape-at.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape-copy.flan b/test/programs/fn-escape-copy.flan deleted file mode 100644 index b9f3a1ea..00000000 --- a/test/programs/fn-escape-copy.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape-handled.flan b/test/programs/fn-escape-handled.flan deleted file mode 100644 index 8e8fd54e..00000000 --- a/test/programs/fn-escape-handled.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape-match.flan b/test/programs/fn-escape-match.flan deleted file mode 100644 index 1fe2b10c..00000000 --- a/test/programs/fn-escape-match.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape-param.flan b/test/programs/fn-escape-param.flan deleted file mode 100644 index 6cba4ed2..00000000 --- a/test/programs/fn-escape-param.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape-return.flan b/test/programs/fn-escape-return.flan deleted file mode 100644 index c56617af..00000000 --- a/test/programs/fn-escape-return.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape-store.flan b/test/programs/fn-escape-store.flan deleted file mode 100644 index 248c3619..00000000 --- a/test/programs/fn-escape-store.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape-vec.flan b/test/programs/fn-escape-vec.flan deleted file mode 100644 index affa50f5..00000000 --- a/test/programs/fn-escape-vec.flan +++ /dev/null @@ -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) diff --git a/test/programs/fn-escape.flan b/test/programs/fn-escape.flan new file mode 100644 index 00000000..b990128e --- /dev/null +++ b/test/programs/fn-escape.flan @@ -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) diff --git a/test/programs/fn-in-map.flan b/test/programs/fn-in-map.flan new file mode 100644 index 00000000..1fabf906 --- /dev/null +++ b/test/programs/fn-in-map.flan @@ -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)) diff --git a/test/programs/fn-in-struct.flan b/test/programs/fn-in-struct.flan index 4bfd32db..0baf66ce 100644 --- a/test/programs/fn-in-struct.flan +++ b/test/programs/fn-in-struct.flan @@ -5,11 +5,9 @@ ;; left to crash at the call, and the same rule covers a global, a fixed ;; array's element and (zeroed). ;; -;; Capture sharpened the reason behind this one without changing it. A struct -;; outlives the frame it was built on, so a field could not hold a value -;; carrying an environment either — see fn-escape-*.flan. The zero is still -;; what the message names, because it is the objection that applies to every -;; function value and not only to a capturing one. +;; The zero is the whole objection: a capturing value's environment belongs to +;; the collector and may be kept anywhere, and (Option (Fn ...)) is the field +;; that holds one — see fn-escape.flan. ;; ;; 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 diff --git a/test/programs/fn-values.flan b/test/programs/fn-values.flan index 52362f23..2a0f11ba 100644 --- a/test/programs/fn-values.flan +++ b/test/programs/fn-values.flan @@ -1,7 +1,6 @@ ;; 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 -;; hand around — fn-capture.flan is the other half, and fn-escape-*.flan is -;; the line between them. +;; here captures — fn-capture.flan is the other half, and fn-escape.flan is a +;; capturing value outliving the frame that made it. ;; ;; 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 diff --git a/test/programs/fn-vec-stale.flan b/test/programs/fn-vec-stale.flan new file mode 100644 index 00000000..cb709112 --- /dev/null +++ b/test/programs/fn-vec-stale.flan @@ -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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index c913eff1..c4133974 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3471,6 +3471,10 @@ let () = local: kept 42\naggregate: kept 42\nnested: kept 42\n\ fn value: kept 42\nindex: kept 42\nfield index: kept 42\n" 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 ──────────────────────────────────────────────────────── 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 same explicit slots there as natively. *) 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 (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" "programs/higher-order.flan" higher_order_out; - (* Capture by value into a stack environment — spec-memory.md's case 2. - Three opt levels for the reason the case above has them, and for one - more: the environment is a struct in the frame and the value carries - 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 + (* Capture by value. Three opt levels for the reason the case above has + them, and for one more: the value carries the address of the copies, + 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 comes out of the indirection cell and the environment half must not have disturbed that. @@ -4378,32 +4388,43 @@ level "1" outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan" fn_capture_out; - (* What function values do *not* include, each refused by name. Escape is - the headline now that capture is not: the copies live in the frame the - literal was written in, so a value carrying their address may be - called, passed down and copied about, and may not outlive that frame. - Each of these names case 3 — the collector-allocated environment — - because "not yet" is the true sentence. *) - refuses "a captured fn cannot be returned" "programs/fn-escape-return.flan" - "a return would outlive the frame"; - refuses "a function value parameter cannot be kept" - "programs/fn-escape-param.flan" "may carry an environment"; - refuses "a function value cannot be stored through a pointer" - "programs/fn-escape-store.flan" "a store would outlive the frame"; - refuses "a function value cannot be pushed into a Vec" - "programs/fn-escape-vec.flan" "a container would outlive the frame"; - (* The two an escape check written by eye would have missed. A function - value read back out of an environment is a copy of something that may - carry one, and a handler-bind is an expression whose value is its - body's — so both are ways for a suspect to be a function's answer. *) - refuses "an index read is a read like any other" - "programs/fn-escape-at.flan" "may carry an environment"; - refuses "a match arm's binding is a binding" - "programs/fn-escape-match.flan" "may carry an environment"; - refuses "a captured function value cannot be handed back" - "programs/fn-escape-copy.flan" "a return would outlive the frame"; - refuses "a handler-bind's value is a return too" - "programs/fn-escape-handled.flan" "a return would outlive the frame"; + (* Closures that outlive their frame: spec-memory.md's case 3. The + environment is allocated by the collector, so a capturing fn is + returned, passed through a function that hands it back, held as an + argument while the next one collects, read back out + of another fn's environment, stored through a pointer, pushed into a + Vec beside a widened name, kept in an Option field and an Option + global, and called after a forced collection every time. The counter + shares state through a captured dyn map; a handler clause captures a + dyn and a closure; and a hundred thousand dropped environments leave + the heap small, which is the line that fails if they are never freed. + With the collector not marking environments, valgrind reports reads of + freed blocks on this program and the counter line traps. *) + outputs "an fn that outlives its frame" "programs/fn-escape.flan" + fn_escape_out; + outputs ~opt:"-O0" "an fn that outlives its frame, -O0" + "programs/fn-escape.flan" fn_escape_out; + outputs ~x86:true "an fn that outlives its frame, --x86" + "programs/fn-escape.flan" fn_escape_out; + outputs ~dev:true "an fn that outlives its frame, dev" + "programs/fn-escape.flan" fn_escape_out; + outputs "an fn captures a dyn" "programs/fn-capture-dyn.flan" "7\n"; + outputs ~x86:true "an fn captures a dyn, --x86" + "programs/fn-capture-dyn.flan" "7\n"; + (* A stale copy of a Vec of closures, and of a Vec of Vecs of them, whose + block a push on another copy moved and freed. With the marker trusting + 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" "programs/fn-capture-set.flan" "cannot assign to n"; (* 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)"; refuses "an Fn does not narrow to a CFn" "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" "nothing here says what this fn"; refuses "a function value would be zeroed" "programs/fn-in-struct.flan" @@ -5303,7 +5322,7 @@ level "1" (List.filter (fun line -> 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)) in if n <> want then begin @@ -5402,6 +5421,105 @@ level "1" [the global ...] sites and two [the return type of ...] ones, which a walk over function bodies alone would never have found. *) 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 [Emit]: a program with nothing to refuse compiles to the same bytes with diff --git a/test/test_dev.ml b/test/test_dev.ml index 4af6b6f5..015a62c1 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -7128,6 +7128,18 @@ let () = if not (await ~ms:20000 (fun () -> value "(> seen 0)" = Some "true")) then fail "--%s: the stale fixture never ran step" backend 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 if status r <> "ok" then fail "--%s: a signature change was refused: %s" backend (said r) diff --git a/test/test_flan.ml b/test/test_flan.ml index 7a918afc..49325eb6 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6437,6 +6437,22 @@ let () = "may allocate: a push past the Vec's capacity grows it through its \ 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 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,