diff --git a/CHANGES.md b/CHANGES.md index f9b798f8..c47c6c4a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -18,6 +18,9 @@ next - Fix a bug causing `jbuilder external-lib-deps` to crash (#723, @diml) +- `-j` now defaults to the number of processing units available rather + 4 (#726, @diml) + 1.0+beta20 (10/04/2018) ----------------------- diff --git a/bin/main.ml b/bin/main.ml index 8b0cfd55..68fe877c 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -95,6 +95,11 @@ module Scheduler = struct include Jbuilder.Scheduler let go ?log ~common fiber = + let fiber = + Main.set_concurrency ?log common.config + >>= fun () -> + fiber + in Scheduler.go ?log ~config:common.config fiber end @@ -274,8 +279,16 @@ let common = in let docs = copts_sect in let concurrency = + let arg = + Arg.conv + ((fun s -> + Result.map_error (Config.Concurrency.of_string s) + ~f:(fun s -> `Msg s)), + fun pp x -> + Format.pp_print_string pp (Config.Concurrency.to_string x)) + in Arg.(value - & opt (some int) None + & opt (some arg) None & info ["j"] ~docs ~docv:"JOBS" ~doc:{|Run no more than $(i,JOBS) commands simultaneously.|} ) diff --git a/src/config.ml b/src/config.ml index 97565326..30d274a9 100644 --- a/src/config.ml +++ b/src/config.ml @@ -41,12 +41,41 @@ module Display = struct let t = enum all end +module Concurrency = struct + type t = + | Fixed of int + | Auto + + let error = + Error "invalid concurrency value, must be 'auto' or a positive number" + + let of_string = function + | "auto" -> Ok Auto + | s -> + match int_of_string s with + | exception _ -> error + | n -> + if n >= 1 then + Ok (Fixed n) + else + error + + let t sexp = + match of_string (string sexp) with + | Ok t -> t + | Error msg -> of_sexp_error sexp msg + + let to_string = function + | Auto -> "auto" + | Fixed n -> string_of_int n +end + module type S = sig type 'a field type t = - { display : Display.t field - ; concurrency : int field + { display : Display.t field + ; concurrency : Concurrency.t field } end @@ -64,15 +93,15 @@ let merge t (partial : Partial.t) = } let default = - { display = if inside_dune then Quiet else Progress - ; concurrency = if inside_dune then 1 else 4 + { display = if inside_dune then Quiet else Progress + ; concurrency = if inside_dune then Fixed 1 else Auto } let t = record (field "display" Display.t ~default:default.display >>= fun display -> - field "jobs" int ~default:default.concurrency + field "jobs" Concurrency.t ~default:default.concurrency >>= fun concurrency -> return { display ; concurrency diff --git a/src/config.mli b/src/config.mli index ee7787e9..e82b847a 100644 --- a/src/config.mli +++ b/src/config.mli @@ -34,12 +34,21 @@ module Display : sig val all : (string * t) list end +module Concurrency : sig + type t = + | Fixed of int + | Auto + + val of_string : string -> (t, string) result + val to_string : t -> string +end + module type S = sig type 'a field type t = - { display : Display.t field - ; concurrency : int field + { display : Display.t field + ; concurrency : Concurrency.t field } end diff --git a/src/main.ml b/src/main.ml index 14fe46f9..f1c8a527 100644 --- a/src/main.ml +++ b/src/main.ml @@ -137,6 +137,56 @@ let ignored_during_bootstrap = ; "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 (); @@ -154,12 +204,16 @@ let bootstrap () = display := Some (List.assoc s Config.Display.all)) in let concurrency = ref None in - let set r x = r := Some x in + let concurrency_arg x = + match Config.Concurrency.of_string x with + | Error msg -> raise (Arg.Bad msg) + | Ok c -> concurrency := Some c + in Arg.parse - [ "-j" , Int (set concurrency), "JOBS concurrency" - ; "--dev" , Set Clflags.dev_mode , " set development mode" - ; "--display" , display_mode , " set the display mode" - ; "--subst" , Unit subst , + [ "-j" , String concurrency_arg, "JOBS concurrency" + ; "--dev" , Set Clflags.dev_mode , " set development mode" + ; "--display" , display_mode , " set the display mode" + ; "--subst" , Unit subst , " substitute watermarks in source files" ; "--debug-backtraces", Set Clflags.debug_backtraces, @@ -186,7 +240,9 @@ let bootstrap () = in let log = Log.create ~display:config.display () in Scheduler.go ~log ~config - (setup ~log ~workspace:{ merlin_context = Some "default" + (set_concurrency config + >>= fun () -> + setup ~log ~workspace:{ merlin_context = Some "default" ; contexts = [Default [Native]] } ~extra_ignored_subtrees:ignored_during_bootstrap () diff --git a/src/main.mli b/src/main.mli index 3c22f0b6..8b559d88 100644 --- a/src/main.mli +++ b/src/main.mli @@ -38,6 +38,9 @@ val find_context_exn : setup -> name:string -> Context.t (** Setup the environment *) val setup_env : capture_outputs:bool -> Env.t +(** Set the concurrency level according to the user configuration *) +val set_concurrency : ?log:Log.t -> Config.t -> unit Fiber.t + (**/**) (* This is used to bootstrap jbuilder itself. It is not part of the diff --git a/src/scheduler.ml b/src/scheduler.ml index 07aa2dea..7ec35f6d 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -62,7 +62,7 @@ type t = { log : Log.t ; original_cwd : string ; display : Config.Display.t - ; concurrency : int + ; mutable concurrency : int ; waiting_for_available_job : t Fiber.Ivar.t Queue.t ; mutable status_line : string ; mutable gen_status_line : unit -> string option @@ -95,6 +95,10 @@ let set_status_line_generator f = Fiber.Var.get_exn t_var >>| fun t -> t.gen_status_line <- f +let set_concurrency n = + Fiber.Var.get_exn t_var >>| fun t -> + t.concurrency <- n + let wait_for_available_job () = Fiber.Var.get_exn t_var >>= fun t -> if Running_jobs.count () < t.concurrency then @@ -162,7 +166,7 @@ let go ?(log=Log.no_log) ?(config=Config.default) ; gen_status_line ; original_cwd = cwd ; display = config.display - ; concurrency = config.concurrency + ; concurrency = (match config.concurrency with Auto -> 1 | Fixed n -> n) ; status_line = "" ; waiting_for_available_job = Queue.create () } diff --git a/src/scheduler.mli b/src/scheduler.mli index a073585c..ba67b5a8 100644 --- a/src/scheduler.mli +++ b/src/scheduler.mli @@ -18,6 +18,8 @@ val wait_for_process : int -> Unix.process_status Fiber.t (** Set the status line generator for the current scheduler *) val set_status_line_generator : (unit -> string option) -> unit Fiber.t +val set_concurrency : int -> unit Fiber.t + (** Scheduler informations *) type t