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

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

(* 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 ~src ~name =
  let key =
    Digest.to_hex
      (Digest.string
         (String.concat "\000"
            [ name; src; Lazy.force clang_stamp; opts.opt;
              (match opts.target with None -> "" | Some t -> t) ]))
  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" ]
         @ (match opts.target with None -> [] | Some t -> [ "--target=" ^ t ])
         @ [ 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

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

(* [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 =
  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);
  let objs =
    compile_c ~opts ~src:Runtime_src.source ~name:"flan_rt.c"
    :: List.map
         (fun c ->
           compile_c ~opts ~src:(read_file c) ~name:(Filename.basename c))
         csrcs
  in
  let cmd =
    String.concat " "
      ([ Filename.quote clang; opts.opt; "-Wno-override-module" ]
       @ (if opts.dev then [ "-rdynamic" ] else [])
       @ (match opts.target with None -> [] | Some t -> [ "--target=" ^ t ])
       @ [ Filename.quote ll ]
       @ List.map Filename.quote objs
       @ lflags
       @ [ "-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 =
  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 }