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 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
  | 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

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

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