duneboot.ml

(** {2 Command line} *)

let concurrency, verbose, _keep_generated_files, debug, secondary, force_byte_compilation =
  let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
  let concurrency = ref None in
  let verbose = ref false in
  let keep_generated_files = ref false in
  let prog = Filename.basename Sys.argv.(0) in
  let debug = ref false in
  let secondary = ref false in
  let force_byte_compilation = ref false in
  Arg.parse
    [ "-j", Int (fun n -> concurrency := Some n), "JOBS Concurrency"
    ; "--verbose", Set verbose, " Set the display mode"
    ; "--keep-generated-files", Set keep_generated_files, " Keep generated files"
    ; "--debug", Set debug, " Enable various debugging options"
    ; "--secondary", Set secondary, " Use the secondary compiler installation"
    ; ( "--force-byte-compilation"
      , Set force_byte_compilation
      , " Force bytecode compilation even if ocamlopt is available" )
    ]
    anon
    (Printf.sprintf "Usage: %s <options>\nOptions are:" prog);
  ( !concurrency
  , !verbose
  , !keep_generated_files
  , !debug
  , !secondary
  , !force_byte_compilation )
;;

(** {2 General configuration} *)

let build_dir = "_boot"

type task =
  { target : string * string
  ; external_libraries : string list
  ; local_libraries : (string * string option * bool * string option) list
  }

let task =
  { target = "dune", "bin/main.ml"
  ; external_libraries = Libs.external_libraries
  ; local_libraries = Libs.local_libraries
  }
;;

(** {2 Utility functions} *)

open StdLabels
open Printf
module StringSet = Set.Make (String)
module StringMap = Map.Make (String)

module List = struct
  include List

  let rec filter_map l ~f =
    match l with
    | [] -> []
    | x :: l ->
      (match f x with
       | None -> filter_map l ~f
       | Some x -> x :: filter_map l ~f)
  ;;
end

let ( ^/ ) = Filename.concat

let fatal fmt =
  ksprintf
    (fun s ->
      prerr_endline s;
      exit 2)
    fmt
;;

module Status_line = struct
  let num_jobs = ref 0
  let num_jobs_finished = ref 0
  let displayed = ref ""

  let display_status_line =
    Unix.(isatty stdout)
    ||
    match Sys.getenv "INSIDE_EMACS" with
    | (_ : string) -> true
    | exception Not_found -> false
  ;;

  let update jobs =
    if display_status_line && !num_jobs > 0
    then (
      let new_displayed =
        sprintf "Done: %d/%d (jobs: %d)" !num_jobs_finished !num_jobs jobs
      in
      Printf.printf "\r%*s\r%s%!" (String.length !displayed) "" new_displayed;
      displayed := new_displayed)
  ;;

  let () = at_exit (fun () -> Printf.printf "\r%*s\r" (String.length !displayed) "")
end

(* Return list of entries in [path] as [path/entry] *)
let readdir path =
  Array.fold_right
    ~f:(fun entry dir -> (path ^/ entry) :: dir)
    ~init:[]
    (Sys.readdir path)
;;

let open_out file =
  if Sys.file_exists file then fatal "%s already exists" file;
  open_out file
;;

let input_lines ic =
  let rec loop ic acc =
    match input_line ic with
    | line -> loop ic (line :: acc)
    | exception End_of_file -> List.rev acc
  in
  loop ic []
;;

let read_lines fn =
  let ic = open_in fn in
  let lines = input_lines ic in
  close_in ic;
  lines
;;

let read_file fn =
  let ic = open_in_bin fn in
  let s = really_input_string ic (in_channel_length ic) in
  close_in ic;
  s
;;

let split_lines s =
  let rec loop ~last_is_cr ~acc i j =
    if j = String.length s
    then (
      let acc =
        if j = i || (j = i + 1 && last_is_cr)
        then acc
        else String.sub s ~pos:i ~len:(j - i) :: acc
      in
      List.rev acc)
    else (
      match s.[j] with
      | '\r' -> loop ~last_is_cr:true ~acc i (j + 1)
      | '\n' ->
        let line =
          let len = if last_is_cr then j - i - 1 else j - i in
          String.sub s ~pos:i ~len
        in
        loop ~acc:(line :: acc) (j + 1) (j + 1) ~last_is_cr:false
      | _ -> loop ~acc i (j + 1) ~last_is_cr:false)
  in
  loop ~acc:[] 0 0 ~last_is_cr:false
;;

(* copy a file - fails if the file exists *)
let copy ?(header = "") directive a b =
  if Sys.file_exists b then fatal "%s already exists" b;
  let ic = open_in_bin a in
  let len = in_channel_length ic in
  let s = really_input_string ic len in
  close_in ic;
  let oc = open_out_bin b in
  output_string oc header;
  fprintf oc "#%s 1 %S\n" directive a;
  output_string oc s;
  close_out oc
;;

let path_sep = if Sys.win32 then ';' else ':'

let split_path s =
  let rec loop i j =
    if j = String.length s
    then [ String.sub s ~pos:i ~len:(j - i) ]
    else if s.[j] = path_sep
    then String.sub s ~pos:i ~len:(j - i) :: loop (j + 1) (j + 1)
    else loop i (j + 1)
  in
  loop 0 0
;;

let path =
  match Sys.getenv "PATH" with
  | exception Not_found -> []
  | s -> split_path s
;;

let find_prog ~f =
  let rec search = function
    | [] -> None
    | dir :: rest ->
      (match f dir with
       | None -> search rest
       | Some fn -> Some (dir, fn))
  in
  search path
;;

let exe = if Sys.win32 then ".exe" else ""

(** {2 Concurrency level} *)

let concurrency =
  let try_run_and_capture_line (prog, args) =
    match
      find_prog ~f:(fun dir -> if Sys.file_exists (dir ^/ prog) then Some prog else None)
    with
    | None -> None
    | Some (dir, prog) ->
      let path = dir ^/ prog in
      let args = Array.of_list @@ (path :: args) in
      let ic, oc, ec = Unix.open_process_args_full path args (Unix.environment ()) in
      let line =
        match input_line ic with
        | s -> Some s
        | exception End_of_file -> None
      in
      (match Unix.close_process_full (ic, oc, ec), line with
       | WEXITED 0, Some s -> Some s
       | _ -> None)
  in
  match concurrency with
  | Some n -> n
  | None ->
    (* If no [-j] was given, try to autodetect the number of processors *)
    if Sys.win32
    then (
      match Sys.getenv_opt "NUMBER_OF_PROCESSORS" with
      | None -> 1
      | Some s ->
        (match int_of_string s with
         | exception _ -> 1
         | n -> n))
    else (
      let commands =
        [ "nproc", []
        ; "getconf", [ "_NPROCESSORS_ONLN" ]
        ; "getconf", [ "NPROCESSORS_ONLN" ]
        ]
      in
      let rec loop = function
        | [] -> 1
        | cmd :: rest ->
          (match try_run_and_capture_line cmd with
           | None -> loop rest
           | Some s ->
             (match int_of_string (String.trim s) with
              | n -> n
              | exception _ -> loop rest))
      in
      loop commands)
;;

(** {2 Fibers} *)

module Fiber : sig
  (** Fibers *)

  (** This module is similar to the one in [../src/fiber] except that it is much
      less optimised and much easier to understand. You should look at the
      documentation of the other module to understand the API. *)

  type 'a t

  val return : 'a -> 'a t

  module O : sig
    val ( >>> ) : unit t -> 'a t -> 'a t
    val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
    val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
  end

  module Future : sig
      type 'a fiber
      type 'a t

      val wait : 'a t -> 'a fiber
    end
    with type 'a fiber := 'a t

  val fork : (unit -> 'a t) -> 'a Future.t t
  val fork_and_join : (unit -> 'a t) -> (unit -> 'b t) -> ('a * 'b) t
  val fork_and_join_unit : (unit -> unit t) -> (unit -> 'a t) -> 'a t
  val parallel_map : 'a list -> f:('a -> 'b t) -> 'b list t
  val parallel_iter : 'a list -> f:('a -> unit t) -> unit t

  module Process : sig
    val run : ?cwd:string -> string -> string list -> unit t
    val run_and_capture : ?cwd:string -> string -> string list -> string t
    val try_run_and_capture : ?cwd:string -> string -> string list -> string option t
  end

  val run : 'a t -> 'a
end = struct
  open MoreLabels

  type 'a t = ('a -> unit) -> unit

  let return x k = k x

  module O = struct
    let ( >>> ) a b k = a (fun () -> b k)
    let ( >>= ) t f k = t (fun x -> f x k)
    let ( >>| ) t f k = t (fun x -> k (f x))
  end

  open O

  let both a b = a >>= fun a -> b >>= fun b -> return (a, b)

  module Ivar = struct
    type 'a state =
      | Full of 'a
      | Empty of ('a -> unit) Queue.t

    type 'a t = { mutable state : 'a state }

    let create () = { state = Empty (Queue.create ()) }

    let fill t x =
      match t.state with
      | Full _ -> failwith "Fiber.Ivar.fill"
      | Empty q ->
        t.state <- Full x;
        Queue.iter (fun f -> f x) q
    ;;

    let read t k =
      match t.state with
      | Full x -> k x
      | Empty q -> Queue.push k q
    ;;
  end

  module Future = struct
    type 'a t = 'a Ivar.t

    let wait = Ivar.read
  end

  let fork f k =
    let ivar = Ivar.create () in
    f () (fun x -> Ivar.fill ivar x);
    k ivar
  ;;

  let fork_and_join f g =
    fork f >>= fun a -> fork g >>= fun b -> both (Future.wait a) (Future.wait b)
  ;;

  let fork_and_join_unit f g =
    fork f >>= fun a -> fork g >>= fun b -> Future.wait a >>> Future.wait b
  ;;

  let rec parallel_map l ~f =
    match l with
    | [] -> return []
    | x :: l ->
      fork (fun () -> f x)
      >>= fun future ->
      parallel_map l ~f >>= fun l -> Future.wait future >>= fun x -> return (x :: l)
  ;;

  let rec parallel_iter l ~f =
    match l with
    | [] -> return ()
    | x :: l ->
      fork (fun () -> f x)
      >>= fun future -> parallel_iter l ~f >>= fun () -> Future.wait future
  ;;

  module Temp = struct
    module Files = Set.Make (String)

    let tmp_files = ref Files.empty

    let () =
      at_exit (fun () ->
        let fns = !tmp_files in
        tmp_files := Files.empty;
        Files.iter fns ~f:(fun fn ->
          try Sys.remove fn with
          | _ -> ()))
    ;;

    let file prefix suffix =
      let fn = Filename.temp_file prefix suffix in
      tmp_files := Files.add fn !tmp_files;
      fn
    ;;

    let destroy_file fn =
      (try Sys.remove fn with
       | _ -> ());
      tmp_files := Files.remove fn !tmp_files
    ;;
  end

  module Process = struct
    let running = Hashtbl.create concurrency

    exception Finished of int * Unix.process_status

    let rec wait_win32 () =
      match
        Hashtbl.iter running ~f:(fun ~key:pid ~data:_ ->
          let pid, status = Unix.waitpid [ WNOHANG ] pid in
          if pid <> 0 then raise_notrace (Finished (pid, status)))
      with
      | () ->
        ignore (Unix.select [] [] [] 0.001);
        wait_win32 ()
      | exception Finished (pid, status) -> pid, status
    ;;

    let wait = if Sys.win32 then wait_win32 else Unix.wait
    let waiting_for_slot = Queue.create ()

    let throttle () =
      if Hashtbl.length running >= concurrency
      then (
        let ivar = Ivar.create () in
        Queue.push ivar waiting_for_slot;
        Ivar.read ivar)
      else return ()
    ;;

    let restart_throttled () =
      while
        Hashtbl.length running < concurrency && not (Queue.is_empty waiting_for_slot)
      do
        Ivar.fill (Queue.pop waiting_for_slot) ()
      done
    ;;

    let open_temp_file () =
      let out = Temp.file "duneboot-" ".output" in
      let fd = Unix.openfile out [ O_WRONLY; O_CREAT; O_TRUNC; O_SHARE_DELETE ] 0o666 in
      out, fd
    ;;

    let read_temp fn =
      let s = read_file fn in
      Temp.destroy_file fn;
      s
    ;;

    let initial_cwd = Sys.getcwd ()

    let run_process ?cwd prog args ~split =
      throttle ()
      >>= fun () ->
      let stdout_fn, stdout_fd = open_temp_file () in
      let stderr_fn, stderr_fd =
        if split then open_temp_file () else stdout_fn, stdout_fd
      in
      (match cwd with
       | Some x -> Sys.chdir x
       | None -> ());
      let pid =
        Unix.create_process
          prog
          (Array.of_list (prog :: args))
          Unix.stdin
          stdout_fd
          stderr_fd
      in
      (match cwd with
       | Some _ -> Sys.chdir initial_cwd
       | None -> ());
      Unix.close stdout_fd;
      if split then Unix.close stderr_fd;
      let ivar = Ivar.create () in
      Hashtbl.add running ~key:pid ~data:ivar;
      Ivar.read ivar
      >>= fun (status : Unix.process_status) ->
      let stdout_s = read_temp stdout_fn in
      let stderr_s = if split then read_temp stderr_fn else stdout_s in
      if stderr_s <> "" || status <> WEXITED 0 || verbose
      then (
        let cmdline = String.concat ~sep:" " (prog :: args) in
        let cmdline =
          match cwd with
          | Some x -> sprintf "cd %s && %s" x cmdline
          | None -> cmdline
        in
        prerr_endline cmdline;
        prerr_string stderr_s;
        flush stderr);
      match status with
      | WEXITED 0 -> return (Ok stdout_s)
      | WEXITED n -> return (Error n)
      | WSIGNALED _ -> return (Error 255)
      | WSTOPPED _ -> assert false
    ;;

    let run ?cwd prog args =
      run_process ?cwd prog args ~split:false
      >>| function
      | Ok _ -> ()
      | Error n -> exit n
    ;;

    let run_and_capture ?cwd prog args =
      run_process ?cwd prog args ~split:true
      >>| function
      | Ok x -> x
      | Error n -> exit n
    ;;

    let try_run_and_capture ?cwd prog args =
      run_process ?cwd prog args ~split:true
      >>| function
      | Ok x -> Some x
      | Error _ -> None
    ;;
  end

  let run t =
    let result = ref None in
    t (fun x -> result := Some x);
    let rec loop () =
      if Hashtbl.length Process.running > 0
      then (
        Status_line.update (Hashtbl.length Process.running);
        let pid, status = Process.wait () in
        let ivar = Hashtbl.find Process.running pid in
        Hashtbl.remove Process.running pid;
        Ivar.fill ivar status;
        Process.restart_throttled ();
        loop ())
      else (
        match !result with
        | Some x -> x
        | None -> fatal "bootstrap got stuck!")
    in
    loop ()
  ;;
end

open Fiber.O
module Process = Fiber.Process

(** {2 OCaml tools} *)

module Mode = struct
  type t =
    | Byte
    | Native
end

module Config : sig
  val compiler : string
  val ocamldep : string
  val ocamllex : string
  val ocamlyacc : string
  val mode : Mode.t
  val ocaml_archive_ext : string
  val ocaml_config : unit -> string StringMap.t Fiber.t
  val output_complete_obj_arg : string
  val unix_library_flags : string list
end = struct
  let ocaml_version = Scanf.sscanf Sys.ocaml_version "%d.%d" (fun a b -> a, b)
  let prog_not_found prog = fatal "Program %s not found in PATH" prog

  let best_prog dir prog =
    let fn = dir ^/ prog ^ ".opt" ^ exe in
    if Sys.file_exists fn
    then Some fn
    else (
      let fn = dir ^/ prog ^ exe in
      if Sys.file_exists fn then Some fn else None)
  ;;

  let find_prog prog = find_prog ~f:(fun dir -> best_prog dir prog)

  let get_prog dir prog =
    match best_prog dir prog with
    | None -> prog_not_found prog
    | Some fn -> fn
  ;;

  let bin_dir, ocamlc =
    if secondary
    then (
      let s =
        Fiber.run
          (Process.run_and_capture
             "ocamlfind"
             [ "-toolchain"; "secondary"; "query"; "ocaml" ])
      in
      match split_lines s with
      | [] | _ :: _ :: _ -> fatal "Unexpected output locating secondary compiler"
      | [ bin_dir ] ->
        (match best_prog bin_dir "ocamlc" with
         | None -> fatal "Failed to locate secondary ocamlc"
         | Some x -> bin_dir, x))
    else (
      match find_prog "ocamlc" with
      | None -> prog_not_found "ocamlc"
      | Some x -> x)
  ;;

  let ocamlyacc = get_prog bin_dir "ocamlyacc"
  let ocamllex = get_prog bin_dir "ocamllex"
  let ocamldep = get_prog bin_dir "ocamldep"

  let compiler, mode, ocaml_archive_ext =
    match force_byte_compilation, best_prog bin_dir "ocamlopt" with
    | true, _ | _, None -> ocamlc, Mode.Byte, ".cma"
    | false, Some path -> path, Mode.Native, ".cmxa"
  ;;

  let ocaml_config () =
    Process.run_and_capture ocamlc [ "-config" ]
    >>| fun s ->
    List.fold_left (split_lines s) ~init:StringMap.empty ~f:(fun acc line ->
      match Scanf.sscanf line "%[^:]: %s" (fun k v -> k, v) with
      | k, v -> StringMap.add k v acc
      | exception _ ->
        fatal "invalid line in output of 'ocamlc -config': %s" (String.escaped line))
  ;;

  let output_complete_obj_arg =
    if ocaml_version < (4, 10) then "-custom" else "-output-complete-exe"
  ;;

  let unix_library_flags = if ocaml_version >= (5, 0) then [ "-I"; "+unix" ] else []
end

let insert_header fn ~header =
  match header with
  | "" -> ()
  | h ->
    let s = read_file fn in
    let oc = open_out_bin fn in
    output_string oc h;
    output_string oc s;
    close_out oc
;;

let copy_lexer ~header src dst =
  let dst = Filename.remove_extension dst ^ ".ml" in
  Process.run Config.ocamllex [ "-q"; "-o"; dst; src ]
  >>| fun () -> insert_header dst ~header
;;

let copy_parser ~header src dst =
  let dst = Filename.remove_extension dst in
  Process.run Config.ocamlyacc [ "-b"; dst; src ]
  >>| fun () ->
  insert_header (dst ^ ".ml") ~header;
  insert_header (dst ^ ".mli") ~header
;;

(** {2 Handling of the dune-build-info library} *)

(** {2 Preparation of library files} *)
module Build_info = struct
  let get_version () =
    let from_dune_project =
      match read_lines "dune-project" with
      | exception _ -> None
      | lines ->
        let rec loop = function
          | [] -> None
          | line :: lines ->
            (match Scanf.sscanf line "(version %[^)])" (fun v -> v) with
             | exception _ -> loop lines
             | v -> Some v)
        in
        loop lines
    in
    match from_dune_project with
    | Some _ -> Fiber.return from_dune_project
    | None ->
      if not (Sys.file_exists ".git")
      then Fiber.return None
      else
        Process.try_run_and_capture
          "git"
          [ "describe"; "--always"; "--dirty"; "--abbrev=7" ]
        >>| (function
         | Some s -> Some (String.trim s)
         | None -> None)
  ;;

  let gen_data_module oc =
    let pr fmt = fprintf oc fmt in
    let prlist name l ~f =
      match l with
      | [] -> pr "let %s = []\n" name
      | x :: l ->
        pr "let %s =\n" name;
        pr "  [ ";
        f x;
        List.iter l ~f:(fun x ->
          pr "  ; ";
          f x);
        pr "  ]\n"
    in
    get_version ()
    >>| fun version ->
    pr
      "let version = %s\n"
      (match version with
       | None -> "None"
       | Some v -> sprintf "Some %S" v);
    pr "\n";
    let libs =
      List.map task.local_libraries ~f:(fun (name, _, _, _) -> name, "version")
      @ List.map task.external_libraries ~f:(fun name ->
        name, {|Some "[distributed with OCaml]"|})
      |> List.sort ~cmp:(fun (a, _) (b, _) -> String.compare a b)
    in
    prlist "statically_linked_libraries" libs ~f:(fun (name, v) -> pr "%S, %s\n" name v)
  ;;
end

(* module OCaml_file = struct module Kind = struct type t = Impl | Intf end

   type t = { kind : Kind.t ; module_name = end *)

module Library = struct
  module File_kind = struct
    type t =
      | Header
      | C
      | Ml
      | Mli
      | Mll
      | Mly

    let analyse fn =
      let dn = Filename.dirname fn in
      let fn = Filename.basename fn in
      let i =
        try String.index fn '.' with
        | Not_found -> String.length fn
      in
      match String.sub fn ~pos:i ~len:(String.length fn - i) with
      | ".h" -> Some Header
      | ".c" -> Some C
      | ".ml" -> Some Ml
      | ".mli" -> Some Mli
      | ".mll" -> Some Mll
      | ".mly" -> Some Mly
      | ".defaults.ml" ->
        let fn' = String.sub fn ~pos:0 ~len:i ^ ".ml" in
        if Sys.file_exists (dn ^/ fn') then None else Some Ml
      | _ -> None
    ;;
  end

  module Wrapper = struct
    type t =
      { toplevel_module : string
      ; alias_module : string
      }

    let make ~namespace ~modules =
      match namespace with
      | None -> None
      | Some namespace ->
        let namespace = String.capitalize_ascii namespace in
        if StringSet.equal modules (StringSet.singleton namespace)
        then None
        else if StringSet.mem namespace modules
        then Some { toplevel_module = namespace; alias_module = namespace ^ "__" }
        else Some { toplevel_module = namespace; alias_module = namespace }
    ;;

    let mangle_filename t fn (kind : File_kind.t) =
      let base =
        let fn = Filename.basename fn in
        String.sub fn ~pos:0 ~len:(String.index fn '.') |> String.uncapitalize_ascii
      in
      match kind with
      | C -> base ^ ".c"
      | Header -> base ^ ".h"
      | _ ->
        let ext =
          match kind with
          | Mli -> ".mli"
          | _ -> ".ml"
        in
        (match t with
         | None -> base ^ ext
         | Some t ->
           if String.capitalize_ascii base = t.toplevel_module
           then base ^ ext
           else (
             let base = String.capitalize_ascii base in
             String.uncapitalize_ascii t.toplevel_module ^ "__" ^ base ^ ext))
    ;;

    let header t =
      match t with
      | None -> ""
      | Some t -> sprintf "open! %s\n" t.alias_module
    ;;

    let generate_wrapper t modules =
      match t with
      | None -> None
      | Some t ->
        let fn = String.uncapitalize_ascii t.alias_module ^ ".ml" in
        let oc = open_out (build_dir ^/ fn) in
        StringSet.iter
          (fun m ->
            if m <> t.toplevel_module
            then fprintf oc "module %s = %s__%s\n" m t.toplevel_module m)
          modules;
        close_out oc;
        Some fn
    ;;
  end

  (* Collect source files *)
  let scan ~dir ~scan_subdirs =
    let rec loop files acc =
      match files with
      | [] -> acc
      | file :: files ->
        let acc =
          if Sys.is_directory file
          then if scan_subdirs then loop (readdir file) acc else acc
          else (
            match File_kind.analyse file with
            | Some kind -> (file, kind) :: acc
            | None -> acc)
        in
        loop files acc
    in
    loop (readdir dir) []
  ;;

  let process (dir, namespace, scan_subdirs, build_info_module) =
    let files = scan ~dir ~scan_subdirs in
    let modules =
      List.fold_left files ~init:StringSet.empty ~f:(fun acc (fn, kind) ->
        match (kind : File_kind.t) with
        | Header | C -> acc
        | Ml | Mli | Mll | Mly ->
          let module_name =
            let fn = Filename.basename fn in
            String.sub fn ~pos:0 ~len:(String.index fn '.') |> String.capitalize_ascii
          in
          StringSet.add module_name acc)
    in
    let modules =
      match build_info_module with
      | None -> modules
      | Some m -> StringSet.add (String.capitalize_ascii m) modules
    in
    let wrapper = Wrapper.make ~namespace ~modules in
    let header = Wrapper.header wrapper in
    Fiber.fork_and_join
      (fun () ->
        Fiber.parallel_map files ~f:(fun (fn, kind) ->
          let mangled = Wrapper.mangle_filename wrapper fn kind in
          let dst = build_dir ^/ mangled in
          match kind with
          | Header | C ->
            copy "line" fn dst;
            Fiber.return [ mangled ]
          | Ml | Mli ->
            copy "" fn dst ~header;
            Fiber.return [ mangled ]
          | Mll -> copy_lexer fn dst ~header >>> Fiber.return [ mangled ]
          | Mly -> copy_parser fn dst ~header >>> Fiber.return [ mangled; mangled ^ "i" ]))
      (fun () ->
        match build_info_module with
        | None -> Fiber.return None
        | Some m ->
          let fn = String.uncapitalize_ascii m ^ ".ml" in
          let mangled = Wrapper.mangle_filename wrapper fn Ml in
          let oc = open_out (build_dir ^/ mangled) in
          Build_info.gen_data_module oc
          >>| fun () ->
          close_out oc;
          Some mangled)
    >>| fun (files, build_info_file) ->
    let files = List.concat files in
    let files =
      match build_info_file with
      | None -> files
      | Some fn -> fn :: files
    in
    let alias_file = Wrapper.generate_wrapper wrapper modules in
    let c_files, ocaml_files =
      List.partition files ~f:(fun fn -> Filename.extension fn = ".c")
    in
    ocaml_files, alias_file, c_files
  ;;
end

let ocamldep args =
  Process.run_and_capture Config.ocamldep ("-modules" :: args) ~cwd:build_dir
  >>| fun s ->
  List.map (split_lines s) ~f:(fun line ->
    let colon = String.index line ':' in
    let filename = String.sub line ~pos:0 ~len:colon in
    let modules =
      if colon = String.length line - 1
      then []
      else (
        let modules =
          String.sub line ~pos:(colon + 2) ~len:(String.length line - colon - 2)
        in
        String.split_on_char ~sep:' ' modules)
    in
    filename, modules)
  |> List.sort ~cmp:compare
;;

let mk_flags arg l = List.map l ~f:(fun m -> [ arg; m ]) |> List.flatten

let convert_dependencies ~all_source_files (file, dependencies) =
  let is_mli = Filename.check_suffix file ".mli" in
  let convert_module module_name =
    let filename = String.uncapitalize_ascii module_name in
    if filename = Filename.chop_extension file
    then (* Self-reference *)
      None
    else if StringSet.mem (filename ^ ".mli") all_source_files
    then
      if (not is_mli) && StringSet.mem (filename ^ ".ml") all_source_files
      then
        (* We need to build the .ml for inlining info *)
        Some [ filename ^ ".mli"; filename ^ ".ml" ]
      else (* .mli files never depend on .ml files *)
        Some [ filename ^ ".mli" ]
    else if StringSet.mem (filename ^ ".ml") all_source_files
    then
      (* If there's no .mli, then we must always depend on the .ml *)
      Some [ filename ^ ".ml" ]
    else (* This is a module coming from an external library *)
      None
  in
  let dependencies = List.concat (List.filter_map ~f:convert_module dependencies) in
  (* .ml depends on .mli, if it exists *)
  let dependencies =
    if (not is_mli) && StringSet.mem (file ^ "i") all_source_files
    then (file ^ "i") :: dependencies
    else dependencies
  in
  file, dependencies
;;

let write_args file args =
  let ch = open_out (build_dir ^/ file) in
  output_string ch (String.concat ~sep:"\n" args);
  close_out ch
;;

let get_dependencies libraries =
  let alias_files =
    List.fold_left libraries ~init:[] ~f:(fun acc (_, alias_file, _) ->
      match alias_file with
      | None -> acc
      | Some fn -> fn :: acc)
  in
  let all_source_files = List.map ~f:(fun (x, _, _) -> x) libraries |> List.concat in
  write_args "source_files" all_source_files;
  ocamldep (mk_flags "-map" alias_files @ [ "-args"; "source_files" ])
  >>| fun dependencies ->
  let all_source_files =
    List.fold_left
      alias_files
      ~init:(StringSet.of_list all_source_files)
      ~f:(fun acc fn -> StringSet.add fn acc)
  in
  let deps =
    List.rev_append
      ((* Alias files have no dependencies *)
       List.rev_map alias_files ~f:(fun fn -> fn, []))
      (List.rev_map dependencies ~f:(convert_dependencies ~all_source_files))
  in
  if debug
  then (
    eprintf "***** Dependencies *****\n";
    List.iter deps ~f:(fun (fn, deps) ->
      eprintf "%s: %s\n" fn (String.concat deps ~sep:" "));
    eprintf "**********\n");
  deps
;;

let assemble_libraries { local_libraries; target = _, main; _ } =
  let libraries =
    (* In order to assemble all the sources in one place, the executables
       modules are also put in a namespace *)
    let task_lib =
      let dir = Filename.dirname main in
      let namespace =
        String.capitalize_ascii (Filename.chop_extension (Filename.basename main))
      in
      dir, Some namespace, true (* enable (include_subdirs unqualified *), None
    in
    local_libraries @ [ task_lib ]
  in
  Fiber.parallel_map ~f:Library.process libraries
;;

type status =
  | Not_started of (unit -> unit Fiber.t)
  | Initializing
  | Started of unit Fiber.Future.t

let resolve_externals external_libraries =
  let external_libraries, external_includes =
    let convert = function
      | "threads" -> "threads" ^ Config.ocaml_archive_ext, [ "-I"; "+threads" ]
      | "unix" -> "unix" ^ Config.ocaml_archive_ext, Config.unix_library_flags
      | s -> fatal "unhandled external library %s" s
    in
    let externals = List.map ~f:convert external_libraries in
    List.split externals
  in
  let external_includes = List.concat external_includes in
  external_libraries, external_includes
;;

let sort_files dependencies ~main =
  let n = List.length dependencies in
  let deps_by_file = Hashtbl.create n in
  List.iter dependencies ~f:(fun (file, deps) -> Hashtbl.add deps_by_file file deps);
  let seen = ref StringSet.empty in
  let res = ref [] in
  let rec loop file =
    if not (StringSet.mem file !seen)
    then (
      seen := StringSet.add file !seen;
      List.iter (Hashtbl.find deps_by_file file) ~f:loop;
      res := file :: !res)
  in
  loop (Filename.basename main);
  List.rev !res
;;

let common_build_args name ~external_includes ~external_libraries =
  List.concat
    [ [ "-o"; Filename.concat "../_boot" (name ^ ".exe"); "-g" ]
    ; (match Config.mode with
       | Byte -> [ Config.output_complete_obj_arg ]
       | Native -> [])
    ; external_includes
    ; external_libraries
    ]
;;

let allow_unstable_sources = [ "-alert"; "-unstable" ]

let build
  ~ocaml_config
  ~dependencies
  ~c_files
  ~link_flags
  { target = name, main; external_libraries; _ }
  =
  let ext_obj =
    try StringMap.find "ext_obj" ocaml_config with
    | Not_found -> ".o"
  in
  let external_libraries, external_includes = resolve_externals external_libraries in
  let num_dependencies = List.length dependencies in
  let table = Hashtbl.create num_dependencies in
  Status_line.num_jobs := num_dependencies;
  let build m =
    match Hashtbl.find table m with
    | Not_started f ->
      Hashtbl.replace table m Initializing;
      Fiber.fork f
      >>= fun fut ->
      Hashtbl.replace table m (Started fut);
      Fiber.Future.wait fut >>| fun () -> incr Status_line.num_jobs_finished
    | Initializing -> fatal "dependency cycle!"
    | Started fut -> Fiber.Future.wait fut
    | exception Not_found -> fatal "file not found: %s" m
  in
  List.iter dependencies ~f:(fun (file, deps) ->
    Hashtbl.add
      table
      file
      (Not_started
         (fun () ->
           Fiber.parallel_iter deps ~f:build
           >>= fun () ->
           Process.run
             ~cwd:build_dir
             Config.compiler
             (List.concat
                [ [ "-c"; "-g"; "-no-alias-deps"; "-w"; "-49-6" ]
                ; allow_unstable_sources
                ; external_includes
                ; [ file ]
                ]))));
  Fiber.fork_and_join_unit
    (fun () -> build (Filename.basename main))
    (fun () ->
      Fiber.parallel_map c_files ~f:(fun file ->
        Process.run
          ~cwd:build_dir
          Config.compiler
          (List.concat [ [ "-c"; "-g" ]; external_includes; [ file ] ])
        >>| fun () -> Filename.chop_extension file ^ ext_obj))
  >>= fun obj_files ->
  let compiled_ml_ext =
    match Config.mode with
    | Byte -> ".cmo"
    | Native -> ".cmx"
  in
  let compiled_ml_files =
    List.filter_map (sort_files dependencies ~main) ~f:(fun fn ->
      match Filename.extension fn with
      | ".ml" -> Some (Filename.remove_extension fn ^ compiled_ml_ext)
      | _ -> None)
  in
  write_args "compiled_ml_files" compiled_ml_files;
  Process.run
    ~cwd:build_dir
    Config.compiler
    (List.concat
       [ common_build_args name ~external_includes ~external_libraries
       ; obj_files
       ; [ "-args"; "compiled_ml_files" ]
       ; link_flags
       ; allow_unstable_sources
       ])
;;

let build_with_single_command
  ~ocaml_config:_
  ~dependencies
  ~c_files
  ~link_flags
  { target = name, main; external_libraries; _ }
  =
  let external_libraries, external_includes = resolve_externals external_libraries in
  write_args "mods_list" (sort_files dependencies ~main);
  Process.run
    ~cwd:build_dir
    Config.compiler
    (List.concat
       [ common_build_args name ~external_includes ~external_libraries
       ; [ "-no-alias-deps"; "-w"; "-49-6" ]
       ; c_files
       ; [ "-args"; "mods_list" ] @ link_flags
       ; allow_unstable_sources
       ])
;;

let rec rm_rf fn =
  match Unix.lstat fn with
  | { st_kind = S_DIR; _ } ->
    clear fn;
    Unix.rmdir fn
  | _ -> Unix.unlink fn
  | exception Unix.Unix_error (ENOENT, _, _) -> ()

and clear dir = List.iter (readdir dir) ~f:rm_rf

(** {2 Bootstrap process} *)
let main () =
  (try clear build_dir with
   | Sys_error _ -> ());
  (try Unix.mkdir build_dir 0o777 with
   | Unix.Unix_error (Unix.EEXIST, _, _) -> ());
  Config.ocaml_config ()
  >>= fun ocaml_config ->
  assemble_libraries task
  >>= fun libraries ->
  let c_files = List.map ~f:(fun (_, _, c_files) -> c_files) libraries |> List.concat in
  get_dependencies libraries
  >>= fun dependencies ->
  let link_flags =
    match StringMap.find_opt "system" ocaml_config with
    | None -> assert false
    | Some platform ->
      (match List.assoc_opt platform Libs.link_flags with
       | None -> []
       | Some flags -> flags)
  in
  let build = if concurrency = 1 || Sys.win32 then build_with_single_command else build in
  build ~ocaml_config ~dependencies ~c_files ~link_flags task
;;

let () = Fiber.run (main ())