Joseph Ferano
36c3e5a56d
The globals section attributed a frame by its slot fingerprint, which is the wrong cut for it: a redefined body can name entirely different globals while binding identical locals, so the check saw no change and the new body's reference set went into the union under the old body's frame, with the frame numbers beside an entry saying so. So a second fingerprint. Reach.ref_fingerprint hashes the set of globals a body names — sorted and deduplicated, because a reference set is not ordered, where slot indices make the slot fingerprint order-sensitive on purpose — and it travels the path the first one already cut: %fninfo, flan_dev_frame_refsig, the agent's snapshot, the backtrace line, Dev.globals_op. Different means the frame is skipped by name with its reason, and the rest of the stack still contributes. Two numbers rather than one, because they are two facts. A frame whose slots match and whose globals do not has locals that are perfectly readable and attribution that is not, and a combined hash would make locals refuse a frame with nothing wrong with it. locals still checks the slot fingerprint alone. It lives in reach.ml because expr_refs is already the walk that answers what a body refers to, and is the walk the union itself is built from. One consequence: emit now reaches reach, which closes a cycle through Load if cimport calls Build.cachedir, so the header cache spells the object cache directory itself. test_dev.ml drives the exact case — a body that binds identical locals and names untouched where the stopped frame names pressure. With the check disabled it fails twice: the missing refusal, and untouched appearing under frame 0.
201 lines
9.3 KiB
OCaml
201 lines
9.3 KiB
OCaml
(** What a program actually calls, and what that means for the link.
|
|
|
|
A package is imported as a whole — every declaration in the directory
|
|
becomes a declaration of the importing program — and until now the C it
|
|
binds to came with it unconditionally. So importing [vendor:raylib] linked
|
|
libraylib whatever [main] did, and on wasm32 that link cannot succeed. That
|
|
is the single fact that made sand's two halves two *files* rather than two
|
|
entry points, and it is what this module removes.
|
|
|
|
The answer is reachability, computed once on the checked program: start at
|
|
[main] and at every global initialiser, follow every call, and keep what is
|
|
reached. Two things fall out of the same walk:
|
|
|
|
- a package none of whose externs is reached contributes no [.c] file and
|
|
no linker argument, and
|
|
- the functions that would have referenced those externs are dropped from
|
|
the program, because removing [-lraylib] while still emitting a body that
|
|
calls [@InitWindow] only moves the failure from the linker's argument
|
|
list to its symbol table.
|
|
|
|
Only [fns] and [externs] are pruned. Globals, structs and unions stay:
|
|
a dropped function is a loud link error, a dropped global would be a
|
|
silently different program, and an unreferenced global is bytes in BSS that
|
|
cost nothing. A [defvar brush rl/Texture2D] in a headless build is exactly
|
|
that.
|
|
|
|
Dev builds are not pruned at all. A REPL redefines a function that the
|
|
running program has not called yet, so "not reached" there means "not
|
|
reached *so far*", which is not the same claim. *)
|
|
|
|
(* The edges. [Call] and [Global] are the obvious ones; [Handled] is the one
|
|
worth naming, because a handler-bind clause was lifted into a function of
|
|
its own and is reached by *address* from the body that wrote it, never by a
|
|
call. Miss it and a program with a handler loses the handler. *)
|
|
let rec expr_refs f (e : Tast.expr) =
|
|
let go = expr_refs f in
|
|
let gos = List.iter go in
|
|
match e.Tast.e with
|
|
| Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit
|
|
| Tast.Zero _ | Tast.Uninit _ | Tast.Local _ | Tast.None_
|
|
| Tast.InvokeRestart _ -> ()
|
|
| Tast.Global n -> f n
|
|
(* The other edge reached by address rather than by a call: a Map's hash and
|
|
equality pair. Same hazard as [Handled] below — miss it and a program with
|
|
a map loses the two functions its every lookup calls through. *)
|
|
| Tast.FnAddr (Tast.Flanfn n) -> f n
|
|
| Tast.FnAddr (Tast.Rtfn _) -> ()
|
|
| Tast.Prim (_, es) -> gos es
|
|
| Tast.Call (n, es) -> f n; gos es
|
|
| Tast.Do es -> gos es
|
|
| Tast.Let (bs, body) -> List.iter (fun (_, v) -> go v) bs; gos body
|
|
| Tast.If (c, t, e') -> go c; go t; go e'
|
|
| Tast.While (c, body) -> go c; gos body
|
|
| Tast.Return v -> Option.iter go v
|
|
| Tast.Set (p, v) -> place_refs f p; go v
|
|
| Tast.Field (t, _) -> go t
|
|
| Tast.Addr p -> place_refs f p
|
|
| Tast.Deref t -> go t
|
|
| Tast.Make (_, es) -> gos es
|
|
| Tast.Arr es -> gos es
|
|
| Tast.Some_ v -> go v
|
|
| Tast.Match (sc, arms) ->
|
|
go sc; List.iter (fun (a : Tast.arm) -> gos a.Tast.abody) arms
|
|
| Tast.UnwrapSome v -> go v
|
|
| Tast.Signal (_, _, c) -> go c
|
|
| Tast.Handled (frames, body) ->
|
|
List.iter (fun (h : Tast.hframe) -> f h.Tast.hfn) frames;
|
|
gos body
|
|
| Tast.RestartCase (cs, body) ->
|
|
List.iter (fun (c : Tast.rclause) -> gos c.Tast.rbody) cs;
|
|
go body
|
|
| Tast.WithAlloc (a, body) -> go a; gos body
|
|
|
|
and place_refs f (p : Tast.place) =
|
|
match p with
|
|
| Tast.Plocal _ -> ()
|
|
| Tast.Pglobal n -> f n
|
|
| Tast.Pfield (t, _) -> expr_refs f t
|
|
| Tast.Pindex (t, idx) -> expr_refs f t; List.iter (expr_refs f) idx
|
|
| Tast.Pderef t -> expr_refs f t
|
|
|
|
(* ── What a body names, as one number ──────────────────────────────── *)
|
|
|
|
(* The globals half of what the two ends of a break loop compare about a frame,
|
|
and the companion to [Emit.slot_fingerprint] rather than a replacement for
|
|
it. The slot fingerprint is the right cut for [locals]: if the slots are
|
|
identical then the names still describe the storage, whatever else the body
|
|
changed. It is the wrong cut for the globals section, because a redefined
|
|
body can name entirely different globals while binding identical locals —
|
|
and then the section shows the new body's reference set attributed to the
|
|
frame of the old one.
|
|
|
|
Two fingerprints and not one combined, because the two facts are separately
|
|
useful: a frame can have perfectly readable locals and untrustworthy global
|
|
attribution, and the user should be told which. One hash over both would
|
|
make [locals] refuse a frame nothing is wrong with.
|
|
|
|
**A set, sorted and deduplicated, not the order the walk found them in.**
|
|
Slot indices make the slot fingerprint order-sensitive on purpose; a
|
|
reference set is not ordered, and a body that mentions the same two globals
|
|
the other way round is the same body as far as this is concerned.
|
|
|
|
Computed from [expr_refs], which is the walk that already answers "what does
|
|
this body refer to" — the same one [Dev]'s globals section uses to build the
|
|
union, so the two cannot disagree about what counts as a reference. Which
|
|
names are globals is the caller's to say: the emitter knows the program's
|
|
globals, and so does the session. *)
|
|
let ref_fingerprint ~is_global (fn : Tast.fn) =
|
|
let seen = Hashtbl.create 16 in
|
|
let note n = if is_global n && not (Hashtbl.mem seen n) then Hashtbl.add seen n () in
|
|
List.iter (expr_refs note) fn.Tast.body;
|
|
List.iter (expr_refs note) fn.Tast.fdefers;
|
|
let names = List.sort compare (Hashtbl.fold (fun n () acc -> n :: acc) seen []) in
|
|
Hashtbl.hash (String.concat ";" names) land 0x3fffffff
|
|
|
|
(* Every name reachable from [main] and from the globals, which run before it.
|
|
A name that is neither a function nor an extern — a global, a struct — is
|
|
still recorded; it costs a hashtable entry and saves asking twice. *)
|
|
let reachable (p : Tast.program) =
|
|
let fns = Hashtbl.create 64 in
|
|
List.iter (fun (fn : Tast.fn) -> Hashtbl.replace fns fn.Tast.name fn) p.Tast.fns;
|
|
let seen = Hashtbl.create 128 in
|
|
let queue = Queue.create () in
|
|
let visit n =
|
|
if not (Hashtbl.mem seen n) then begin
|
|
Hashtbl.add seen n ();
|
|
Queue.add n queue
|
|
end
|
|
in
|
|
List.iter (fun (g : Tast.global) -> expr_refs visit g.Tast.ginit) p.Tast.globals;
|
|
visit "main";
|
|
while not (Queue.is_empty queue) do
|
|
let n = Queue.pop queue in
|
|
match Hashtbl.find_opt fns n with
|
|
| None -> ()
|
|
| Some fn ->
|
|
List.iter (expr_refs visit) fn.Tast.body;
|
|
List.iter (expr_refs visit) fn.Tast.fdefers
|
|
done;
|
|
seen
|
|
|
|
(* A lifted handler clause is reached from its parent and from nowhere else,
|
|
and the parent names it in a [Handled] frame — so it is already in [seen]
|
|
when the parent is. Nothing extra is needed for it here; [fparent] only
|
|
matters to the dev registry. *)
|
|
|
|
let prune (p : Tast.program) =
|
|
let seen = reachable p in
|
|
let kept n = Hashtbl.mem seen n in
|
|
{ p with
|
|
Tast.fns = List.filter (fun (f : Tast.fn) -> kept f.Tast.name) p.Tast.fns;
|
|
externs =
|
|
List.filter (fun (e : Tast.extern) -> kept e.Tast.ename) p.Tast.externs }
|
|
|
|
(* ── What the build is told ────────────────────────────────────────── *)
|
|
|
|
(* The link, decided by the program rather than by the import list. [dev] is
|
|
the opt-out: a dev build keeps everything, because what a REPL may call next
|
|
is not a function of what it has called so far.
|
|
|
|
Returns the program to emit and the C and linker arguments that go with it,
|
|
which is why it is one function and not three — the three answers have to
|
|
agree, and a caller that took the flags without the pruned program would
|
|
link nothing and still emit the calls. *)
|
|
let link ?(dev = false) (l : Load.t) (p : Tast.program) =
|
|
if dev then (p, l.Load.csrcs, l.Load.lflags)
|
|
else begin
|
|
let p = prune p in
|
|
let used (pkg : Load.pkg) =
|
|
(* An extern of the package survived the prune, so something reachable
|
|
calls into the C it binds to. A package of pure Flan has no externs
|
|
and no C either, so it answers false and contributes nothing, which
|
|
is the same as contributing what it has. *)
|
|
let prefix = pkg.Load.alias ^ "/" in
|
|
List.exists
|
|
(fun (e : Tast.extern) -> String.starts_with ~prefix e.Tast.ename)
|
|
p.Tast.externs
|
|
in
|
|
(* The generated wrappers go the same way as the packages: a wrapper whose
|
|
flattened declaration did not survive the prune is a C function calling
|
|
a library symbol nothing reachable wants, and emitting it would put an
|
|
undefined reference in a link that deliberately has no such library.
|
|
The preamble stays; an unused typedef costs nothing. *)
|
|
let live (name, _) =
|
|
name = ""
|
|
|| List.exists (fun (e : Tast.extern) -> e.Tast.esym = name)
|
|
p.Tast.externs
|
|
in
|
|
let p =
|
|
match List.filter live p.Tast.cshim with
|
|
(* Nothing left but the preamble: no wrapper survived, so there is no
|
|
translation unit to compile. *)
|
|
| [ ("", _) ] | [] -> { p with Tast.cshim = [] }
|
|
| parts -> { p with Tast.cshim = parts }
|
|
in
|
|
let pkgs = List.filter used l.Load.pkgs in
|
|
(p,
|
|
List.concat_map (fun (k : Load.pkg) -> k.Load.pcsrcs) pkgs,
|
|
List.concat_map (fun (k : Load.pkg) -> k.Load.plflags) pkgs)
|
|
end
|