295 lines
9.0 KiB
OCaml
295 lines
9.0 KiB
OCaml
open Import
|
|
open Fiber.O
|
|
|
|
let () = Inline_tests.linkme
|
|
|
|
type setup =
|
|
{ build_system : Build_system.t
|
|
; contexts : Context.t list
|
|
; scontexts : Super_context.t String_map.t
|
|
; packages : Package.t Package.Name.Map.t
|
|
; file_tree : File_tree.t
|
|
; env : Env.t
|
|
}
|
|
|
|
let package_install_file { packages; _ } pkg =
|
|
match Package.Name.Map.find packages pkg with
|
|
| None -> Error ()
|
|
| Some p ->
|
|
Ok (Path.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 Colors.stderr_supports_colors) then
|
|
Env.initial
|
|
else
|
|
Colors.setup_env_for_colors Env.initial
|
|
in
|
|
Env.add env ~var:"INSIDE_DUNE" ~value:"1"
|
|
|
|
let setup ?(log=Log.no_log)
|
|
?external_lib_deps_mode
|
|
?workspace ?workspace_file
|
|
?only_packages
|
|
?extra_ignored_subtrees
|
|
?x
|
|
?ignore_promoted_rules
|
|
?(capture_outputs=true)
|
|
?profile
|
|
() =
|
|
let env = setup_env ~capture_outputs in
|
|
let conf =
|
|
Jbuild_load.load ?extra_ignored_subtrees ?ignore_promoted_rules ()
|
|
in
|
|
Option.iter only_packages ~f:(fun set ->
|
|
Package.Name.Set.iter set ~f:(fun pkg ->
|
|
if not (Package.Name.Map.mem 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 conf.packages
|
|
|> List.map ~f:Package.Name.to_string))));
|
|
let workspace =
|
|
match workspace with
|
|
| Some w -> w
|
|
| None ->
|
|
match workspace_file with
|
|
| Some p ->
|
|
Workspace.load ?x ?profile p
|
|
| _ ->
|
|
match
|
|
List.find_map ["dune-workspace"; "jbuild-workspace"] ~f:(fun fn ->
|
|
let p = Path.of_string fn in
|
|
if Path.exists p then
|
|
Some p
|
|
else
|
|
None)
|
|
with
|
|
| Some p -> Workspace.load ?x ?profile p
|
|
| None ->
|
|
{ merlin_context = Some "default"
|
|
; contexts = [Default
|
|
{ targets = [
|
|
match x with
|
|
| None -> Native
|
|
| Some x -> Named x
|
|
]
|
|
; profile = Option.value profile ~default:"default"
|
|
}]
|
|
}
|
|
in
|
|
|
|
Fiber.parallel_map workspace.contexts ~f:(fun ctx_def ->
|
|
let name = Workspace.Context.name ctx_def in
|
|
Context.create ctx_def ~env ~merlin:(workspace.merlin_context = Some name))
|
|
>>= fun contexts ->
|
|
let contexts = List.concat contexts in
|
|
List.iter contexts ~f:(fun (ctx : Context.t) ->
|
|
Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp
|
|
(Context.sexp_of_t ctx));
|
|
let rule_done = ref 0 in
|
|
let rule_total = ref 0 in
|
|
let gen_status_line () =
|
|
Some (sprintf "Done: %u/%u" !rule_done !rule_total)
|
|
in
|
|
let hook (hook : Build_system.hook) =
|
|
match hook with
|
|
| Rule_started -> incr rule_total
|
|
| Rule_completed -> incr rule_done
|
|
in
|
|
let build_system =
|
|
Build_system.create ~contexts ~file_tree:conf.file_tree ~hook
|
|
in
|
|
Gen_rules.gen conf
|
|
~build_system
|
|
~contexts
|
|
?only_packages
|
|
?external_lib_deps_mode
|
|
>>= fun scontexts ->
|
|
Scheduler.set_status_line_generator gen_status_line
|
|
>>>
|
|
Fiber.return
|
|
{ build_system
|
|
; scontexts
|
|
; contexts
|
|
; packages = conf.packages
|
|
; file_tree = conf.file_tree
|
|
; env
|
|
}
|
|
|
|
let find_context_exn t ~name =
|
|
match List.find t.contexts ~f:(fun c -> c.name = name) with
|
|
| Some ctx -> ctx
|
|
| None ->
|
|
die "@{<Error>Error@}: Context %S not found!@." name
|
|
|
|
let external_lib_deps ?log ~packages () =
|
|
Scheduler.go ?log
|
|
(setup () ~external_lib_deps_mode:true
|
|
>>| fun setup ->
|
|
let context = find_context_exn setup ~name:"default" in
|
|
let install_files =
|
|
List.map packages ~f:(fun pkg ->
|
|
match package_install_file setup pkg with
|
|
| Ok path -> Path.append context.build_dir path
|
|
| Error () -> die "Unknown package %S" (Package.Name.to_string pkg))
|
|
in
|
|
let sctx = Option.value_exn (String.Map.find setup.scontexts "default") in
|
|
let internals = Super_context.internal_lib_names sctx in
|
|
Path.Map.map
|
|
(Build_system.all_lib_deps setup.build_system
|
|
~request:(Build.paths install_files))
|
|
~f:(String.Map.filteri ~f:(fun name _ ->
|
|
not (String.Set.mem internals name))))
|
|
|
|
let ignored_during_bootstrap =
|
|
Path.Set.of_list
|
|
(List.map ~f:Path.in_source
|
|
[ "test"
|
|
; "example"
|
|
])
|
|
|
|
let auto_concurrency =
|
|
let v = ref None in
|
|
fun ?(log=Log.no_log) () ->
|
|
match !v with
|
|
| Some n -> Fiber.return n
|
|
| None ->
|
|
(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 prog with
|
|
| None -> loop rest
|
|
| Some prog ->
|
|
Process.run_capture (Accept All) prog args ~env:Env.initial
|
|
>>= function
|
|
| Error _ -> loop rest
|
|
| Ok s ->
|
|
match int_of_string (String.trim s) with
|
|
| n -> Fiber.return n
|
|
| exception _ -> loop rest
|
|
in
|
|
loop commands)
|
|
>>| fun n ->
|
|
Log.infof log "Auto-detected concurrency: %d" n;
|
|
v := Some n;
|
|
n
|
|
|
|
let set_concurrency ?log (config : Config.t) =
|
|
(match config.concurrency with
|
|
| Fixed n -> Fiber.return n
|
|
| Auto -> auto_concurrency ?log ())
|
|
>>= fun n ->
|
|
if n >= 1 then
|
|
Scheduler.set_concurrency n
|
|
else
|
|
Fiber.return ()
|
|
|
|
(* Called by the script generated by ../build.ml *)
|
|
let bootstrap () =
|
|
Colors.setup_err_formatter_colors ();
|
|
Path.set_root Path.External.initial_cwd;
|
|
Path.set_build_dir (Path.Kind.of_string "_build");
|
|
let main () =
|
|
let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
|
|
let subst () =
|
|
Scheduler.go (Watermarks.subst () ~name:"dune");
|
|
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
|
|
Arg.parse
|
|
[ "-j" , String concurrency_arg, "JOBS concurrency"
|
|
; "--dev" , Unit (fun () -> profile := Some "dev"),
|
|
" set development mode"
|
|
; "--display" , display_mode , " set the display mode"
|
|
; "--subst" , Unit subst ,
|
|
" substitute watermarks in source files"
|
|
; "--debug-backtraces",
|
|
Set Clflags.debug_backtraces,
|
|
" always print exception backtraces"
|
|
]
|
|
anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
|
|
Clflags.debug_dep_path := true;
|
|
let config =
|
|
(* Only load the configuration with --dev *)
|
|
if !profile = Some "dev" then
|
|
Config.load_user_config_file ()
|
|
else
|
|
Config.default
|
|
in
|
|
let config =
|
|
Config.merge config
|
|
{ display = !display
|
|
; concurrency = !concurrency
|
|
}
|
|
in
|
|
let config =
|
|
Config.adapt_display config
|
|
~output_is_a_tty:(Lazy.force Colors.stderr_supports_colors)
|
|
in
|
|
let log = Log.create ~display:config.display () in
|
|
Scheduler.go ~log ~config
|
|
(set_concurrency config
|
|
>>= fun () ->
|
|
setup ~log ~workspace:{ merlin_context = Some "default"
|
|
; contexts = [Default { targets = [Native]
|
|
; profile =
|
|
Option.value !profile
|
|
~default:"default"
|
|
}
|
|
]
|
|
}
|
|
?profile:!profile
|
|
~extra_ignored_subtrees:ignored_during_bootstrap
|
|
()
|
|
>>= fun { build_system = bs; _ } ->
|
|
Build_system.do_build bs
|
|
~request:(Build.path (
|
|
Path.relative Path.build_dir "default/dune.install")))
|
|
in
|
|
try
|
|
main ()
|
|
with
|
|
| Fiber.Never -> exit 1
|
|
| exn ->
|
|
Report_error.report exn;
|
|
exit 1
|
|
|
|
let setup = setup ~extra_ignored_subtrees:Path.Set.empty
|
|
|
|
let find_context_exn t ~name =
|
|
match List.find t.contexts ~f:(fun c -> c.name = name) with
|
|
| Some ctx -> ctx
|
|
| None ->
|
|
die "@{<Error>Error@}: Context %S not found!@." name
|