flan/lib/reach.ml

(** 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 data types 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 [defonce 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, which is the whole of what this module has to say about the shape
   of an expression: [Tast.walk] visits every node and this names the ones that
   are a link-time reference. [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.

   A write to a global is a reference too — [Set] and [Addr] through a
   [Pglobal] — which is how a program whose only mention of a global is the
   (set g ...) that loads it keeps it. *)
let expr_refs f (e : Tast.expr) =
  Tast.walk
    (fun (e : Tast.expr) ->
       match e.Tast.e with
       | Tast.Global n -> f n
       | Tast.Call (n, _) -> f n
       (* The edges reached by address rather than by a call: a Map's hash and
          equality pair, and a function *value* someone wrote the name of. A
          name used as a value is never a [Call], so without the second one the
          one function a program passes to [map] is the one function the link
          drops. [Rtfn] is C in flan_rt.c and is linked whatever happens. *)
       | Tast.FnAddr (Tast.Flanfn n) | Tast.FnAddr (Tast.Fnval n)
       | Tast.Closure (Tast.Flanfn n, _) | Tast.Closure (Tast.Fnval n, _)
       (* And the widening thunk, which is reached by address from the value
          it builds and from nowhere else. Without this edge the one function
          a program widens is the one function the link drops. *)
       | Tast.Thicken (n, _) -> f n
       | Tast.Set (Tast.Pglobal n, _) | Tast.Addr (Tast.Pglobal n) -> f n
       | Tast.Handled (frames, _) ->
         List.iter (fun (h : Tast.hframe) -> f h.Tast.hfn) frames
       (* A [CallPtr] roots no name: whatever it calls was reached as a value,
          and the [FnAddr] that produced it is a node inside the callee. *)
       | _ -> ())
    e

(* ── 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