Make -j default to the number of CPUs (#726)

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)
 -----------------------
 

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.|}
         )

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

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
 

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
          ()

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

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 ()
     }

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