flan/lib/build.ml

(** Driver: typed IR → an executable, via LLVM IR text and clang.

    The release path from plan.org, Compilation:

    {v flan → typed IR → .ll → clang --target={native,wasm32} v}

    Not the dev path — that one never invokes the clang driver, because the
    driver *is* the cost, and goes llc + ld -shared + dlopen instead. That is
    [shared], at the bottom of this file, measured at ~19ms. *)

let clang = try Sys.getenv "FLAN_CLANG" with Not_found -> "clang"

let write path contents =
  let ch = open_out path in
  output_string ch contents;
  close_out ch

let write_bin path contents =
  let ch = open_out_bin path in
  output_string ch contents;
  close_out ch

let read_file path =
  let ch = open_in_bin path in
  let n = in_channel_length ch in
  let s = really_input_string ch n in
  close_in ch;
  s

let read_file_opt path =
  try Some (read_file path) with Sys_error _ -> None

(* One temporary directory per build, so the .ll is findable by name when
   something is wrong with it. *)
let workdir () =
  let d =
    Filename.concat (Filename.get_temp_dir_name ())
      (Printf.sprintf "flan-%d" (Unix.getpid ()))
  in
  (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
  d

(* The object cache, which unlike [workdir] is stable across builds. The C that
   goes into a build — the host shim and the packages' shims — is the same on
   every build and never the thing being edited, yet it was being recompiled
   each time: 40ms of a 140ms build for [flan_rt.c] alone. *)
let cachedir () =
  let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-objcache" in
  (try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
  d

type opts = {
  target : string option;   (* None is the host; "wasm32-wasi" is the other *)
  opt    : string;
  keep   : bool;            (* leave the .ll behind *)
  checks : bool;            (* bounds-check [at] and [slice] *)
  (* A dev build is the one a REPL can attach to. Two things, and they belong
     together because either alone is useless: every cross-function call goes
     through a cell so a redefinition can be installed, and [-rdynamic] exports
     those cells (and the globals) so a dlopen'd module can reach them. *)
  dev : bool;
}

(* Checks are deliberately independent of [opt]: the acceptance table runs the
   same programs at -O0 and -O2 to compare the emitted IR against what mem2reg
   makes of it, and that comparison is only meaningful if both emit the same
   checks. Dropping them is a release decision, not an optimisation one. *)
let default =
  { target = None; opt = "-O2"; keep = false; checks = true; dev = false }

(* ── wasm32, which needs more than a triple ──────────────────────────
   The native target is whatever clang was built for, so [--target=] alone is
   the whole of it. wasm32-wasi is not: the headers come from a sysroot clang
   does not know about, and the builtins archive is not in clang's resource
   directory on Fedora at all. Both have to be found, and *both* have to reach
   the C compiles as well as the link — [flan_rt.c] includes <stdio.h>.

   Anything missing is refused by name, with the path that is missing and the
   package that would supply it. A build that reports success for a target it
   cannot actually produce is the one outcome worth avoiding here. *)

let getenv name = try Some (Sys.getenv name) with Not_found -> None

let is_wasm t = String.starts_with ~prefix:"wasm32" t

let wasm_target opts =
  match opts.target with Some t when is_wasm t -> true | _ -> false

(* Where on PATH a program is, or None. *)
let on_path prog =
  let dirs = String.split_on_char ':' (try Sys.getenv "PATH" with Not_found -> "") in
  List.find_map
    (fun d ->
       let p = Filename.concat d prog in
       if Sys.file_exists p then Some p else None)
    dirs

let wasm_sysroot () =
  match getenv "FLAN_WASM_SYSROOT" with Some s -> s | None -> "/usr/wasm32-wasi"

(* The builtins archive — __muldi3, the float conversions, memcpy. Fedora's
   clang ships no wasm copy of it (dnf provides '*libclang_rt.builtins*wasm*'
   finds nothing) and the proper article comes from a wasi-sdk release.
   Failing that, emscripten builds the same compiler-rt for wasm32 and calls it
   libcompiler_rt.a; it is a different triple (wasm32-unknown-emscripten) built
   by a different clang, and it is *substituting* here, not the real thing. It
   links and runs, and the sand hash matches native byte for byte, but a
   session reading this should know the joint is glued. *)
let wasm_builtins_candidates () =
  (* wasi-sdk's own resource directory, whichever LLVM that release bundled —
     the version is in the path and moves release to release, so it is read
     rather than guessed. Same rule as [clang_resource_dir]. *)
  (let root = "/opt/wasi-sdk/lib/clang" in
   match Sys.readdir root with
   | vs ->
     Array.sort compare vs;
     Array.to_list vs
     |> List.map (fun v ->
          Filename.concat root
            (Filename.concat v "lib/wasm32-unknown-wasi/libclang_rt.builtins.a"))
   | exception Sys_error _ -> [])
  @ (match on_path "emcc" with
     | None -> []
     | Some e ->
       [ Filename.concat (Filename.dirname e)
           "cache/sysroot/lib/wasm32-emscripten/libcompiler_rt.a" ])

let wasm_builtins () =
  (* An explicit FLAN_WASM_BUILTINS that does not exist is an error and not a
     hint: falling back to a guess would build against something other than
     what was asked for and say nothing. *)
  match getenv "FLAN_WASM_BUILTINS" with
  | Some s when Sys.file_exists s -> s
  | Some s ->
    failwith (Printf.sprintf "wasm32: FLAN_WASM_BUILTINS is %s, which does not exist" s)
  | None ->
  let cands = wasm_builtins_candidates () in
  match List.find_opt Sys.file_exists cands with
  | Some p -> p
  | None ->
    failwith
      (Printf.sprintf
         "wasm32: no builtins archive. clang wants \
          <resource-dir>/lib/wasm32-unknown-wasi/libclang_rt.builtins.a, which \
          no Fedora package provides; it comes from a wasi-sdk release, or \
          emscripten's libcompiler_rt.a will substitute. Looked in: %s. Set \
          FLAN_WASM_BUILTINS to the archive."
         (String.concat ", " cands))

(* clang's own resource directory, asked for rather than guessed — the version
   number is in the path and a Fedora clang bump changes it. *)
let clang_resource_dir =
  lazy
    (let tmp =
       Filename.concat (Filename.get_temp_dir_name ())
         (Printf.sprintf "flan-rd-%d" (Unix.getpid ()))
     in
     let code =
       Sys.command
         (Printf.sprintf "%s -print-resource-dir > %s 2>/dev/null"
            (Filename.quote clang) (Filename.quote tmp))
     in
     let s = if code = 0 then read_file_opt tmp else None in
     (try Sys.remove tmp with Sys_error _ -> ());
     match s with
     | Some s -> String.trim s
     | None -> failwith "wasm32: clang -print-resource-dir failed")

(* A resource directory clang will accept for wasm32-wasi: its real include
   directory, and the builtins archive under the name and triple clang looks
   for. Built under the object cache and named by a digest of what went into
   it, so repointing FLAN_WASM_BUILTINS or upgrading clang makes a new one
   rather than reusing a stale one. *)
let wasm_resource_dir () =
  let real = Lazy.force clang_resource_dir in
  let builtins = wasm_builtins () in
  let st = Unix.stat builtins in
  let key =
    Digest.to_hex
      (Digest.string
         (String.concat "\000"
            [ real; builtins; string_of_int st.Unix.st_size;
              string_of_float st.Unix.st_mtime ]))
  in
  let dir = Filename.concat (cachedir ()) ("wasm-rd-" ^ key) in
  let lib = Filename.concat dir "lib" in
  let triple = Filename.concat lib "wasm32-unknown-wasi" in
  let archive = Filename.concat triple "libclang_rt.builtins.a" in
  if not (Sys.file_exists archive) then begin
    let mk d = try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> () in
    mk dir; mk lib; mk triple;
    let inc = Filename.concat dir "include" in
    if not (Sys.file_exists inc) then
      (try Unix.symlink (Filename.concat real "include") inc
       with Unix.Unix_error _ -> ());
    let tmp = Printf.sprintf "%s.%d.tmp" archive (Unix.getpid ()) in
    write_bin tmp (read_file builtins);
    (try Unix.rename tmp archive with Unix.Unix_error _ -> ())
  end;
  dir

(* The flags a target adds, used by the C compiles and by the link alike. *)
let target_flags opts =
  match opts.target with
  | None -> []
  | Some t when not (is_wasm t) -> [ "--target=" ^ t ]
  | Some t ->
    let sysroot = wasm_sysroot () in
    (* Fedora's wasi-libc puts the headers one level deeper than wasi-sdk's
       does — include/wasm32-wasi/stdio.h against include/stdio.h — so both
       shapes count as a sysroot. clang finds either on its own. *)
    if not (List.exists
              (fun p -> Sys.file_exists (Filename.concat sysroot p))
              [ "include/stdio.h"; "include/wasm32-wasi/stdio.h" ])
    then
      failwith
        (Printf.sprintf
           "wasm32: no sysroot at %s (wanted include/stdio.h). Install \
            wasi-libc-devel and wasi-libc-static, or set FLAN_WASM_SYSROOT."
           sysroot);
    [ "--target=" ^ t; "--sysroot=" ^ sysroot;
      "-resource-dir=" ^ wasm_resource_dir () ]

(* wasi-libc's start code calls __main_argc_argv, not main: clang *renames*
   C's argc/argv [main] to that when it compiles C for wasm32, and the .ll
   Emit writes says @main literally. Without this the link succeeds and the
   program traps at its first instruction on a signature-mismatched weak stub.
   The __asm__ label is load-bearing and must not be "simplified" away —
   spelling the callee [main] makes clang rename *that* too, and the shim
   becomes an infinite self-call that hangs rather than failing. *)
let wasm_main_source =
  "int flan_entry(int argc, char **argv) __asm__(\"main\");\n\
   int __main_argc_argv(int argc, char **argv) { return flan_entry(argc, argv); }\n"

(* What the compiler itself is, cheaply: its path, size and mtime. A clang
   upgrade changes one of those, so the key changes with it — without paying a
   [clang --version] subprocess on every build, which would cost most of what
   the cache buys. *)
let clang_stamp =
  lazy
    (let path =
       if Filename.is_relative clang then
         let dirs = String.split_on_char ':' (try Sys.getenv "PATH" with Not_found -> "") in
         (try List.find (fun d -> Sys.file_exists (Filename.concat d clang))
                dirs |> fun d -> Filename.concat d clang
          with Not_found -> clang)
       else clang
     in
     match Unix.stat path with
     | st -> Printf.sprintf "%s:%d:%f" path st.Unix.st_size st.Unix.st_mtime
     | exception Unix.Unix_error _ -> path)

(* Compile one C translation unit to an object file, reusing a cached one when
   the source text, the compiler and the flags are all unchanged. The key has
   to carry [opt] and [target]: the acceptance table builds the same programs
   at -O0 and -O2, and an -O2 object must not serve an -O0 build. *)
let compile_c ~opts ?tflags ~src ~name () =
  (* The whole flag list, not just the triple: on wasm32 the sysroot and the
     resource directory decide which headers and which builtins an object was
     built against, so repointing either must not serve a stale .o. *)
  let tflags = match tflags with Some f -> f | None -> target_flags opts in
  let key =
    Digest.to_hex
      (Digest.string
         (String.concat "\000"
            [ name; src; Lazy.force clang_stamp; opts.opt;
              String.concat " " tflags ]))
  in
  let obj = Filename.concat (cachedir ()) (key ^ ".o") in
  if not (Sys.file_exists obj) then begin
    let dir = workdir () in
    let c = Filename.concat dir name in
    write c src;
    (* A distinct temporary target, renamed into place, so two builds running
       at once cannot see a half-written object. *)
    let tmp = Printf.sprintf "%s.%d.tmp" obj (Unix.getpid ()) in
    let cmd =
      String.concat " "
        ([ Filename.quote clang; opts.opt; "-c" ] @ tflags
         @ [ Filename.quote c; "-o"; Filename.quote tmp ])
    in
    let code = Sys.command cmd in
    if code <> 0 then
      failwith (Printf.sprintf "%s failed (exit %d) on %s" clang code name);
    (try Unix.rename tmp obj with Unix.Unix_error _ -> ());
    (try Sys.remove c with Sys_error _ -> ())
  end;
  obj

(* [csrcs] and [lflags] come from the imported packages (see [Load]): the C
   shim a package binds through, and the arguments needed to link the library
   it binds to. *)
let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
      (p : Tast.program) ~out =
  (* A dev build is the REPL's, and the REPL reaches a running process through
     [-rdynamic] and [dlopen]. Neither exists on wasm32, so the combination is
     refused rather than quietly producing a module nothing can attach to. *)
  if wasm_target opts && opts.dev then
    failwith
      "wasm32: --dev is native only — the reload path is dlopen, which wasm32 \
       has no equivalent of";
  let tflags = target_flags opts in
  let dir = workdir () in
  let ll = Filename.concat dir (Filename.basename out ^ ".ll") in
  write ll (Emit.program ~checks:opts.checks ~dev:opts.dev p);
  (* [flan_dev.c] is compiled into every build, not only a dev one. Nothing in
     a release build calls into it — the compiler only emits a registry lookup
     for a name the host was not built with, which cannot arise without cells —
     but the agent package's C refers to it, and a package's C sources are
     collected whatever [main] does. Leaving it out made [flan build sand.flan]
     fail at the link with an undefined symbol, which reads as a compiler bug
     rather than as a missing flag. The table is BSS, so this costs address
     space and not binary size, and [-rdynamic] and the cells are still what
     [--dev] means. *)
  let cc src name = compile_c ~opts ~tflags ~src ~name () in
  let objs =
    cc Runtime_src.source "flan_rt.c"
    :: [ cc Runtime_src.dev_source "flan_dev.c" ]
    (* wasi-libc's entry point, which is not [main]. See [wasm_main_source]. *)
    @ (if wasm_target opts then [ cc wasm_main_source "flan_wasm_main.c" ] else [])
    (* The generated half of the FFI: one translation unit holding a typedef
       per struct that crosses and a wrapper per (declare-c ...), compiled
       exactly like a package's hand-written .c. It rides on the program
       rather than on a parameter so that every caller of [executable] carries
       it without having been changed to. See [Shim]. *)
    @ (match p.Tast.cshim with
       | [] -> []
       | parts ->
         [ cc (String.concat "" (List.map snd parts)) "flan_shim.c" ])
    @ List.map (fun c -> cc (read_file c) (Filename.basename c)) csrcs
  in
  let cmd =
    String.concat " "
      ([ Filename.quote clang; opts.opt; "-Wno-override-module" ]
       @ (if opts.dev then [ "-rdynamic" ] else [])
       @ tflags
       @ [ Filename.quote ll ]
       @ List.map Filename.quote objs
       @ lflags
       (* The prelude declares sqrtf, so every link needs libm. It goes here
          and not in the leading flags: the default --as-needed drops a
          library named before the object that wants it, so at -O2 this would
          appear to work — LLVM folds most sqrtf calls into the hardware
          instruction and the symbol never has to resolve — and the -O0 build,
          which emits the call, would fail at the link. Untested against
          --target=wasm32; wasi-libc ships libm.a as a stub because the
          symbols live in libc, so it should be inert there. *)
       @ [ "-lm" ]
       @ [ "-o"; Filename.quote out ])
  in
  let code = Sys.command cmd in
  if code <> 0 then
    failwith (Printf.sprintf "%s failed (exit %d); the IR is at %s" clang code ll);
  if not opts.keep then (try Sys.remove ll with Sys_error _ -> ());
  out

(* ── The dev path: one function into a loadable object ──────────────── *)

(* Step 1 of the dev loop (NEXT.md): [Emit.redefinition] text → a [.so] the
   running process can [dlopen]. This never invokes the clang driver — the
   driver is most of what a build costs and none of what it does is needed
   here, since the input is already IR and the output has no libc to find.

   [ld -shared] rather than [clang -shared] for the same reason. A shared
   object is allowed undefined symbols, which is the whole mechanism: the
   redefined function's calls to other Flan functions, to the globals and to
   the runtime are all left for the loader to bind back to the host.

   PIC has to be asked for. [llc] defaults to the static relocation model on
   this target, and the failure is at link time, not at codegen: "relocation
   R_X86_64_32S against ... can not be used when making a shared object". *)

let llc = try Sys.getenv "FLAN_LLC" with Not_found -> "llc"
let linker = try Sys.getenv "FLAN_LD" with Not_found -> "ld"

(* Times in milliseconds, per stage, because a single total does not say
   whether the number is worth chasing. *)
type timing = { llc_ms : float; link_ms : float }

let time f =
  let t0 = Unix.gettimeofday () in
  let x = f () in
  (x, (Unix.gettimeofday () -. t0) *. 1000.)

let run what cmd =
  let code = Sys.command cmd in
  if code <> 0 then failwith (Printf.sprintf "%s failed (exit %d)" what code)

let shared ?(opts = default) ~ir ~out () : timing =
  if wasm_target opts then
    failwith
      "wasm32: the reload path is native only — it is llc + ld -shared + \
       dlopen, and wasm32 has no dlopen";
  let dir = workdir () in
  let base = Filename.remove_extension (Filename.basename out) in
  let ll = Filename.concat dir (base ^ ".ll") in
  let obj = Filename.concat dir (base ^ ".o") in
  write ll ir;
  let (), llc_ms =
    time (fun () ->
      run llc
        (String.concat " "
           ([ Filename.quote llc; opts.opt; "-filetype=obj";
              "-relocation-model=pic" ]
            @ (match opts.target with None -> [] | Some t -> [ "-mtriple=" ^ t ])
            @ [ Filename.quote ll; "-o"; Filename.quote obj ])))
  in
  let (), link_ms =
    time (fun () ->
      run linker
        (String.concat " "
           [ Filename.quote linker; "-shared"; Filename.quote obj; "-o";
             Filename.quote out ]))
  in
  if not opts.keep then begin
    (try Sys.remove ll with Sys_error _ -> ());
    (try Sys.remove obj with Sys_error _ -> ())
  end;
  { llc_ms; link_ms }