diff --git a/TODO.org b/TODO.org index fcf9257b..2f2f83bd 100644 --- a/TODO.org +++ b/TODO.org @@ -1041,11 +1041,12 @@ globals-init path was not converted and still writes in place. fix has a shape already — the same temporary, chosen by an aliasing question. Whether the two become one predicate or two is the lane to decide. -** TODO The aggregate temporary is an unrooted buffer while it is filled -No root table names it. Harmless only while a dyn field in a struct was refused, -and per-type descriptors have since lifted that. Whoever relies on a dyn field -reaching this path has to root the buffer, or a collection running inside the -construction will not see what has been built so far. +** DONE The aggregate temporary is an unrooted buffer while it is filled +CLOSED: [2026-09-25] +The buffer stays unrooted. Every dyn word written into it while a sibling field +may allocate is also in a root slot of its own, pinned as that field was +computed, so the collector sees what has been built so far without a root for +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 @@ -1223,6 +1224,15 @@ A struct or a condition holding a =dyn= carries a descriptor naming the byte offsets the collector must follow, emitted by both backends and by both redefinition emitters. The stopgap refusal on a dyn field in a struct is lifted. +** DONE A dyn read out of a place is rooted while a sibling operand runs +CLOSED: [2026-09-25] +An operand holding a dyn word — a call's or runtime call's argument, a struct, +case or array literal's element — is spilled into a pushed root slot as soon as +it is computed, whenever another operand in the same list does not settle. Same +explicit-slot root stack on both backends and on wasm32; rules out anything that +scans the native stack or registers. See docs/BUILT.md, "Operands held beside a +sibling". + ** DONE A redefined defclass migrates its instances lazily CLOSED: [2026-09-20] CLHS 4.3.6 minus the user hook. Nothing is enumerated and no heap is walked — the diff --git a/docs/BUILT.md b/docs/BUILT.md index 6dfdd95c..40812239 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -7171,3 +7171,63 @@ default x86 and `--llvm`. `programs/dev-rerun.flan` keeps the other half. The `defconst` there is an `f64`, deliberately: the checker folds *integer* constants on the way in, and a folded one is refused by name rather than published, so an `i64` would have pinned the refusal instead of the store. + +## How a dyn value is rooted, and operands held beside a sibling + +The collector in `runtime/flan_dyn.c` is precise and finds its roots by address. `gc_mark_all` reads two things: the +root stack, which is an array of addresses pushed through `flan_dyn_root_push` (a bare dyn word) and +`flan_dyn_root_push_desc` (an aggregate, with the descriptor naming its dyn offsets), and a ring of the last 64 +allocations. It never scans the machine stack or registers. That is what lets the same scheme run on wasm32, where a +program cannot read its own stack: every root is a slot the compiled code told the runtime about. + +What gets a slot is decided once per function by `Emit.root_plan`, and both backends read that one plan rather than +each deriving it. Before this section's change it named three kinds of root: every frame slot whose type holds a dyn +word, the result of every call or runtime call that answers one (spilled into its own slot the instant it returns, +because the callee popped its roots on the way out), and the few non-place expressions whose *address* is handed to +something that can allocate. All the slots are made, zeroed and pushed at entry and popped by count at every exit. + +### Operands held beside a sibling + +A dyn read out of a place is rooted by the place, and only for as long as the place still holds it. In + +``` +(set (.d dst) (pick (.d other) (do (set other (T {.n 0})) (churn)))) +``` + +the first argument is loaded, the second overwrites `other` and allocates, and between the two the only copy of the +first is a register or a scratch temporary that no root names. A collection there freed it: the program printed a +freed block's contents on LLVM, LLVM `-O0`, `--x86` and wasm32 alike, and valgrind showed `gc_mark_all` reading a +block `gc_sweep` had freed. + +The positions that hold a value while more code runs are the ordered operand lists — a call's arguments, a runtime +call's, a struct, case or array literal's fields. Everything else consumes its operand at once: a `let` stores it into +a rooted slot, a `set` into its place (both backends compute the place before the value), a branch tests it, a +`return` hands it back. So `Emit.held_operands` looks only at those lists, and pins an operand when: + +- its type holds a dyn word, as a bare dyn or through a descriptor; +- nothing roots it already — a call's result has its own slot from the rule above; +- some *other* operand in the same list does not settle. + +`Emit.settles` is the closed list of expressions that cannot reach a call, a signal, a check, a store or a return — the +same question the x86 backend asks before building an aggregate in place. A sibling that settles can neither allocate +nor overwrite a place, so a value beside it is safe where it is. Asking about every other operand, not only the later +ones, means the plan does not depend on the order a backend evaluates operands in. + +A pinned operand is spilled into a root slot as soon as it is computed, in `Emit.value` and in `X86.lower`, which is +the same move a call's result gets and uses the same slots. The pinned nodes are keyed by physical identity. The +checker occasionally shares one node between two positions, and a node pinned in one position is then spilled from +both, so the count of slots is taken per visit of a pinned node rather than per position that asked for it — +otherwise the supply runs short and the backends fall back to an unrooted temporary. The acceptance suite's +`%dx`/`%ax` check sees that fallback on LLVM; it caught exactly this during the change. + +The x86 backend's aggregate temporary, which builds a struct literal field by field, needs no root of its own for the +same reason: every dyn word written into it while a sibling field may allocate is also in a pinned slot. + +What it costs is a store per pinned operand and a slot per pin in the entry block. Over `dyn-class.flan`, `dyn-map.flan` +and `edn-read.flan` the emitted root pushes went up by roughly a quarter to a half. Typed code is unaffected: nothing +without a dyn word in it is ever pinned. + +`programs/dyn-held-operand.flan` is the fixture, eight cases on three rows: a call's argument, a struct literal's +field, an array literal's element, a runtime call's argument (dyn `=`), a local overwritten by the sibling, a whole +struct passed by value, a struct nested in a literal, and a call through a function value. Without the pins every +line prints freed memory. diff --git a/lib/emit.ml b/lib/emit.ml index f6af7bbc..53f2de04 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -954,6 +954,10 @@ type f = { within a pool never matters. See [root_plan] for why this is by type and not a single positional list. *) mutable aroot_ns : (string * string list) list; + (* The operands [root_plan] found held beside a sibling that may allocate, + by physical identity. [value] spills each of them into a root slot the + moment it is computed. See [held_operands]. *) + mutable pins : Tast.expr list; (* Where a dev build records each slot's address, so that a stopped frame's locals can be read. [None] in a release build and in a function with no named slot at all. Only *named* slots are recorded: a slot the compiler @@ -1087,6 +1091,93 @@ let label f name = count below is still the number the epilogue takes off; what changed is that the plan has to say, per entry, which kind it is. *) +(* Whether lowering this expression into a destination is bound to reach the + end of it. + + Asked first by the x86 backend. Nothing there holds a value in a register + across a statement, so an aggregate is built *in the destination*: field by field, element by + element, each one stored as it is computed. That is the cheapest thing that + works, and it works right up until the middle of the construction leaves. + A condition signalled while the third of four elements is being computed + transfers out of the assignment with two elements written and two not, and + what is left behind is a variable that is half its old value and half its + new one. The LLVM backend cannot have that shape — it builds the whole + aggregate as one value and stores it once — and where the two disagree, + the x86 one is the one that is wrong. + + So an x86 assignment whose right-hand side might leave part-way builds into a + frame temporary and copies the finished value over in a single block move. + The copy is not free, which is what this question is for: it buys nothing + for [(set grid [1 2 3 4])], where nothing between the first store and the + last can go anywhere at all. + + The answer is yes only for shapes spelled out below, none of which can + reach a call, a signal, a bounds or arithmetic check, or a return. Anything + else answers no and pays for the copy — a node added to the IR later + included, since being wrong this way costs a block copy and being wrong the + other way costs a corrupted variable. + + [root_plan] asks the same question for a different reason: a sibling + operand that settles can neither allocate nor overwrite a place, so a dyn + value held beside it needs no root of its own. See [held_operands]. *) +let settled_prim (p : Tast.prim) = + match p with + (* Arithmetic that cannot fail. Division and remainder are absent on + purpose: both are checked, and a check signals. *) + | Tast.Add | Tast.Sub | Tast.Mul + | Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge | Tast.Not + | Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr + (* Questions about a value's shape, answered from the layout tables. *) + | Tast.Len | Tast.SizeOf _ | Tast.AlignOf _ | Tast.AddrOf -> true + (* Everything else reaches C, signals, or both: an index and a slice are + bounds-checked and [Rt] is a call by definition. [Cast] is not here + because it is only sometimes checked; see [cast_checks]. *) + | _ -> false + +(* Which conversions can signal, and it is one of them. [cvttsd2si] answers a + fixed "integer indefinite" for a value out of range, which is a number + rather than an answer, so a float narrowed to an integer is tested against + the destination's range first and the failure signals ArithError — see + [cast], which is where the test is emitted. Every other conversion is a + move, a widen or one SSE instruction, and cannot go anywhere. That matters + here because an array of the language's own literals is usually written + [(u32 1)] and not [1], and refusing every cast would have made the most + ordinary aggregate literal there is pay for a copy. *) +let cast_checks (src : Types.t) (target : Types.t) = + let concrete (t : Types.t) = + match t with Types.Enum _ -> Types.Int Types.I32 | t -> t + in + match concrete src, concrete target with + | Types.Float _, Types.Int _ -> true + | _ -> false + +let rec settles (e : Tast.expr) = + match e.Tast.e with + (* Values with no code in them to leave from. *) + | Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit + | Tast.Zero _ | Tast.Uninit _ | Tast.Local _ | Tast.Global _ | Tast.None_ + | Tast.FnAddr _ -> true + (* Building an aggregate, and running a sequence: as settled as the parts. *) + | Tast.Make (_, es) | Tast.MakeCase (_, _, es) | Tast.Arr es | Tast.Do es -> + List.for_all settles es + | Tast.Some_ x | Tast.Field (x, _) | Tast.CaseField (x, _, _) + | Tast.Deref x -> settles x + | Tast.If (c, a, b) -> settles c && settles a && settles b + | Tast.Addr p -> settles_place p + | Tast.Prim (Tast.Cast target, [ a ]) -> + (not (cast_checks a.Tast.ty target)) && settles a + | Tast.Prim (p, es) -> settled_prim p && List.for_all settles es + (* A call, a signal, an invoke, an unwrap that returns early, a loop, a + [return], a [break] — and anything this list has not heard of. *) + | _ -> false + +and settles_place (p : Tast.place) = + match p with + | Tast.Plocal _ | Tast.Pglobal _ -> true + | Tast.Pfield (x, _) | Tast.Pderef x -> settles x + (* An index is bounds-checked, and the check signals. *) + | Tast.Pindex _ -> false + (* Which expressions [addr] can answer without copying. Shared with [addr] itself rather than repeated, because the counter below has to make exactly the same call: a place has an address already and needs no root, and @@ -1122,8 +1213,66 @@ type rootplan = { rslots : (int * Types.t) list; (* slot index and its type, in slot order *) rdyn : int; ragg : Types.t list; (* sorted, with multiplicity *) + rpins : Tast.expr list; (* see [held_operands] *) } +(* The operands whose value is held while one of their siblings runs, and which + therefore need a root of their own from the moment they are computed. + + A dyn read out of a place — a local, a global, a field — is rooted only by + the place, and only for as long as the place still holds it. In + [(pick (.d other) (do (set other ...) (churn)))] the first argument is + loaded, the second overwrites [other] and allocates, and between the two + the only copy of the first is a register or a temporary no root points at, + so a collection there frees it. Nothing about the place was wrong; what was + missing is a root for the value between being produced and being consumed. + + The positions that hold a value while more code runs are the ordered + operand lists: a call's arguments, a runtime call's, a struct, case or + array literal's fields. Every other position consumes its operand at once + — a [let] stores it into a rooted slot, a [set] into its place (both + backends compute the place first), a branch tests it, a [return] hands it + back — so these lists are the whole of it. + + An operand is pinned when its type holds a dyn word, when nothing already + roots it — a call's result and a dyn-producing runtime call's are spilled + into their own slot where they are made — and when some *other* operand in + the same list does not settle. A sibling that settles cannot allocate and + cannot write a place, so a value beside it is safe where it is. Any other + sibling, before or after, counts: which order the operands run in is then + not a question this plan has to agree with a backend about. + + The node itself is the key, by physical identity, and the backends spill + its value after computing it — [value] in this file, [lower] in the other — + exactly as they spill a call's result. An array argument to a runtime call + is not a candidate: it crosses by address, which the x86 backend takes + without lowering it and this file takes by way of [value] only when it is + not a place, so pinning it would draw a slot on one backend and not the + other. *) +let held_operands m (e : Tast.expr) : Tast.expr list = + let holds (x : Tast.expr) = + (x.Tast.ty = Types.Dyn || dyn_offsets m x.Tast.ty <> []) + && (match x.Tast.e with + | Tast.Call _ | Tast.CallPtr _ -> false + | Tast.Prim (Tast.Rt _, _) -> x.Tast.ty <> Types.Dyn + | Tast.Zero _ | Tast.Uninit _ | Tast.None_ | Tast.Unit -> false + | _ -> true) + in + let pick ?(by_addr = false) siblings candidates = + List.filter + (fun (x : Tast.expr) -> + holds x + && (not (by_addr && (match x.Tast.ty with Types.Array _ -> true | _ -> false))) + && List.exists (fun s -> s != x && not (settles s)) siblings) + candidates + in + match e.Tast.e with + | Tast.Prim (Tast.Rt _, es) -> pick ~by_addr:true es es + | Tast.Call (_, es) | Tast.Make (_, es) | Tast.MakeCase (_, _, es) + | Tast.Arr es -> pick es es + | Tast.CallPtr (c, es) -> pick (c :: es) es + | _ -> [] + let root_plan m (fn : Tast.fn) : rootplan = let rslots = ref [] in Array.iteri @@ -1133,7 +1282,24 @@ let root_plan m (fn : Tast.fn) : rootplan = fn.Tast.slots; let dyn = ref 0 and agg = ref [] in let want (t : Types.t) = t <> Types.Dyn && dyn_offsets 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 + spilled in every position it is emitted from. The count below is + therefore taken per visit of a pinned node, which is per emission, and + not per position that asked for the pin. *) + let pins = ref [] in + let collect (e : Tast.expr) = + List.iter + (fun x -> if not (List.memq x !pins) then pins := x :: !pins) + (held_operands m e) + in + List.iter (Tast.walk collect) fn.Tast.body; + List.iter (Tast.walk collect) fn.Tast.fdefers; let count (e : Tast.expr) = + if !pins <> [] && List.memq e !pins then begin + if e.Tast.ty = Types.Dyn then incr dyn else agg := e.Tast.ty :: !agg + end; match e.Tast.e with | Tast.Prim (Tast.Rt _, _) when e.Tast.ty = Types.Dyn -> incr dyn (* A Flan call answering a dyn, which wants the same slot a dyn-producing @@ -1177,7 +1343,8 @@ let root_plan m (fn : Tast.fn) : rootplan = asm listing and an IR listing put the same value at the same depth. *) ragg = List.sort (fun a b -> String.compare (Types.to_string a) (Types.to_string b)) - !agg } + !agg; + rpins = !pins } let dyn_roots m (fn : Tast.fn) = let p = root_plan m fn in @@ -1752,14 +1919,25 @@ let fcmp_op = function a child -- the branch at the end of an [if], the store of a [set] -- are attributed to the parent and not to whatever ran last inside it. *) let rec value f (e : Tast.expr) : string = - match f.dsub with - | None -> value_at f e - | Some _ -> - let saved = f.dloc in - at_loc f e.Tast.loc; - let v = value_at f e in - f.dloc <- saved; - v + let v = + match f.dsub with + | None -> value_at f e + | Some _ -> + let saved = f.dloc in + at_loc f e.Tast.loc; + let v = value_at f e in + f.dloc <- saved; + v + in + (* An operand held while a sibling may allocate: spilled into a root slot the + instant it exists, the same move a call's result gets in [call_through]. + The value carries on being used as a register; the store is what the + collector reads. *) + if f.pins <> [] && List.memq e f.pins then begin + if e.Tast.ty = Types.Dyn then ins f "store i64 %s, ptr %s" v (dyn_tmp f) + else ins f "store %s %s, ptr %s" (ll e.Tast.ty) v (agg_tmp f e.Tast.ty) + end; + v (* The [!DILocation] for a position, memoised: a loop body emits the same few lines over and over and each would otherwise make its own node. *) @@ -3320,7 +3498,7 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = pads = []; loops = []; unwind = "unwind"; unwound = false; defers = fn.Tast.fdefers; frame = None; slotv = None; snames = fn.Tast.snames; - droots = 0; droot_ns = []; aroot_ns = []; + droots = 0; droot_ns = []; aroot_ns = []; pins = []; dsub; dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line); dloc = ""; @@ -3432,6 +3610,7 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = List.iter (fun (ty, n) -> push n ty) atemps; f.droots <- nroots; f.droot_ns <- dtemps; + f.pins <- plan.rpins; f.aroot_ns <- List.fold_left (fun acc (ty, n) -> diff --git a/lib/x86.ml b/lib/x86.ml index b01553ff..dd9881a2 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -708,6 +708,10 @@ type fnctx = { type is interchangeable, so a supply that drifted from the emission can only run out and never pair an address with another type's descriptor. *) mutable aroot_ns : (string * int list) list; + (* [emit.ml]'s [pins]: the operands [Emit.root_plan] found held beside a + sibling that may allocate, spilled by [lower] into a root slot as soon as + each is computed. *) + mutable pins : Tast.expr list; (* [fn.snames], carried so [bind_slot] can ask whether a slot has a name to show without the whole [Tast.fn] being threaded to every binding site. *) snames : string option array; @@ -1594,88 +1598,8 @@ let emit_args f (args : arg list) = point is that the store has somewhere legal to go. *) let sink = Lf 0 -(* Whether lowering this expression into a destination is bound to reach the - end of it. - - Nothing in this backend holds a value in a register across a statement, so - an aggregate is built *in the destination*: field by field, element by - element, each one stored as it is computed. That is the cheapest thing that - works, and it works right up until the middle of the construction leaves. - A condition signalled while the third of four elements is being computed - transfers out of the assignment with two elements written and two not, and - what is left behind is a variable that is half its old value and half its - new one. The LLVM backend cannot have that shape — it builds the whole - aggregate as one value and stores it once — and where the two disagree, - this one is the one that is wrong. - - So an assignment whose right-hand side might leave part-way builds into a - frame temporary and copies the finished value over in a single block move. - The copy is not free, which is what this question is for: it buys nothing - for [(set grid [1 2 3 4])], where nothing between the first store and the - last can go anywhere at all. - - The answer is yes only for shapes spelled out below, none of which can - reach a call, a signal, a bounds or arithmetic check, or a return. Anything - else answers no and pays for the copy — a node added to the IR later - included, since being wrong this way costs a block copy and being wrong the - other way costs a corrupted variable. *) -let settled_prim (p : Tast.prim) = - match p with - (* Arithmetic that cannot fail. Division and remainder are absent on - purpose: both are checked, and a check signals. *) - | Tast.Add | Tast.Sub | Tast.Mul - | Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge | Tast.Not - | Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr - (* Questions about a value's shape, answered from the layout tables. *) - | Tast.Len | Tast.SizeOf _ | Tast.AlignOf _ | Tast.AddrOf -> true - (* Everything else reaches C, signals, or both: an index and a slice are - bounds-checked and [Rt] is a call by definition. [Cast] is not here - because it is only sometimes checked; see [cast_checks]. *) - | _ -> false - -(* Which conversions can signal, and it is one of them. [cvttsd2si] answers a - fixed "integer indefinite" for a value out of range, which is a number - rather than an answer, so a float narrowed to an integer is tested against - the destination's range first and the failure signals ArithError — see - [cast], which is where the test is emitted. Every other conversion is a - move, a widen or one SSE instruction, and cannot go anywhere. That matters - here because an array of the language's own literals is usually written - [(u32 1)] and not [1], and refusing every cast would have made the most - ordinary aggregate literal there is pay for a copy. *) -let cast_checks (src : Types.t) (target : Types.t) = - let concrete (t : Types.t) = - match t with Types.Enum _ -> Types.Int Types.I32 | t -> t - in - match concrete src, concrete target with - | Types.Float _, Types.Int _ -> true - | _ -> false - -let rec settles (e : Tast.expr) = - match e.Tast.e with - (* Values with no code in them to leave from. *) - | Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit - | Tast.Zero _ | Tast.Uninit _ | Tast.Local _ | Tast.Global _ | Tast.None_ - | Tast.FnAddr _ -> true - (* Building an aggregate, and running a sequence: as settled as the parts. *) - | Tast.Make (_, es) | Tast.MakeCase (_, _, es) | Tast.Arr es | Tast.Do es -> - List.for_all settles es - | Tast.Some_ x | Tast.Field (x, _) | Tast.CaseField (x, _, _) - | Tast.Deref x -> settles x - | Tast.If (c, a, b) -> settles c && settles a && settles b - | Tast.Addr p -> settles_place p - | Tast.Prim (Tast.Cast target, [ a ]) -> - (not (cast_checks a.Tast.ty target)) && settles a - | Tast.Prim (p, es) -> settled_prim p && List.for_all settles es - (* A call, a signal, an invoke, an unwrap that returns early, a loop, a - [return], a [break] — and anything this list has not heard of. *) - | _ -> false - -and settles_place (p : Tast.place) = - match p with - | Tast.Plocal _ | Tast.Pglobal _ -> true - | Tast.Pfield (x, _) | Tast.Pderef x -> settles x - (* An index is bounds-checked, and the check signals. *) - | Tast.Pindex _ -> false +(* [Emit.settles], whose comment gives this backend's reason for asking. *) +let settles = Emit.settles let rec lower f (e : Tast.expr) (dst : loc) : unit = (* The one hook the line table needs, and it is here rather than at @@ -1688,7 +1612,7 @@ let rec lower f (e : Tast.expr) (dst : loc) : unit = scoped f (fun () -> let o = tmp f e.Tast.ty in lower f e (Lf o)) - else if not f.ann then lower_at f e dst + else if not f.ann then (lower_at f e dst; pin f e dst) else begin (* The second hook, and it hangs off the same recursion for the same reason: a heading queued here spans exactly the bytes this form and @@ -1703,6 +1627,7 @@ let rec lower f (e : Tast.expr) (dst : loc) : unit = let s = annot f e in f.adepth <- d + 1; lower_at f e dst; + pin f e dst; f.adepth <- d; set_ind f.b ind; match s with @@ -1710,6 +1635,16 @@ let rec lower f (e : Tast.expr) (dst : loc) : unit = | None -> () end +(* An operand held while a sibling may allocate, copied into a root slot the + moment it has been lowered — [Emit.held_operands] for which ones and why. + [dst] is not enough: it is usually a [scoped] temporary, or a field of an + aggregate being built in one, and never a slot anything was pushed for. *) +and pin f (e : Tast.expr) (dst : loc) = + if f.pins <> [] && List.memq e f.pins then begin + let o = if e.Tast.ty = Types.Dyn then dyn_tmp f else agg_tmp f e.Tast.ty in + move f ~dst:(Lf o) ~src:dst e.Tast.ty + end + and lower_at f (e : Tast.expr) (dst : loc) : unit = let t = e.Tast.ty in match e.Tast.e with @@ -3654,7 +3589,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) { b; md; fnname = fn.Tast.name; retlbl = ""; fret = fn.Tast.ret; slots = Array.make nslots 0; xfer_off = 0; sret_off = 0; retval = 0; - dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = []; + dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = []; pins = []; snames = fn.Tast.snames; frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = []; xfer_lbl = ""; unwound = false; @@ -3769,6 +3704,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false) droot_zero := zeros @ List.map (fun o -> (o, Types.Dyn)) dtemps @ atemps; f.droots <- nroots; f.droot_ns <- dtemps; + f.pins <- plan.Emit.rpins; f.aroot_ns <- List.fold_left (fun acc (o, ty) -> @@ -4372,7 +4308,7 @@ let emit_globals_init ?(cfi = false) ?(ann = false) ?body ~sym (md : Emit.m) ~ex let f = { b; md; fnname = ""; retlbl = new_label () "ginit"; fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0; - dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = []; + dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = []; pins = []; snames = [||]; frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = []; xfer_lbl = ""; unwound = false; @@ -5068,7 +5004,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) let f = { b = ib; md; fnname = ""; retlbl = new_label () "install"; fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0; - dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = []; + dframe = None; dslotv = None; droots = 0; droot_ns = []; aroot_ns = []; pins = []; snames = [||]; frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = []; xfer_lbl = ""; unwound = false; diff --git a/test/programs/dyn-held-operand.flan b/test/programs/dyn-held-operand.flan new file mode 100644 index 00000000..981baf34 --- /dev/null +++ b/test/programs/dyn-held-operand.flan @@ -0,0 +1,90 @@ +;;;; A dyn value read out of a place, held while a sibling operand runs. +;;;; +;;;; Every line below reads the vector in [other] into an operand position — +;;;; a call's argument, a struct literal's field, an array literal's element, +;;;; a runtime call's argument, a function value's argument — and then runs a +;;;; sibling that overwrites [other] and allocates enough to collect. Once +;;;; [other] is overwritten, the only reference to the vector is the operand +;;;; being held, so unless that operand has a root of its own the collection +;;;; frees it and the line prints whatever the freed block holds next. +;;;; +;;;; [churn] ends in an explicit collection, so each line is tested against a +;;;; collection that certainly ran and not against the trigger's timing. + +(defstruct T [d dyn n i64]) +(defstruct W [t T k i64]) +(declare gc-collect [] () "flan_gc_collect") + +(defonce other T) +(defonce dst T) +(defonce pair [2 dyn]) +(defonce w W) + +(defn churn [] i64 + (let [i 0] + (while (< i 2000) + (let [v (vec-new dyn)] (push v i) (push v "junk")) + (set i (+ i 1))) + (gc-collect) + 7)) + +(defn kept [] dyn + (let [v (vec-new dyn)] (push v "kept") (push v 42) v)) + +;;; A fresh vector in [other], old enough that it is no longer among the +;;; collector's most recent allocations. +(defn fill [] () (set (.d other) (kept)) (churn)) + +;;; Overwrite [other], then allocate and collect. +(defn clobber [] i64 (set other (T {.n 0})) (churn)) +(defn clobber-dyn [] dyn (clobber) (vec-new dyn)) + +(defn pick [x dyn n i64] dyn x) +(defn pick-t [t T n i64] dyn (.d t)) + +(defn show [label string v dyn] () + (churn) + (println label (at v 0) (at v 1))) + +(defn main [] () + ;; A call's argument. + (fill) + (set (.d dst) (pick (.d other) (clobber))) + (show "call:" (.d dst)) + + ;; A struct literal's field. + (fill) + (set dst (T {.d (.d other) .n (clobber)})) + (show "struct:" (.d dst)) + + ;; An array literal's element. + (fill) + (set pair [(.d other) (clobber-dyn)]) + (show "array:" (at pair 0)) + + ;; A runtime call's argument: dyn equality is a call into the runtime, and + ;; its first operand is held while the second is computed. + (fill) + (println "runtime:" (= (.d other) (do (clobber) (kept)))) + + ;; A local, overwritten by the sibling rather than a global. + (fill) + (let [x (.d other)] + (set (.d dst) (pick x (do (set x 0) (clobber)))) + (show "local:" (.d dst))) + + ;; A whole struct with a dyn field in it, passed by value. + (fill) + (set (.d dst) (pick-t other (clobber))) + (show "aggregate:" (.d dst)) + + ;; The same struct as a field of a struct literal. + (fill) + (set w (W {.t other .k (clobber)})) + (show "nested:" (.d (.t w))) + + ;; Through a function value. + (fill) + (let [g pick] + (set (.d dst) (g (.d other) (clobber))) + (show "fn value:" (.d dst)))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 58a8cf4e..143633f5 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -4437,6 +4437,24 @@ level "1" "programs/dyn-struct.flan" dyn_struct_out; outputs ~x86:true "dyn: a struct with dyn fields, under collection, --x86" "programs/dyn-struct.flan" dyn_struct_out; + (* A dyn read out of a place and held in an operand position while a + sibling overwrites the place and collects: a call's argument, a struct + and an array literal's element, a runtime call's argument, a local, a + whole struct passed by value, a struct nested in a literal, and a call + through a function value. [Emit.held_operands] roots each of them. With + that function answering nothing, every line comes out as a freed + block's contents and the runtime line as false, on all three rows. *) + let dyn_held_out = + "call: kept 42\nstruct: kept 42\narray: kept 42\nruntime: true\n\ + local: kept 42\naggregate: kept 42\nnested: kept 42\n\ + fn value: kept 42\n" + in + outputs "dyn: an operand held while a sibling collects" + "programs/dyn-held-operand.flan" dyn_held_out; + outputs ~opt:"-O0" "dyn: an operand held while a sibling collects, -O0" + "programs/dyn-held-operand.flan" dyn_held_out; + outputs ~x86:true "dyn: an operand held while a sibling collects, --x86" + "programs/dyn-held-operand.flan" dyn_held_out; (* Two struct spellings the checker decides: a bare {.field v} typed by the position it stands in, and (Cell 1 2) positional. Three rows because that is the house rule, not because the backends could differ @@ -4845,6 +4863,7 @@ level "1" "programs/dyn-struct.flan"; "programs/dyn-global.flan"; "programs/dyn-boundary.flan"; "programs/dyn-defer.flan"; "programs/dyn-view.flan"; + "programs/dyn-held-operand.flan"; (* Included for the same reason every dyn program is, though this check cannot see the slot M2 item 4 actually added: [%dx]/[%ax] are the pool-ran-dry fallback for a temporary [root_plan] COUNTED