2016-11-13 12:25:45 +00:00
|
|
|
open Import
|
2018-02-06 14:39:03 +00:00
|
|
|
open Fiber.O
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-27 19:06:12 +00:00
|
|
|
let () = Inline_tests.linkme
|
|
|
|
|
2017-02-23 14:58:18 +00:00
|
|
|
type setup =
|
|
|
|
{ build_system : Build_system.t
|
2018-04-23 05:43:20 +00:00
|
|
|
; stanzas : (Path.t * Jbuild.Scope_info.t * Jbuild.Stanzas.t) list String.Map.t
|
2017-02-25 02:38:41 +00:00
|
|
|
; contexts : Context.t list
|
2018-03-02 18:44:03 +00:00
|
|
|
; packages : Package.t Package.Name.Map.t
|
2017-09-29 15:06:29 +00:00
|
|
|
; file_tree : File_tree.t
|
2018-03-29 15:58:41 +00:00
|
|
|
; env : Env.t
|
2017-02-23 14:58:18 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
let package_install_file { packages; _ } pkg =
|
2018-03-02 18:44:03 +00:00
|
|
|
match Package.Name.Map.find packages pkg with
|
2017-02-23 14:58:18 +00:00
|
|
|
| None -> Error ()
|
2017-12-21 11:54:00 +00:00
|
|
|
| Some p ->
|
2018-02-25 16:35:25 +00:00
|
|
|
Ok (Path.relative p.path
|
|
|
|
(Utils.install_file ~package:p.name ~findlib_toolchain:None))
|
2017-02-23 14:58:18 +00:00
|
|
|
|
2018-03-29 15:58:41 +00:00
|
|
|
let setup_env ~capture_outputs =
|
2018-03-29 16:09:23 +00:00
|
|
|
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"
|
2018-03-29 15:58:41 +00:00
|
|
|
|
2018-01-19 08:50:06 +00:00
|
|
|
let setup ?(log=Log.no_log)
|
2018-03-31 01:52:18 +00:00
|
|
|
?external_lib_deps_mode
|
2018-04-24 20:25:27 +00:00
|
|
|
?workspace ?(workspace_file=Path.of_string "jbuild-workspace")
|
2017-03-29 15:51:48 +00:00
|
|
|
?only_packages
|
|
|
|
?extra_ignored_subtrees
|
2017-12-21 11:54:00 +00:00
|
|
|
?x
|
2018-01-25 19:07:46 +00:00
|
|
|
?ignore_promoted_rules
|
2018-03-29 15:58:41 +00:00
|
|
|
?(capture_outputs=true)
|
2017-03-29 15:51:48 +00:00
|
|
|
() =
|
2018-03-29 15:58:41 +00:00
|
|
|
let env = setup_env ~capture_outputs in
|
|
|
|
let conf =
|
|
|
|
Jbuild_load.load ?extra_ignored_subtrees ?ignore_promoted_rules ()
|
|
|
|
in
|
2017-03-02 18:21:19 +00:00
|
|
|
Option.iter only_packages ~f:(fun set ->
|
2018-03-02 18:44:03 +00:00
|
|
|
Package.Name.Set.iter set ~f:(fun pkg ->
|
|
|
|
if not (Package.Name.Map.mem conf.packages pkg) then
|
2018-03-03 13:41:29 +00:00
|
|
|
let pkg_name = Package.Name.to_string pkg in
|
2017-03-02 18:21:19 +00:00
|
|
|
die "@{<error>Error@}: I don't know about package %s \
|
2017-04-04 15:56:14 +00:00
|
|
|
(passed through --only-packages/--release)%s"
|
2018-03-03 13:41:29 +00:00
|
|
|
pkg_name
|
|
|
|
(hint pkg_name
|
|
|
|
(Package.Name.Map.keys conf.packages
|
|
|
|
|> List.map ~f:Package.Name.to_string))));
|
2017-02-25 02:38:41 +00:00
|
|
|
let workspace =
|
|
|
|
match workspace with
|
|
|
|
| Some w -> w
|
|
|
|
| None ->
|
2018-04-25 09:18:32 +00:00
|
|
|
if Path.exists workspace_file then
|
2017-12-21 11:54:00 +00:00
|
|
|
Workspace.load ?x workspace_file
|
2017-02-25 02:38:41 +00:00
|
|
|
else
|
2017-12-21 11:54:00 +00:00
|
|
|
{ merlin_context = Some "default"
|
|
|
|
; contexts = [Default [
|
|
|
|
match x with
|
|
|
|
| None -> Native
|
|
|
|
| Some x -> Named x
|
|
|
|
]]
|
|
|
|
}
|
2017-02-25 02:38:41 +00:00
|
|
|
in
|
2017-12-21 11:54:00 +00:00
|
|
|
|
2018-02-06 14:39:03 +00:00
|
|
|
Fiber.parallel_map workspace.contexts ~f:(fun ctx_def ->
|
|
|
|
let name = Workspace.Context.name ctx_def in
|
2018-03-29 15:58:41 +00:00
|
|
|
Context.create ctx_def ~env ~merlin:(workspace.merlin_context = Some name))
|
2017-02-25 00:28:10 +00:00
|
|
|
>>= fun contexts ->
|
2017-12-21 11:54:00 +00:00
|
|
|
let contexts = List.concat contexts in
|
|
|
|
List.iter contexts ~f:(fun (ctx : Context.t) ->
|
2018-03-06 14:56:24 +00:00
|
|
|
Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp
|
|
|
|
(Context.sexp_of_t ctx));
|
2018-02-07 11:38:21 +00:00
|
|
|
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
|
2018-01-19 08:50:06 +00:00
|
|
|
let build_system =
|
2018-02-07 11:38:21 +00:00
|
|
|
Build_system.create ~contexts ~file_tree:conf.file_tree ~hook
|
2018-01-19 08:50:06 +00:00
|
|
|
in
|
2017-12-21 11:54:00 +00:00
|
|
|
Gen_rules.gen conf
|
2018-01-19 08:50:06 +00:00
|
|
|
~build_system
|
2017-12-21 11:54:00 +00:00
|
|
|
~contexts
|
2017-03-02 18:21:19 +00:00
|
|
|
?only_packages
|
2018-03-31 01:52:18 +00:00
|
|
|
?external_lib_deps_mode
|
2018-01-19 08:50:06 +00:00
|
|
|
>>= fun stanzas ->
|
2018-02-07 11:38:21 +00:00
|
|
|
Scheduler.set_status_line_generator gen_status_line
|
|
|
|
>>>
|
2018-02-06 14:39:03 +00:00
|
|
|
Fiber.return
|
|
|
|
{ build_system
|
|
|
|
; stanzas
|
|
|
|
; contexts
|
|
|
|
; packages = conf.packages
|
|
|
|
; file_tree = conf.file_tree
|
2018-03-29 15:58:41 +00:00
|
|
|
; env
|
2018-02-06 14:39:03 +00:00
|
|
|
}
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-03-29 19:33:18 +00:00
|
|
|
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
|
|
|
|
|
2017-02-24 13:08:37 +00:00
|
|
|
let external_lib_deps ?log ~packages () =
|
2018-02-06 14:39:03 +00:00
|
|
|
Scheduler.go ?log
|
2018-03-31 01:52:18 +00:00
|
|
|
(setup () ~external_lib_deps_mode:true
|
2017-03-01 19:19:43 +00:00
|
|
|
>>| fun setup ->
|
2018-03-29 19:33:18 +00:00
|
|
|
let context = find_context_exn setup ~name:"default" in
|
2017-02-23 14:58:18 +00:00
|
|
|
let install_files =
|
|
|
|
List.map packages ~f:(fun pkg ->
|
|
|
|
match package_install_file setup pkg with
|
2018-03-29 19:33:18 +00:00
|
|
|
| Ok path -> Path.append context.build_dir path
|
2018-03-03 13:41:29 +00:00
|
|
|
| Error () -> die "Unknown package %S" (Package.Name.to_string pkg))
|
2017-02-23 14:58:18 +00:00
|
|
|
in
|
2018-04-23 05:43:20 +00:00
|
|
|
let stanzas = Option.value_exn (String.Map.find setup.stanzas "default") in
|
2018-03-29 19:33:18 +00:00
|
|
|
let internals = Jbuild.Stanzas.lib_names stanzas in
|
|
|
|
Path.Map.map
|
|
|
|
(Build_system.all_lib_deps setup.build_system
|
|
|
|
~request:(Build.paths install_files))
|
2018-04-23 05:43:20 +00:00
|
|
|
~f:(String.Map.filteri ~f:(fun name _ ->
|
2018-04-23 05:08:09 +00:00
|
|
|
not (String.Set.mem internals name))))
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2017-03-29 15:51:48 +00:00
|
|
|
let ignored_during_bootstrap =
|
|
|
|
Path.Set.of_list
|
|
|
|
(List.map ~f:Path.of_string
|
|
|
|
[ "test"
|
|
|
|
; "example"
|
|
|
|
])
|
|
|
|
|
2018-04-26 15:10:14 +00:00
|
|
|
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 ()
|
|
|
|
|
2017-02-21 15:09:58 +00:00
|
|
|
(* Called by the script generated by ../build.ml *)
|
|
|
|
let bootstrap () =
|
2018-02-25 16:35:25 +00:00
|
|
|
Colors.setup_err_formatter_colors ();
|
2017-02-21 15:09:58 +00:00
|
|
|
let main () =
|
|
|
|
let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
|
2017-05-07 19:48:10 +00:00
|
|
|
let subst () =
|
2018-02-06 14:39:03 +00:00
|
|
|
Scheduler.go (Watermarks.subst () ~name:"jbuilder");
|
2017-05-07 19:53:40 +00:00
|
|
|
exit 0
|
2017-05-07 19:48:10 +00:00
|
|
|
in
|
2018-02-07 11:38:21 +00:00
|
|
|
let display = ref None in
|
|
|
|
let display_mode =
|
|
|
|
Arg.Symbol
|
|
|
|
(List.map Config.Display.all ~f:fst,
|
|
|
|
fun s ->
|
|
|
|
display := Some (List.assoc s Config.Display.all))
|
|
|
|
in
|
2018-02-07 12:09:24 +00:00
|
|
|
let concurrency = ref None in
|
2018-04-26 15:10:14 +00:00
|
|
|
let concurrency_arg x =
|
|
|
|
match Config.Concurrency.of_string x with
|
|
|
|
| Error msg -> raise (Arg.Bad msg)
|
|
|
|
| Ok c -> concurrency := Some c
|
|
|
|
in
|
2017-02-24 12:19:02 +00:00
|
|
|
Arg.parse
|
2018-04-26 15:10:14 +00:00
|
|
|
[ "-j" , String concurrency_arg, "JOBS concurrency"
|
|
|
|
; "--dev" , Set Clflags.dev_mode , " set development mode"
|
|
|
|
; "--display" , display_mode , " set the display mode"
|
|
|
|
; "--subst" , Unit subst ,
|
2018-02-13 17:49:07 +00:00
|
|
|
" substitute watermarks in source files"
|
|
|
|
; "--debug-backtraces",
|
|
|
|
Set Clflags.debug_backtraces,
|
|
|
|
" always print exception backtraces"
|
2017-02-24 12:19:02 +00:00
|
|
|
]
|
|
|
|
anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
|
2017-06-08 08:59:43 +00:00
|
|
|
Clflags.debug_dep_path := true;
|
2018-02-15 14:04:00 +00:00
|
|
|
let config =
|
|
|
|
(* Only load the configuration with --dev *)
|
|
|
|
if !Clflags.dev_mode then
|
|
|
|
Config.load_user_config_file ()
|
|
|
|
else
|
|
|
|
Config.default
|
|
|
|
in
|
2018-02-07 11:38:21 +00:00
|
|
|
let config =
|
2018-02-07 12:09:24 +00:00
|
|
|
Config.merge config
|
|
|
|
{ display = !display
|
|
|
|
; concurrency = !concurrency
|
|
|
|
}
|
2018-02-07 11:38:21 +00:00
|
|
|
in
|
2018-02-15 14:04:00 +00:00
|
|
|
let config =
|
|
|
|
Config.adapt_display config
|
2018-02-25 16:35:25 +00:00
|
|
|
~output_is_a_tty:(Lazy.force Colors.stderr_supports_colors)
|
2018-02-15 14:04:00 +00:00
|
|
|
in
|
2018-02-07 11:38:21 +00:00
|
|
|
let log = Log.create ~display:config.display () in
|
|
|
|
Scheduler.go ~log ~config
|
2018-04-26 15:10:14 +00:00
|
|
|
(set_concurrency config
|
|
|
|
>>= fun () ->
|
|
|
|
setup ~log ~workspace:{ merlin_context = Some "default"
|
2018-01-19 08:50:06 +00:00
|
|
|
; contexts = [Default [Native]] }
|
2017-03-29 15:51:48 +00:00
|
|
|
~extra_ignored_subtrees:ignored_during_bootstrap
|
|
|
|
()
|
2017-02-26 20:53:32 +00:00
|
|
|
>>= fun { build_system = bs; _ } ->
|
2018-02-06 14:39:03 +00:00
|
|
|
Build_system.do_build bs
|
2018-01-19 08:50:06 +00:00
|
|
|
~request:(Build.path (Path.of_string "_build/default/jbuilder.install")))
|
2017-02-21 15:09:58 +00:00
|
|
|
in
|
2016-12-02 13:54:32 +00:00
|
|
|
try
|
|
|
|
main ()
|
2018-02-06 14:39:03 +00:00
|
|
|
with
|
|
|
|
| Fiber.Never -> exit 1
|
|
|
|
| exn ->
|
|
|
|
Report_error.report exn;
|
2016-12-02 13:54:32 +00:00
|
|
|
exit 1
|
2017-03-22 08:19:26 +00:00
|
|
|
|
2018-03-06 14:56:24 +00:00
|
|
|
let setup = setup ~extra_ignored_subtrees:Path.Set.empty
|
2017-08-04 07:59:35 +00:00
|
|
|
|
|
|
|
let find_context_exn t ~name =
|
|
|
|
match List.find t.contexts ~f:(fun c -> c.name = name) with
|
|
|
|
| Some ctx -> ctx
|
|
|
|
| None ->
|
2018-02-06 14:39:03 +00:00
|
|
|
die "@{<Error>Error@}: Context %S not found!@." name
|