<commit_before>open! Stdune
open Import
open Fiber.O

let () = Inline_tests.linkme

type workspace =
  { contexts : Context.t list
  ; conf     : Dune_load.conf
  ; env      : Env.t
  }

type build_system =
  { workspace    : workspace
  ; scontexts    : Super_context.t String.Map.t
  }

let package_install_file w pkg =
  match Package.Name.Map.find w.conf.packages pkg with
  | None -> Error ()
  | Some p ->
    Ok (Path.Source.relative p.path
          (Utils.install_file ~package:p.name ~findlib_toolchain:None))

let setup_env ~capture_outputs =
  let env =
    if capture_outputs || not (Lazy.force Ansi_color.stderr_supports_color) then
      Env.initial
    else
      Colors.setup_env_for_colors Env.initial
  in
  Env.add env ~var:"INSIDE_DUNE" ~value:"1"

let scan_workspace ?(log=Log.no_log)
      ?workspace ?workspace_file
      ?x
      ?ignore_promoted_rules
      ?(capture_outputs=true)
      ?profile
      ~ancestor_vcs
      () =
  let env = setup_env ~capture_outputs in
  let conf =
    Dune_load.load ?ignore_promoted_rules ~ancestor_vcs ()
  in
  let workspace =
    match workspace with
    | Some w -> w
    | None ->
      match workspace_file with
      | Some p ->
        if not (Path.exists p) then
          die "@{<error>Error@}: workspace file %s does not exist"
            (Path.to_string_maybe_quoted p);
        Workspace.load ?x ?profile p
      | None ->
        match
          let p = Path.of_string Workspace.filename in
          Option.some_if (Path.exists p) p
        with
        | Some p -> Workspace.load ?x ?profile p
        | None -> Workspace.default ?x ?profile ()
  in

  let+ contexts = Context.create ~env workspace in
  List.iter contexts ~f:(fun (ctx : Context.t) ->
    Log.infof log "@[<1>Dune context:@,%a@]@." Dyn.pp
      (Context.to_dyn ctx));
  { contexts
  ; conf
  ; env
  }

let init_build_system ?only_packages ?external_lib_deps_mode w =
  Option.iter only_packages ~f:(fun set ->
    Package.Name.Set.iter set ~f:(fun pkg ->
      if not (Package.Name.Map.mem w.conf.packages pkg) then
        let pkg_name = Package.Name.to_string pkg in
        die "@{<error>Error@}: I don't know about package %s \
             (passed through --only-packages/--release)%s"
          pkg_name
          (hint pkg_name
             (Package.Name.Map.keys w.conf.packages
              |> List.map ~f:Package.Name.to_string))));
  let rule_done  = ref 0 in
  let rule_total = ref 0 in
  let gen_status_line () =
    { Console.
      message = Some (Pp.verbatim
                        (sprintf "Done: %u/%u" !rule_done !rule_total))
    ; show_jobs = true
    }
  in
  let hook (hook : Build_system.hook) =
    match hook with
    | Rule_started   -> incr rule_total
    | Rule_completed -> incr rule_done
  in
  Build_system.reset ();
  Build_system.init ~contexts:w.contexts ~file_tree:w.conf.file_tree ~hook;
  Scheduler.set_status_line_generator gen_status_line;
  let+ scontexts =
    Gen_rules.gen w.conf
      ~contexts:w.contexts
      ?only_packages
      ?external_lib_deps_mode
  in
  { workspace = w; scontexts }

let auto_concurrency =
  let v = ref None in
  fun ?(log=Log.no_log) () ->
    match !v with
    | Some n -> Fiber.return n
    | None ->
      let+ n =
        (if Sys.win32 then
           match Env.get Env.initial "NUMBER_OF_PROCESSORS" with
           | None -> Fiber.return 1
           | Some s ->
             match int_of_string s with
             | exception _ -> Fiber.return 1
             | n -> Fiber.return n
         else
           let commands =
             [ "nproc", []
             ; "getconf", ["_NPROCESSORS_ONLN"]
             ; "getconf", ["NPROCESSORS_ONLN"]
             ]
           in
           let rec loop = function
             | [] -> Fiber.return 1
             | (prog, args) :: rest ->
               match Bin.which ~path:(Env.path Env.initial) prog with
               | None -> loop rest
               | Some prog ->
                 let* result =
                   Process.run_capture (Accept All) prog args ~env:Env.initial
                     ~stderr_to:(Process.Output.file Config.dev_null)
                 in
                 match result with
                 | Error _ -> loop rest
                 | Ok s ->
                   match int_of_string (String.trim s) with
                   | n -> Fiber.return n
                   | exception _ -> loop rest
           in
           loop commands)
      in
      Log.infof log "Auto-detected concurrency: %d" n;
      v := Some n;
      n

let set_concurrency ?log (config : Config.t) =
  let+ n =
    match config.concurrency with
    | Fixed n -> Fiber.return n
    | Auto    -> auto_concurrency ?log ()
  in
  if n >= 1 then Scheduler.set_concurrency n

(* Called by the script generated by ../build.ml *)
let bootstrap () =
  Colors.setup_err_formatter_colors ();
  Path.set_root Path.External.initial_cwd;
  Path.Build.set_build_dir (Path.Build.Kind.of_string "_boot");
  let main () =
    let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
    let subst () =
      let config : Config.t =
        { display     = Quiet
        ; concurrency = Fixed 1
        }
      in
      Scheduler.go ~config Watermarks.subst;
      exit 0
    in
    let display = ref None in
    let display_mode =
      Arg.Symbol
        (List.map Config.Display.all ~f:fst,
         fun s ->
           display := List.assoc Config.Display.all s)
    in
    let concurrency = ref None in
    let concurrency_arg x =
      match Config.Concurrency.of_string x with
      | Error msg -> raise (Arg.Bad msg)
      | Ok c -> concurrency := Some c
    in
    let profile = ref None in<commit_msg>Make bootstrap build promote .install files<commit_after>open! Stdune
open Import
open Fiber.O

let () = Inline_tests.linkme

type workspace =
  { contexts : Context.t list
  ; conf     : Dune_load.conf
  ; env      : Env.t
  }

type build_system =
  { workspace    : workspace
  ; scontexts    : Super_context.t String.Map.t
  }

let package_install_file w pkg =
  match Package.Name.Map.find w.conf.packages pkg with
  | None -> Error ()
  | Some p ->
    Ok (Path.Source.relative p.path
          (Utils.install_file ~package:p.name ~findlib_toolchain:None))

let setup_env ~capture_outputs =
  let env =
    if capture_outputs || not (Lazy.force Ansi_color.stderr_supports_color) then
      Env.initial
    else
      Colors.setup_env_for_colors Env.initial
  in
  Env.add env ~var:"INSIDE_DUNE" ~value:"1"

let scan_workspace ?(log=Log.no_log)
      ?workspace ?workspace_file
      ?x
      ?ignore_promoted_rules
      ?(capture_outputs=true)
      ?profile
      ~ancestor_vcs
      () =
  let env = setup_env ~capture_outputs in
  let conf =
    Dune_load.load ?ignore_promoted_rules ~ancestor_vcs ()
  in
  let workspace =
    match workspace with
    | Some w -> w
    | None ->
      match workspace_file with
      | Some p ->
        if not (Path.exists p) then
          die "@{<error>Error@}: workspace file %s does not exist"
            (Path.to_string_maybe_quoted p);
        Workspace.load ?x ?profile p
      | None ->
        match
          let p = Path.of_string Workspace.filename in
          Option.some_if (Path.exists p) p
        with
        | Some p -> Workspace.load ?x ?profile p
        | None -> Workspace.default ?x ?profile ()
  in

  let+ contexts = Context.create ~env workspace in
  List.iter contexts ~f:(fun (ctx : Context.t) ->
    Log.infof log "@[<1>Dune context:@,%a@]@." Dyn.pp
      (Context.to_dyn ctx));
  { contexts
  ; conf
  ; env
  }

let init_build_system ?only_packages ?external_lib_deps_mode w =
  Option.iter only_packages ~f:(fun set ->
    Package.Name.Set.iter set ~f:(fun pkg ->
      if not (Package.Name.Map.mem w.conf.packages pkg) then
        let pkg_name = Package.Name.to_string pkg in
        die "@{<error>Error@}: I don't know about package %s \
             (passed through --only-packages/--release)%s"
          pkg_name
          (hint pkg_name
             (Package.Name.Map.keys w.conf.packages
              |> List.map ~f:Package.Name.to_string))));
  let rule_done  = ref 0 in
  let rule_total = ref 0 in
  let gen_status_line () =
    { Console.
      message = Some (Pp.verbatim
                        (sprintf "Done: %u/%u" !rule_done !rule_total))
    ; show_jobs = true
    }
  in
  let hook (hook : Build_system.hook) =
    match hook with
    | Rule_started   -> incr rule_total
    | Rule_completed -> incr rule_done
  in
  Build_system.reset ();
  Build_system.init ~contexts:w.contexts ~file_tree:w.conf.file_tree ~hook;
  Scheduler.set_status_line_generator gen_status_line;
  let+ scontexts =
    Gen_rules.gen w.conf
      ~contexts:w.contexts
      ?only_packages
      ?external_lib_deps_mode
  in
  { workspace = w; scontexts }

let auto_concurrency =
  let v = ref None in
  fun ?(log=Log.no_log) () ->
    match !v with
    | Some n -> Fiber.return n
    | None ->
      let+ n =
        (if Sys.win32 then
           match Env.get Env.initial "NUMBER_OF_PROCESSORS" with
           | None -> Fiber.return 1
           | Some s ->
             match int_of_string s with
             | exception _ -> Fiber.return 1
             | n -> Fiber.return n
         else
           let commands =
             [ "nproc", []
             ; "getconf", ["_NPROCESSORS_ONLN"]
             ; "getconf", ["NPROCESSORS_ONLN"]
             ]
           in
           let rec loop = function
             | [] -> Fiber.return 1
             | (prog, args) :: rest ->
               match Bin.which ~path:(Env.path Env.initial) prog with
               | None -> loop rest
               | Some prog ->
                 let* result =
                   Process.run_capture (Accept All) prog args ~env:Env.initial
                     ~stderr_to:(Process.Output.file Config.dev_null)
                 in
                 match result with
                 | Error _ -> loop rest
                 | Ok s ->
                   match int_of_string (String.trim s) with
                   | n -> Fiber.return n
                   | exception _ -> loop rest
           in
           loop commands)
      in
      Log.infof log "Auto-detected concurrency: %d" n;
      v := Some n;
      n

let set_concurrency ?log (config : Config.t) =
  let+ n =
    match config.concurrency with
    | Fixed n -> Fiber.return n
    | Auto    -> auto_concurrency ?log ()
  in
  if n >= 1 then Scheduler.set_concurrency n

(* Called by the script generated by ../build.ml *)
let bootstrap () =
  Clflags.promote_install_files := true;
  Colors.setup_err_formatter_colors ();
  Path.set_root Path.External.initial_cwd;
  Path.Build.set_build_dir (Path.Build.Kind.of_string "_boot");
  let main () =
    let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
    let subst () =
      let config : Config.t =
        { display     = Quiet
        ; concurrency = Fixed 1
        }
      in
      Scheduler.go ~config Watermarks.subst;
      exit 0
    in
    let display = ref None in
    let display_mode =
      Arg.Symbol
        (List.map Config.Display.all ~f:fst,
         fun s ->
           display := List.assoc Config.Display.all s)
    in
    let concurrency = ref None in
    let concurrency_arg x =
      match Config.Concurrency.of_string x with
      | Error msg -> raise (Arg.Bad msg)
      | Ok c -> concurrency := Some c
    in
    let profile = ref None in
{'fraction_non_alphanumeric': 0.10128238680973567, 'fraction_numerical': 0.002093692750588851, 'mean_word_length': 1.90595690747782, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 79, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5232056', 'n_tokens_mistral': 3724, 'n_tokens_neox': 3606, 'n_words': 992}