210 lines
9.9 KiB
OCaml
210 lines
9.9 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 _) -> ()
|
|
(* A function value, and the *only* thing that keeps it linked. A name used
|
|
as a value is never a [Call], so without this edge the one function a
|
|
program passes to [map] is the one function the link drops. *)
|
|
| Tast.FnAddr (Tast.Fnval n) -> f n
|
|
| Tast.Prim (_, es) -> gos es
|
|
| Tast.Call (n, es) -> f n; gos es
|
|
(* No name to root: whatever this calls was reached as a value, and the
|
|
[FnAddr] that produced it is somewhere in the callee expression. *)
|
|
| Tast.CallPtr (callee, es) -> go callee; 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, latch) -> go c; gos body; gos latch
|
|
| Tast.Break _ | Tast.Continue _ -> ()
|
|
| 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) | Tast.MakeCase (_, _, es) -> gos es
|
|
| Tast.CaseField (t, _, _) -> go t
|
|
| 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
|