diff --git a/BUILT.md b/BUILT.md index 42a597b..5a864a9 100644 --- a/BUILT.md +++ b/BUILT.md @@ -1150,23 +1150,81 @@ belonging to the program is not. **Refused while the program is running**, like every other break verb. The chain is the game thread's and it is pushed and popped on every call; a walk of it from the daemon would have the shape of a backtrace and the contents of a race. -**What it costs, measured rather than assumed.** Three compilers built, three pairs of binaries, timed interleaved so -that machine load falls on all of them: +**What it costs, measured rather than assumed.** Two benchmarks, one compiler built per variant, every binary kept and +then run alternately. The figure is the **minimum of nine runs**, because this machine is shared and a mean measures +whatever else was running; the whole table reproduces to three digits on a second pass. -| Dev build, -O2 | without frames | with | -|---|---|---| -| 600 frames of sand's simulation | 64.9 ms | 84.0 ms (+29%) | -| fib(30) plus 20M calls in a loop | 90.6 ms | 97.5 ms (+7.6%) | +| Dev build, -O2 | no frames | frames | frames + slots | +|---|---|---|---| +| 2000 sweeps of a 100×100 grid — sand's inner loop, in miniature | 30.0 ms | 40.0 ms (+33%) | 48.3 ms (+61%) | +| fib(30) plus 20M calls in a loop — nothing but calls | 28.7 ms | 31.1 ms (+8%) | 35.1 ms (+22%) | -That is **32 µs per frame of sand**, or 0.19% of a 16.6 ms frame at 60fps, and about 0.3 ns per call. The dev loop's -premise is that redefinition does not stutter a running game, and a fifth of a percent of a frame does not. +Per call that is about **0.1 ns** for the frame and **0.3 ns** for the frame and the slot table together; per sweep of +the grid, 5 µs and 10 µs, which is 0.03% and 0.06% of a 16.6 ms frame at 60fps. The dev loop's premise is that +redefinition does not stutter a running game, and a sixteenth of a percent of a frame does not. A dev build is already +deliberately slower than a release one — every call goes through a cell, every index is checked, no `defconst` folds — +and this joins that list rather than starting a new one. -The shape was chosen by that measurement and not before it. An array with a stack pointer — no alloca, no address -escaping — was built and timed as the obvious alternative, and it is *worse* on both benchmarks (sand +34%, fib +27%): -the frame record on the stack is already hot, and the array's indexed store into a megabyte of BSS is not. It also has -a fixed depth, which the chain does not. One measurement in between said the opposite, loudly, and was an artefact of -comparing a 40-frame binary with a 600-frame one — which is why all six numbers above come from binaries built in one -sitting and run alternately. +The chain's *shape* was chosen by measurement and not before it. An array with a stack pointer — no alloca, no address +escaping — was built and timed as the obvious alternative and is worse on both benchmarks: the frame record on the +calling function's own stack is already hot, and an indexed store into a megabyte of BSS is not. It also has a fixed +depth, which a chain of stack records does not. + +### Locals of a stopped frame + +The half the shadow stack was built for. `(:op "locals" :frame N)` answers what a stopped frame's named locals hold. + +``` +(:op "locals" :frame 0) → (:status "ok" :frame "look" + :locals (("n" "i64" "3") ("label" "string" "\"hello\"") + ("p" "Point" "(Point {:x 1.5 :y 2.5})") + ("xs" "[3 i32]" "[ 10 20 30]") ("flag" "bool" "true")) + :refused (("after" "not bound yet at the point the program stopped"))) +``` + +**Nothing is copied out of the program, and nothing could be.** A Flan value carries no header, so bytes read from +another process would be bytes with no meaning. What the daemon has instead is the *type* — `Tast.fn.slots`, from the +build it owns — and the name beside it in `snames`, which was already there for the DWARF work. So it compiles a thunk +that renders those types **at those addresses, in the program**, on the stopped thread, and reads the text back through +the same seqlocked result buffer `C-x C-e` uses. The only fact that comes from the running program is where the frame +is. That is `render.ml`'s existing walk with its root changed: `Render.render` over `(Deref (Ptr T) (flan/dev-slot f +i))` instead of over an expression — the **pointer-rooted render thunk** NEXT.md said locals needed, and it turned out +to need one new arm in the whole backend (a pointer-to-pointer cast, which under opaque pointers emits nothing). + +**A slot's entry is its address, and null until it is bound.** That is the whole of the liveness answer: there is no +analysis, no PC-to-scope map and no bitmap. The store that binds a slot stores the address, so a slot the program has +not reached yet reads as null and is refused by name. Without it, `(let [after 99] …)` sitting past an `error` would +render whatever the stack held, and a slice or a struct of garbage does not misprint — it faults, on the game thread of +a program that is already stopped, which is the worst moment this project has to offer. The daemon asks the program +which slots are bound *before* it builds the thunk, so the set it emits code for is the set the thunk will resolve. + +**Only named slots are recorded**, and this is where most of the cost went. A slot whose address is stored anywhere +escapes, and an escaped alloca is one `mem2reg` cannot promote — so recording a slot is paying for it in every call to +that function, for ever. The slots that would hurt most are exactly the ones with nothing to show: `dotimes`'s hidden +bound, the temporaries `(min)` and `(max)` evaluate their operands into, the render walk's own scratch. They keep their +promotion and are refused by name (`s4`, "a slot the compiler made up") rather than shown under an invented one. +Recording every slot instead was built and timed and came out inside the noise on both benchmarks, so the rule stands +on what it shows rather than on what it saves. + +**Shadowing is right here, and that is not an accident of this design — it is the thing the DWARF route still owes.** +`check.ml`'s `fresh_slot` only ever allocates, so `(let [v 22] …)` inside `(let [v 11] …)` is two slots, both named +`v`, and both appear with their own values. lldb answers `p v` with 11 in that program and will until a +`!DILexicalBlock` per `Let` exists. + +**Four refusals, each by name and with its reason.** Three per slot — invented, not yet bound, and no printer for the +type (a map, a function value, a type variable; the arm exists, no program the checker accepts has reached it yet, so +it is written and untested) — and two whole frames: one belonging to a `C-x C-e` thunk, whose `Tast` the session does +not keep, and one whose slot count does not match the body this session holds, which is a frame running a body that has +been redefined since and where every slot index would be a guess. + +**A `(Vec T)` shows as `` and a `(Ptr T)` as ``**, because that is what `render.ml` already does for them +everywhere else: following a pointer a REPL was handed is not a safe thing to do on someone's behalf, and walking a +`Vec` structurally is a walk over storage the frame does not own — `(print (as-slice v))` is how that is asked for, +and it says at the call site that it borrowed. + +Each slot is rendered **from its address** rather than copied into the thunk first. A copy would be one `alloca` the +size of the slot — 40KB for sand's grid — and the walk only ever shows eight elements of it. The cost is one call to +`flan/dev-slot` per leaf the walk reaches rather than one per slot, which the depth and span caps already bound. ### Conditions — step 2: `restart-case` and `invoke-restart` diff --git a/NEXT.md b/NEXT.md index 69f7e7e..3e31d9b 100644 --- a/NEXT.md +++ b/NEXT.md @@ -247,7 +247,11 @@ it is how a save file disappears with nothing said. So `barf` on web signals a c program decides. This is the language having something Odin does not; use it. Per-package target isolation, if a whole desktop-only package is ever wanted, is the `@native`/`@wasi`/`@web` link-line tagging the web lane built. -**3. Build the shadow stack.** plan.org:591 has specified it in the dev-build column since the beginning and nothing +**3. Build the shadow stack.** ~~Not yet built.~~ **Built**, both halves — see BUILT.md. Kept here as the decision it +was, with the measurement it asked for: +33% on call-heavy code over globals for the frames, +61% with the slot table, +and 0.06% of a 60fps frame. + +plan.org:591 has specified it in the dev-build column since the beginning and nothing has ever built it. It is the route to `(:op "backtrace")` *and* to locals, together, and it is dev-only so a shipped game pays nothing. Chosen over the DWARF route deliberately: DWARF still owes a `!DILexicalBlock` per `Let` before `p v` under shadowing is even honest, and that buys locals in lldb rather than in the break loop. The author's reason @@ -682,7 +686,10 @@ sanitized sweep (`@sanitize`) is under the same watchdog but has never been obse - **`(:op "condition")` → the stopped program's condition, rendered.** Two steps: `break_loop` currently does `(void)condition;` and *discards the pointer*, so stash it beside `condition_name`; then the daemon builds a render - thunk aimed at that address, which is `Session.render` rooted at a `Ptr` instead of an expression. + thunk aimed at that address, which is `Session.render` rooted at a `Ptr` instead of an expression. **The second step + now exists** — `Session.render_locals` is exactly that thunk, rooted at an address the program supplies — so what is + left is the first: keep the pointer, and give the agent a verb that hands it back. The type is already known: it is + the `condition_name` the break loop reports, which `layout` already resolves. - **The type identity is settled, and it is the qualified name** — `layout` is in, see BUILT.md. `Load` qualifies every declaration at import, so the names in `Tast.structs` are a flat namespace where two packages' `Missing` are `a/Missing` and `b/Missing`; a bare name is refused with the candidates rather than resolved. `condition` inherits @@ -691,9 +698,9 @@ sanitized sweep (`@sanitize`) is under the same watchdog but has never been obse reads is not qualified by anything. - ~~**`(:op "backtrace")` is blocked** on frame metadata.~~ **Built**, and not out of DWARF: decision 3's shadow stack carries the name and the location on the frame itself, so a backtrace needs no debug information at all. See - BUILT.md, "The shadow stack, and `backtrace`", for what it costs — 0.19% of a 60fps frame. Locals are no longer - blocked on a frame layout either; what is left of them is the pointer-rooted render thunk. Restart source locations - and arity are still blocked — `flan_restart` carries `prev`, `name_id`, `name` and `namelen`, so both need a new + BUILT.md, "The shadow stack, and `backtrace`", for what it costs. **Locals landed with it** — the pointer-rooted + render thunk turned out to be `Render.render` over a `Deref` of a slot's address, and one new arm in the backend. + See "Locals of a stopped frame" for the four things it refuses. Restart source locations and arity are still blocked — `flan_restart` carries `prev`, `name_id`, `name` and `namelen`, so both need a new field in the frame, which means the compiler emitting it. ### One line away diff --git a/lib/dev.ml b/lib/dev.ml index 20ce419..0f2be53 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -280,6 +280,30 @@ let backtrace t = end | exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e) +(* Which of a frame's slots have been reached. One line per slot, [I ±], the + same framing as everything else the agent answers. + + Asked before a thunk is built rather than after: an unbound slot is a null + address, and a thunk that rendered one would take a fault on the game + thread of a program that is already stopped — which is the one place a + crash costs the most, because it is where someone is standing over the + wreck deciding what to do about it. *) +let bound_slots t ~frame = + match ask t (Printf.sprintf "locals %d" frame) with + | text -> + let lines = List.map String.trim (String.split_on_char '\n' text) in + if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines + then Error (String.trim text) + else + Ok + (List.filter_map + (fun l -> + match String.split_on_char ' ' l with + | [ i; "+" ] -> int_of_string_opt i + | _ -> None) + (List.filter (fun l -> l <> "" && l <> ".") lines)) + | exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e) + let alive t = match Unix.waitpid [ Unix.WNOHANG ] t.child with | 0, _ -> true @@ -685,6 +709,131 @@ let backtrace_op t = Printf.sprintf ":more %d" more ] | Error m -> error ("the program refused to say where it is: " ^ m)) +(* [(:op "locals" :frame N)] — what a stopped frame's named locals hold. + + The half of a break loop that the author actually wanted, and the reason + the shadow stack was built rather than more DWARF: DWARF would have put + these in lldb, and the point is to need lldb less often. + + Nothing is copied out of the program. A Flan value has no header, so bytes + read from another process would be bytes with no meaning; what this end has + is the *type* — [Tast.fn.slots], from the build it owns — and the name + beside it in [snames]. So it compiles a thunk that renders those types at + those addresses, in the program, on the stopped thread, and reads the text + back the way [C-x C-e] does. The only thing that comes from the running + program is where the frame is. + + Three refusals, each by name and with its reason rather than by omission: + a slot the compiler invented and nobody named; a slot whose binding had not + run when the program stopped, which is a null address and would be a fault; + and a type the structural printer has no arm for. A local that is missing + and a local that could not be printed are different facts, and a list that + showed neither would be the same lie twice. + + And two whole frames it refuses: one belonging to a [C-x C-e] thunk, which + this session does not keep the [Tast] of, and one whose slot count does not + match the body this session holds — which is a frame running a body that + has since been redefined, where every slot index would be a guess. *) +let locals t ~frame = + if not (alive t) then error "the program exited; restart flan dev" + else + match state t with + | Running -> + error + "the program is running; locals are read from a stopped frame, and \ + nothing in a frame that is still executing holds still" + | Unreachable m -> error ("cannot ask the program for its locals: " ^ m) + | Stopped _ -> + (match backtrace t with + | Error m -> error ("the program refused to say where it is: " ^ m) + | Ok (frames, _) -> + (match List.nth_opt frames frame with + | None -> + error + (Printf.sprintf "there is no frame %d; the backtrace has %d" frame + (List.length frames)) + | Some (name, _, mine, nslots) -> + if not mine then + error + (name + ^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called") + else + match find_fn t name with + | None -> + error + (name + ^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from") + | Some fn -> + if nslots = 0 then + ok + [ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()"; + ":note " + ^ Wire.quote + "that frame records no slots; every slot in it is one the compiler made up" ] + else if nslots <> Array.length fn.Tast.slots then + error + (Printf.sprintf + "%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess" + name nslots name (Array.length fn.Tast.slots)) + else + match bound_slots t ~frame with + | Error m -> error ("the program refused to say which slots are bound: " ^ m) + | Ok bound -> + let c, refused = Session.render_locals t.session ~frame ~fn ~bound in + let before = match result t with Some (g, _) -> g | None -> 0L in + t.n <- t.n + 1; + let out = Filename.concat t.dir (Printf.sprintf "l%d.so" t.n) in + (match Build.shared + ~opts:{ Build.default with Build.dev = true; + Build.debug = t.session.Session.debug } + ~ir:c.Session.ir ~out () with + | _ -> + (match deliver t out with + | "ok" -> + let rec wait ms = + match result t with + | Some (g, v) when Int64.compare g before > 0 -> Some v + | _ when ms <= 0 -> None + | _ -> + ignore (Unix.select [] [] [] 0.005); + if alive t then wait (ms - 5) else None + in + (match wait 5000 with + | Some v -> + (* One line per slot, name and type and value, + tab separated — safe because every string the + renderer emits is escaped. *) + let entries = + List.filter_map + (fun line -> + match String.split_on_char '\t' line with + | [ n; ty; value ] -> + Some + (Wire.list + [ Wire.quote n; Wire.quote ty; + Wire.quote value ]) + | _ -> None) + (String.split_on_char '\n' v) + in + ok + [ ":frame " ^ Wire.quote name; + ":locals " ^ Wire.list entries; + ":refused " + ^ Wire.list + (List.map + (fun (n, why) -> + Wire.list + [ Wire.quote n; Wire.quote why ]) + refused) ] + | None -> + error + "the program did not reach a frame boundary; is \ + it calling (agent/poll)?") + | reply -> error ("the program refused the module: " ^ reply) + | exception Unix.Unix_error (e, _, _) -> + error ("cannot reach the program: " ^ Unix.error_message e)) + | exception Failure m -> error m))) + (* A choice is validated by the *program*, on its listener thread, against a stack the stopped game thread is holding still — not here. The daemon has no copy of that stack and anything it checked would be a guess that was true a @@ -1074,6 +1223,8 @@ let handle t req = | Some "defs" -> defs t | Some "break" -> break t | Some "backtrace" -> backtrace_op t + | Some "locals" -> + locals t ~frame:(match Wire.int_field req "frame" with Some n -> n | None -> 0) | Some "layout" -> (match Wire.string_field req "type" with | Some ty -> layout t ~ty diff --git a/lib/emit.ml b/lib/emit.ml index cb3246c..2cc0f96 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -414,6 +414,16 @@ type f = { what makes the pop happen on the transfer path as well as the normal one. [None] in a release build, where there is no frame at all. *) mutable frame : string option; + (* 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 + invented has no name to show, and leaving its alloca unrecorded leaves it + promotable, which is where most of the cost of this would otherwise be. + An entry is null until the binding that fills the slot has run — that is + how "not bound yet at this point" is told from "bound", with no liveness + analysis and no bitmap. *) + mutable slotv : string option; + snames : string option array; (* The [, !dbg !N] suffix every instruction in this function carries, or "". Uniform rather than only on the instructions that want a line: LLVM's verifier rejects a call without a location inside a function that has @@ -457,6 +467,24 @@ let ret f v = | None -> ()); term f "ret %s %s" (ll f.ret) v +(* The store that says "this slot is bound now". Emitted at each binding of a + named slot — a [let], a match arm, a restart clause's parameters — and at + entry for the parameters, which are bound before any of the body runs. + + It is deliberately the *address* and not a flag: the reader needs the + address anyway, so one store carries both facts, and a slot that has not + been reached yet reads as null rather than as a plausible value at an + address nobody wrote. *) +let bind_slot f i = + match f.slotv with + | None -> () + | Some v -> + if i < Array.length f.snames && f.snames.(i) <> None then begin + let p = fresh f in + ins f "%s = getelementptr inbounds ptr, ptr %s, i32 %d" p v i; + ins f "store ptr %s, ptr %s" f.slots.(i) p + end + let alloca f ty = let name = fresh f in Buffer.add_string f.allocas (Printf.sprintf " %s = alloca %s\n" name (ll ty)); @@ -665,7 +693,8 @@ and value_at f (e : Tast.expr) : string = List.iter (fun (slot, v) -> let v' = value f v in - ins f "store %s %s, ptr %s" (ll v.Tast.ty) v' f.slots.(slot)) + ins f "store %s %s, ptr %s" (ll v.Tast.ty) v' f.slots.(slot); + bind_slot f slot) bs; block f body | Tast.If (c, t, e') -> emit_if f e.Tast.ty c t e' @@ -1199,7 +1228,8 @@ and emit_restart_case f ty clauses body = ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p (args_type c) buf i; let v = load f p ty in - ins f "store %s %s, ptr %s" (ll ty) v f.slots.(slot_i)) + ins f "store %s %s, ptr %s" (ll ty) v f.slots.(slot_i); + bind_slot f slot_i) c.Tast.rparams in let rec dispatch = function @@ -1290,7 +1320,8 @@ and emit_match f ty scrut arms = (fun slot -> let v = fresh f in ins f "%s = extractvalue %s %s, 1" v sty sv; - ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot)) + ins f "store %s %s, ptr %s" (ll payload_ty) v f.slots.(slot); + bind_slot f slot) a.Tast.binds; let v = block f a.Tast.abody in (match result with @@ -1571,6 +1602,12 @@ and cast f (x : Tast.expr) target = | Types.Float _, Types.Int b -> if Types.signed b then "fptosi" else "fptoui" | Types.Float a, Types.Float b -> if Types.bits_f b > Types.bits_f a then "fpext" else "fptrunc" + (* Nothing in the surface language writes this: [check.ml] has no cast + between pointer types. The locals thunk does — it is handed a slot's + address as a raw pointer and has to read it as the type the slot + holds — and under opaque pointers there is no instruction to emit for + it, both sides being [ptr]. *) + | Types.Ptr _, Types.Ptr _ -> "bitcast" | _ -> failwith "unsupported cast" in if op = "bitcast" then v @@ -1646,7 +1683,7 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = slots = Array.init n (fun i -> Printf.sprintf "%%s%d" i); slot_tys = fn.Tast.slots; pads = []; unwind = "unwind"; unwound = false; defers = fn.Tast.fdefers; - frame = None; + frame = None; slotv = None; snames = fn.Tast.snames; dsub; dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line); dloc = ""; @@ -1681,7 +1718,36 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = right: it really is on the stack, and a backtrace that skipped it would show a gap exactly where the handler ran. *) if m.dev then begin - let info = fninfo m fn ~nslots:0 in + (* The slot table, and it is the whole of what [locals] reads. One [ptr] + per slot, null until the slot is bound; the frame points at it. + + Only a function with at least one *named* slot gets one, and only named + slots are ever recorded in it. That is not a saving of stores — the + nulls are written either way — it is a saving of *optimisation*: a slot + whose address is stored anywhere escapes, and an escaped alloca is one + mem2reg cannot promote. The slots that would hurt most to demote are + exactly the ones with no name to show: [dotimes]'s hidden bound, the + temporaries (min) and (max) evaluate their operands into, the walk's own + scratch in a render thunk. *) + let named = Array.exists (fun n -> n <> None) fn.Tast.snames in + if named && n > 0 then begin + let v = fresh f in + Buffer.add_string f.allocas + (Printf.sprintf " %s = alloca [%d x ptr]\n" v n); + (* Every entry, not only the named ones: "null means not bound" has to + hold at every index, or a reader has to know which indices it may + trust, and that is a second thing to keep in step. *) + for i = 0 to n - 1 do + let p = fresh f in + Buffer.add_string f.allocas + (Printf.sprintf " %s = getelementptr inbounds ptr, ptr %s, i32 %d\n" + p v i); + Buffer.add_string f.allocas + (Printf.sprintf " store ptr null, ptr %s\n" p) + done; + f.slotv <- Some v + end; + let info = fninfo m fn ~nslots:(if f.slotv = None then 0 else n) in let prev = fresh f in Buffer.add_string f.allocas " %frame = alloca %flanframe "; @@ -1696,11 +1762,25 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) = [ "%frame.i = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 1"; Printf.sprintf "store ptr %s, ptr %%frame.i" info; "%frame.s = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 2"; - "store ptr null, ptr %frame.s"; - "%frame.k = getelementptr inbounds %flanframe, ptr %frame, i32 0, i32 3"; - "store i64 0, ptr %frame.k"; + Printf.sprintf "store ptr %s, ptr %%frame.s" + (match f.slotv with Some v -> v | None -> "null"); "store ptr %frame, ptr @flan_frame_head" ]; - f.frame <- Some prev + f.frame <- Some prev; + (* The parameters are bound before the body starts, so they are recorded + here rather than at a binding site there is none of. *) + List.iteri (fun i _ -> + match f.slotv with + | None -> () + | Some v -> + if i < Array.length fn.Tast.snames && fn.Tast.snames.(i) <> None then begin + let p = fresh f in + Buffer.add_string f.allocas + (Printf.sprintf " %s = getelementptr inbounds ptr, ptr %s, i32 %d\n" + p v i); + Buffer.add_string f.allocas + (Printf.sprintf " store ptr %s, ptr %s\n" f.slots.(i) p) + end) + fn.Tast.params end; (* One [llvm.dbg.declare] per slot, in the entry block beside the alloca it describes. This is the whole of what lldb needs to print a local: the slot @@ -1868,7 +1948,7 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher ; every [ret] restores the head, the transfer path included. A release build ; emits neither, and the head below is then a symbol nothing in the .ll names. %fninfo = type { ptr, i64, ptr, i64, i32, i32 } -%flanframe = type { ptr, ptr, ptr, i64 } +%flanframe = type { ptr, ptr, ptr } @flan_frame_head = external global ptr declare void @flan_rt_init(i32, ptr) diff --git a/lib/session.ml b/lib/session.ml index 7c4eb88..90565b5 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -403,6 +403,14 @@ let externs : Tast.extern list = one emit_i64 "flan_dev_emit_i64"; one emit_u64 "flan_dev_emit_u64"; one emit_f64 "flan_dev_emit_f64"; + (* The address of a slot in a *stopped* frame, resolved by the agent + against the snapshot that break took. It is the one piece a locals + thunk cannot work out for itself: the compiler knows every slot's type + and name, and nothing but the running program knows where the frame + is. See [render_locals]. *) + { Tast.ename = "flan/dev-slot"; esym = "flan_agent_frame_slot"; + eparams = [ Types.Int Types.I64; Types.Int Types.I64 ]; + eret = Types.Ptr (Types.Int Types.U8) }; { Tast.ename = "flan/dev-begin"; esym = "flan_dev_result_begin"; eparams = []; eret = Types.Unit }; { Tast.ename = "flan/dev-end"; esym = "flan_dev_result_end"; @@ -421,6 +429,130 @@ let dev_emitter : Render.emitter = eu64 = call emit_u64; ef64 = call emit_f64 } +(* ── The locals of a stopped frame ─────────────────────────────────── *) + +(* The second half of what a break loop can show, and it is the same primitive + as [C-x C-e] pointed somewhere else. + + Nothing marshals and nothing is read across the process boundary. A Flan + value carries no header, so the daemon could not make sense of bytes it + copied out even if it had them; what it has instead is the *type*, from + [Tast.fn.slots], and a name for it, from [snames] beside it. So it compiles + a thunk that renders those types at those addresses, in the program, and + reads back the text — exactly what an evaluated expression does, except + that the root is an address rather than an expression. That address is the + only thing that comes from the running program. + + [bound] is which slots the program says have been reached. It is not an + optimisation: an unbound slot's entry is null, and a thunk that rendered + one would dereference null on the game thread of a program that is already + stopped. So the refusal happens here, before any code is emitted for it. + + What comes back is one line per slot — name, type, value, tab separated. + Tab and newline are safe separators because every string the renderer emits + goes through [flan_dev_emit_str], which escapes both. + + Each slot is rendered from its address rather than copied into the thunk + first. A copy would be one [alloca] the size of the slot — 40KB for sand's + grid — and the walk only ever shows eight elements of it. The cost is one + call to [flan/dev-slot] per leaf the walk reaches instead of one per slot, + which the depth and span caps already bound. *) +let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound + : change * (string * string) list = + let loc = fn.Tast.floc in + let extra = ref [] and nslots = ref 0 in + let c = + { Render.structs = t.program.Tast.structs; + enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; + emit = dev_emitter; + alloc = (fun ty -> + let i = !nslots in + incr nslots; + extra := ty :: !extra; + i) } + in + let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in + let bytes_of str = + { Tast.e = + Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]); + ty = Types.Slice (Types.Int Types.U8); loc } + in + let lit str = c.Render.emit.Render.ebytes (bytes_of str) in + let refused = ref [] in + let refuse name why = refused := (name, why) :: !refused in + let one i ty name = + let idx n = + { Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; loc } + in + let address = + { Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx i ]); + ty = Types.Ptr (Types.Int Types.U8); loc } + in + let typed = + { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr ty), [ address ]); + ty = Types.Ptr ty; loc } + in + let v = { Tast.e = Tast.Deref typed; ty; loc } in + match Render.render c 0 v with + | parts -> + Some + ((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts) @ [ lit "\n" ]) + | exception Loc.Error (_, why) -> + (* A type the structural printer has no arm for — a map, a function + value, a type variable. Named, with the reason, rather than left out + of the list: a local that is missing and a local that could not be + printed are different facts. *) + refuse name why; + None + in + let body = + List.concat + ((List.filter_map + (fun i -> + let ty = fn.Tast.slots.(i) in + let name = + if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) + else None + in + match name with + | None -> + (* A slot the compiler made up: [dotimes]'s hidden bound, the + temporary a (min) evaluates an operand into. There is no + name to show and inventing one would put a variable in the + list that nobody can find in the file. *) + refuse (Printf.sprintf "s%d" i) + "a slot the compiler made up; no name was written for it"; + None + | Some name when not (List.mem i bound) -> + refuse name + "not bound yet at the point the program stopped"; + None + | Some name -> one i ty name) + (List.init (Array.length fn.Tast.slots) (fun i -> i)))) + in + t.thunks <- t.thunks + 1; + let name = Printf.sprintf "locals/%d" t.thunks in + let thunk : Tast.fn = + { Tast.name; params = []; ret = Types.Unit; + body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ]; + fdefers = []; fparent = None; floc = loc; + slots = Array.of_list (List.rev !extra); + (* Every slot in here is the walk's own scratch: the locals being shown + are the *other* frame's, and this thunk reaches them by address. *) + snames = Array.make (List.length !extra) None } + in + let program = + { t.program with + Tast.fns = t.program.Tast.fns @ [ thunk ]; + externs = t.program.Tast.externs @ externs } + in + let ir = + Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ~call:name + program ~fns:[ name ] + in + ignore origin; + ({ ir; names = []; fns = []; installs = true }, List.rev !refused) + let eval_expr ?(origin = "") t src : change = let form = match Reader.read_all ~file:origin src with diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index bc5533a..0be0ba9 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -341,11 +341,12 @@ typedef struct { typedef struct flan_frame { struct flan_frame *prev; const flan_fninfo *info; - /* Where each slot lives, and which of them have been bound at the point the - * frame was interrupted. Both are null/zero unless the build records them; - * see emit.ml. Read through [flan_dev_frame_slot], never directly. */ + /* One entry per slot, each null until the binding that fills that slot has + * run — so "not bound yet at the point this frame stopped" is a null and + * needs no liveness analysis to work out. Null altogether for a function + * with no named slot, and in a release build there is no frame at all. + * Read through [flan_dev_frame_slot], which is where the bound is checked. */ void **slots; - uint64_t init; } flan_frame; /* The compiler names this symbol directly. A redefinition module reaches it @@ -389,3 +390,15 @@ int32_t flan_dev_frame_nslots(const void *frame) { return (f == NULL || f->info == NULL) ? 0 : f->info->nslots; } +/* Where slot [i] of this frame lives, or NULL — which means one of three + * things, all of which are "there is nothing to read here": this build records + * no slots, the index is not one of them, or the binding that fills it had not + * run when the frame stopped. A caller renders what it is given and refuses + * what it is not; nothing here guesses. */ +void *flan_dev_frame_slot(const void *frame, int32_t i) { + const flan_frame *f = frame; + if (f == NULL || f->info == NULL || f->slots == NULL) return NULL; + if (i < 0 || i >= f->info->nslots) return NULL; + return f->slots[i]; +} + diff --git a/test/programs/dev-locals.flan b/test/programs/dev-locals.flan new file mode 100644 index 0000000..da27e79 --- /dev/null +++ b/test/programs/dev-locals.flan @@ -0,0 +1,34 @@ +;;;; A program that stops with something worth looking at in the frame. +;;;; +;;;; dev-break.flan proves an editor can find out *that* a program stopped and +;;;; choose a restart; this one is about what the frame holds while it is +;;;; stopped. One local of each shape the structural printer has an arm for — +;;;; a parameter, a string, a struct, a fixed array, a bool — plus one that is +;;;; bound only *after* the error, which is the case that must come back +;;;; refused rather than rendered: its slot is storage nothing has written yet. +(import agent "vendor:agent") + +(defstruct Point [x f32 y f32]) +(defstruct Boom [why i32]) + +(defn look [n i64 label string] i64 + (let [p (Point {:x 1.5 :y 2.5}) + xs [10 20 30] + flag (> n 0)] + (restart-case + (do (error (Boom {:why 7})) + ;; Never reached before the break, so [after] is a slot with nothing + ;; in it: the frame records a null for it and this is what "not bound + ;; yet" has to mean. + (let [after (i64 99)] after)) + (carry-on [] 5)))) + +(defvar ticks i64) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-locals-fallback.sock") + (print (look 3 "hello")) (println "") + (dotimes [i 4000] + (agent/wait 5) + (set ticks (+ ticks 1))) + 0) diff --git a/test/test_dev.ml b/test/test_dev.ml index dfa9766..3f6b086 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -708,6 +708,131 @@ let () = (try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ()) end end; + (* ── The locals of a stopped frame ─────────────────────────────── *) + + (* A third daemon, over a program that stops with something worth looking + at. This is the half of the shadow stack the backtrace was built for: + the frame chain gives the addresses, [Tast.fn] gives the types and the + names, and a thunk compiled here renders those types at those addresses + inside the stopped program. Nothing is copied out — a Flan value has no + header, so bytes read from another process would be bytes with no + meaning. + + Its own daemon and its own program, for the same reason the break block + has: the claims are about one frame of one program. *) + let lsock = tmp "locals.sock" and lout = tmp "locals.out" in + (try Sys.remove lsock with Sys_error _ -> ()); + let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let lpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-locals.flan"; "-s"; lsock |] + Unix.stdin lfd Unix.stderr + in + Unix.close lfd; + if not (await (fun () -> Sys.file_exists lsock)) then begin + fail "the locals daemon never listened"; + (try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect lsock in + let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then + fail "the locals program never stopped" + else begin + let pairs r key = + match Wire.field r key with + | Some { Form.v = Form.List l; _ } -> + List.filter_map + (fun (e : Form.t) -> + match e.Form.v with + | Form.List ({ Form.v = Form.Str a; _ } + :: { Form.v = Form.Str b; _ } :: rest) -> + Some (a, b, + match rest with + | { Form.v = Form.Str c; _ } :: _ -> c + | _ -> "") + | _ -> None) + l + | _ -> [] + in + let r = ask "(:op \"locals\" :frame 0)" in + if status r <> "ok" then + fail "locals: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")) + else begin + (* One of each shape the structural printer has an arm for, rendered + in the program and read back as text. The values are the ones + [look] was called with, which is the claim: this is the frame's + own storage and not a guess from the source. *) + let got = + List.map (fun (n, ty, v) -> (n, ty, v)) (pairs r "locals") + in + let want = + [ ("n", "i64", "3"); + ("label", "string", "\"hello\""); + ("p", "Point", "(Point {:x 1.5 :y 2.5})"); + ("xs", "[3 i32]", "[ 10 20 30]"); + ("flag", "bool", "true") ] + in + if got <> want then + fail "locals of the stopped frame: %s" + (String.concat ", " + (List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got)); + (* And the one that must not be rendered. [after] is bound inside + the restart-case *past* the error, so its slot is storage nothing + has written: the frame records a null for it, and a thunk that + printed it would dereference that null on the game thread of a + program that is already stopped. Refused by name, with the + reason, rather than left off the list — a local that is missing + and a local that could not be read are different facts. *) + match List.filter (fun (n, _, _) -> n = "after") (pairs r "refused") with + | [ (_, why, _) ] when why <> "" -> () + | _ -> + fail "a slot bound after the error was not refused by name: %s" + (String.concat ", " + (List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused"))) + end; + (* A frame whose every slot the compiler invented is not an error and + is not an empty answer either: it says which it is. *) + let r = ask "(:op \"locals\" :frame 1)" in + if status r <> "ok" then fail "locals of main: %s" (status r); + (* Out of range is refused with the depth, so a client can tell a bad + index from a frame with nothing in it. *) + let r = ask "(:op \"locals\" :frame 9)" in + if status r <> "error" then fail "a frame index past the end answered" + end; + (* Running again, and then the locals verb is refused: a frame that is + still executing does not hold still long enough to be read. *) + let r = ask "(:op \"restart\" :name \"carry-on\")" in + if status r <> "ok" then + fail "resuming the locals program: %s" + (Option.value ~default:"" (Wire.string_field r "message")); + if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then + fail "the locals program never resumed" + else begin + let r = ask "(:op \"locals\" :frame 0)" in + if status r <> "error" then + fail "a running program answered with its locals" + end; + ignore (ask "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] lpid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ()) + end + end; + (* ── Disassembly ───────────────────────────────────────────────── *) (* A third daemon, over a program that keeps running, because the two diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 3df25fc..24f3e54 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -155,6 +155,7 @@ extern void *flan_dev_frame_at(int32_t i); extern const char *flan_dev_frame_name(const void *frame, int64_t *len); extern const char *flan_dev_frame_loc(const void *frame, int64_t *len); extern int32_t flan_dev_frame_nslots(const void *frame); +extern void *flan_dev_frame_slot(const void *frame, int32_t i); extern const uint8_t *flan_restart_name(int32_t i, int64_t *len); extern void *flan_restart_frame(int32_t i); extern void flan_restart_take(void *frame, void *xfer); @@ -270,6 +271,33 @@ typedef struct { static snapshot snaps[BREAK_MAX]; static _Atomic int snap_depth; /* published last; 0 = none */ +static snapshot *snap_top(void); + +/* Where slot [slot] of frame [frame] lives, resolved against the snapshot this + * break took and not against the live chain. + * + * This is what a locals thunk calls. The thunk runs on the stopped game + * thread, from inside this break loop's own poll, and it pushes frames of its + * own while it runs — so "frame 2" means the third frame of the backtrace the + * daemon was shown, not the third frame of whatever the stack looks like by + * the time the thunk is executing. Resolving against the snapshot is the whole + * of the difference, and it is the same reason the restarts are answered from + * there. + * + * NULL for anything it cannot place, and the thunk is built to ask only about + * slots the same snapshot already reported as bound. A NULL would be + * dereferenced, so this is the one place that must not answer optimistically: + * an index that is out of range, a frame that is not in this snapshot, or a + * slot the binding for which had not run, are each a null here and a refusal + * before the thunk is ever built. */ +void *flan_agent_frame_slot(int64_t frame, int64_t slot) { + snapshot *s = snap_top(); + if (s == NULL) return NULL; + if (frame < 0 || frame >= s->fn) return NULL; + if (slot < 0 || slot > 0x7fffffff) return NULL; + return flan_dev_frame_slot(s->fframe[frame], (int32_t)slot); +} + static snapshot *snap_top(void) { int d = atomic_load(&snap_depth); return d <= 0 ? NULL : &snaps[d - 1]; @@ -658,6 +686,41 @@ static void serve(int fd) { reply(fd, ".\n"); return; } + /* Which of a frame's slots have been bound at the point it stopped. One + * line per slot: the index and [+] or [-]. + * + * The daemon asks this before it builds a thunk, and that order is the + * safety: an unbound slot is a null address, a thunk that rendered one + * would dereference it, and a program stopped in a break loop is the last + * place to take a fault. It is answered from the snapshot, so the set the + * daemon is told about is the set the thunk will resolve against. + * + * It says nothing about *what* a slot holds, or what it is called. Those + * are facts about the build, and the daemon owns the build — [Tast.fn] + * carries [slots] and [snames] beside each other. Sending them from here + * would be a second copy of them that could drift. */ + if (strncmp(line, "locals ", 7) == 0) { + if (!(atomic_load(&depth) > 0)) { reply(fd, "err not stopped\n"); return; } + snapshot *s = snap_top(); + if (s == NULL) { reply(fd, "err no frame snapshot\n"); return; } + char *end = NULL; + long at = strtol(line + 7, &end, 10); + if (end == line + 7) { reply(fd, "err locals wants a frame index\n"); return; } + if (at < 0 || at >= s->fn) { reply(fd, "err no frame at that index\n"); return; } + if (s->fslots[at] == 0) { + reply(fd, "err that frame records no slots; it has no named local, or " + "this build does not record them\n"); + return; + } + for (int32_t i = 0; i < s->fslots[at]; i++) { + char l[32]; + int k = snprintf(l, sizeof l, "%d %c\n", i, + flan_dev_frame_slot(s->fframe[at], i) ? '+' : '-'); + if (k > 0) send(fd, l, (size_t)k, MSG_NOSIGNAL); + } + reply(fd, ".\n"); + return; + } /* Take the i'th, optionally checking that the caller and this snapshot * still agree on what the i'th is called. The name is not the lookup - * that is the bug - it is a receipt: a client that listed, prompted, and