Allow to set the concurrency level from the config file

Makefile

@@ -4,10 +4,10 @@ BIN := ./_build/default/bin/main.exe
 -include Makefile.dev
 
 default: boot.exe
-	./boot.exe -j 4 --dev
+	./boot.exe --dev
 
 release: boot.exe
-	./boot.exe -j 4
+	./boot.exe
 
 boot.exe: bootstrap.ml
 	ocaml bootstrap.ml

bin/main.ml

@@ -8,8 +8,7 @@ open Fiber.O
 let () = suggest_function := Jbuilder_cmdliner.Cmdliner_suggest.value
 
 type common =
-  { concurrency           : int
+  { debug_dep_path        : bool
-  ; debug_dep_path        : bool
   ; debug_findlib         : bool
   ; debug_backtraces      : bool
   ; dev_mode              : bool
@@ -31,7 +30,6 @@ type common =
 let prefix_target common s = common.target_prefix ^ s
 
 let set_common c ~targets =
-  Clflags.concurrency := c.concurrency;
   Clflags.debug_dep_path := c.debug_dep_path;
   Clflags.debug_findlib := c.debug_findlib;
   Clflags.debug_backtraces := c.debug_backtraces;
@@ -231,12 +229,12 @@ let common =
       | Default    -> Config.load_user_config_file ()
     in
     let config =
-      match display with
+      Config.merge config
-      | None -> config
+        { display
-      | Some display -> { display }
+        ; concurrency
+        }
     in
-    { concurrency
+    { debug_dep_path
-    ; debug_dep_path
     ; debug_findlib
     ; debug_backtraces
     ; dev_mode
@@ -259,7 +257,7 @@ let common =
   let docs = copts_sect in
   let concurrency =
     Arg.(value
-         & opt int !Clflags.concurrency
+         & opt (some int) None
          & info ["j"] ~docs ~docv:"JOBS"
              ~doc:{|Run no more than $(i,JOBS) commands simultaneously.|}
         )
@@ -1281,6 +1279,11 @@ module Help = struct
                executed by Jbuilder, with some colors to help differentiate
                programs.|}
            ])
+    ; `S "JOBS"
+    ; `P {|Syntax: $(b,\(jobs NUMBER\))|}
+    ; `P {|Set the maximum number of jobs Jbuilder might run in parallel.
+           This can also be set from the command line via $(b,-j NUMBER).|}
+    ; `P {|The default for this value is 4.|}
     ; common_footer
     ]
 

src/clflags.ml

@@ -1,4 +1,3 @@
-let concurrency = ref 4
 (*let ocaml_comp_flags = ref ["-g"]*)
 let g = ref true
 let debug_findlib = ref false

src/clflags.mli

@@ -1,8 +1,5 @@
 (** Command line flags *)
 
-(** Concurrency *)
-val concurrency : int ref
-
 (** Compilation flags for OCaml files *)
 (*val ocaml_comp_flags : string list ref*)
 

src/config.ml

@@ -38,18 +38,42 @@ module Display = struct
   let t = enum all
 end
 
-type t =
+module type S = sig
-  { display : Display.t
+  type 'a field
+
+  type t =
+    { display     : Display.t field
+    ; concurrency : int       field
+    }
+end
+
+module rec M : S with type 'a field = 'a = M
+include M
+
+module rec Partial : S with type 'a field := 'a option = Partial
+
+let merge t (partial : Partial.t) =
+  let field from_t from_partial =
+    Option.value from_partial ~default:from_t
+  in
+  { display     = field t.display     partial.display
+  ; concurrency = field t.concurrency partial.concurrency
   }
 
 let default =
-  { display = Progress
+  { display     = Progress
+  ; concurrency = 4
   }
 
 let t =
   record
-    (field "display" Display.t >>= fun display ->
+    (field "display" Display.t ~default:default.display
-     return { display })
+     >>= fun display ->
+     field "jobs" int ~default:default.concurrency
+     >>= fun concurrency ->
+     return { display
+            ; concurrency
+            })
 
 let user_config_file = Filename.concat Xdg.config_dir "dune/config"
 

src/config.mli

@@ -28,12 +28,23 @@ module Display : sig
   val all : (string * t) list
 end
 
-type t =
+module type S = sig
-  { display : Display.t
+  type 'a field
-  }
+
+  type t =
+    { display     : Display.t field
+    ; concurrency : int       field
+    }
+end
+
+include S with type 'a field = 'a
+
+module Partial : S with type 'a field := 'a option
 
 val t : t Sexp.Of_sexp.t
 
+val merge : t -> Partial.t -> t
+
 val default : t
 val user_config_file : string
 val load_user_config_file : unit -> t

src/main.ml

@@ -126,19 +126,22 @@ let bootstrap () =
          fun s ->
            display := Some (List.assoc s Config.Display.all))
     in
+    let concurrency = ref None in
+    let set r x = r := Some x in
     Arg.parse
-      [ "-j"           , Set_int Clflags.concurrency, "JOBS concurrency"
+      [ "-j"           , Int (set concurrency), "JOBS concurrency"
-      ; "--dev"        , Set Clflags.dev_mode       , " set development mode"
+      ; "--dev"        , Set Clflags.dev_mode , " set development mode"
-      ; "--display"    , display_mode               , " print detailed information about commands being run"
+      ; "--display"    , display_mode         , " set the display mode"
-      ; "--subst"      , Unit subst                 , " substitute watermarks in source files"
+      ; "--subst"      , Unit subst           , " substitute watermarks in source files"
       ]
       anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
     Clflags.debug_dep_path := true;
     let config = Config.load_user_config_file () in
     let config =
-      match !display with
+      Config.merge config
-      | None -> config
+        { display     = !display
-      | Some display -> { display }
+        ; concurrency = !concurrency
+        }
     in
     let log = Log.create ~display:config.display () in
     Scheduler.go ~log ~config

src/scheduler.ml

@@ -58,11 +58,13 @@ end = struct
 end
 
 type t =
-  { log                     : Log.t
+  { log                       : Log.t
-  ; original_cwd            : string
+  ; original_cwd              : string
-  ; display                 : Config.Display.t
+  ; display                   : Config.Display.t
-  ; mutable status_line     : string
+  ; concurrency               : int
-  ; mutable gen_status_line : unit -> string option
+  ; waiting_for_available_job : t Fiber.Ivar.t Queue.t
+  ; mutable status_line       : string
+  ; mutable gen_status_line   : unit -> string option
   }
 
 let log t = t.log
@@ -92,13 +94,13 @@ let set_status_line_generator f =
   Fiber.Var.get_exn t_var >>| fun t ->
   t.gen_status_line <- f
 
-let waiting_for_available_job = Queue.create ()
 let wait_for_available_job () =
-  if Running_jobs.count () < !Clflags.concurrency then
+  Fiber.Var.get_exn t_var >>= fun t ->
-    Fiber.Var.get_exn t_var
+  if Running_jobs.count () < t.concurrency then
+    Fiber.return t
   else begin
     let ivar = Fiber.Ivar.create () in
-    Queue.push ivar waiting_for_available_job;
+    Queue.push ivar t.waiting_for_available_job;
     Fiber.Ivar.read ivar
   end
 
@@ -128,8 +130,8 @@ let rec go_rec t =
         t.status_line <- status_line;
     end;
     let job, status = Running_jobs.wait () in
-    (if not (Queue.is_empty waiting_for_available_job) then
+    (if not (Queue.is_empty t.waiting_for_available_job) then
-       Fiber.Ivar.fill (Queue.pop waiting_for_available_job) t
+       Fiber.Ivar.fill (Queue.pop t.waiting_for_available_job) t
      else
        Fiber.return ())
     >>= fun () ->
@@ -150,7 +152,9 @@ let go ?(log=Log.no_log) ?(config=Config.default)
     ; gen_status_line
     ; original_cwd = cwd
     ; display      = config.display
+    ; concurrency  = config.concurrency
     ; status_line  = ""
+    ; waiting_for_available_job = Queue.create ()
     }
   in
   printer := { print = fun fmt -> print t fmt };