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 (52ms of the measured 68), and goes llc + ld -shared +
    dlopen instead for ~16ms. Nothing at milestone 2 needs it yet. *)

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] *)
}

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

(* 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 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" ]
       @ (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