From fae08c79be3207741223ae259a3cbfaee18dae6d Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 7 Feb 2018 12:09:24 +0000 Subject: [PATCH] Allow to set the concurrency level from the config file --- Makefile | 4 ++-- bin/main.ml | 21 ++++++++++++--------- src/clflags.ml | 1 - src/clflags.mli | 3 --- src/config.ml | 34 +++++++++++++++++++++++++++++----- src/config.mli | 17 ++++++++++++++--- src/main.ml | 17 ++++++++++------- src/scheduler.ml | 26 +++++++++++++++----------- 8 files changed, 82 insertions(+), 41 deletions(-) diff --git a/Makefile b/Makefile index 1096d05b..265510d3 100644 --- a/Makefile +++ b/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 diff --git a/bin/main.ml b/bin/main.ml index 8a8eb672..a95cd0e0 100644 --- a/bin/main.ml +++ b/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 - | None -> config - | Some display -> { display } + Config.merge config + { 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 ] diff --git a/src/clflags.ml b/src/clflags.ml index c13d66d8..2fdac585 100644 --- a/src/clflags.ml +++ b/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 diff --git a/src/clflags.mli b/src/clflags.mli index 9dbf4286..60a452cf 100644 --- a/src/clflags.mli +++ b/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*) diff --git a/src/config.ml b/src/config.ml index 8207f3e1..bbb0ed42 100644 --- a/src/config.ml +++ b/src/config.ml @@ -38,18 +38,42 @@ module Display = struct let t = enum all end -type t = - { display : Display.t +module type S = sig + 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 -> - return { display }) + (field "display" Display.t ~default:default.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" diff --git a/src/config.mli b/src/config.mli index 50e2e73c..d7349d40 100644 --- a/src/config.mli +++ b/src/config.mli @@ -28,12 +28,23 @@ module Display : sig val all : (string * t) list end -type t = - { display : Display.t - } +module type S = sig + 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 diff --git a/src/main.ml b/src/main.ml index b1911129..b117a4aa 100644 --- a/src/main.ml +++ b/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" - ; "--dev" , Set Clflags.dev_mode , " set development mode" - ; "--display" , display_mode , " print detailed information about commands being run" - ; "--subst" , Unit subst , " substitute watermarks in source files" + [ "-j" , Int (set concurrency), "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" ] 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 - | None -> config - | Some display -> { display } + Config.merge config + { display = !display + ; concurrency = !concurrency + } in let log = Log.create ~display:config.display () in Scheduler.go ~log ~config diff --git a/src/scheduler.ml b/src/scheduler.ml index 8bde6734..a32be798 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -58,11 +58,13 @@ end = struct end type t = - { log : Log.t - ; original_cwd : string - ; display : Config.Display.t - ; mutable status_line : string - ; mutable gen_status_line : unit -> string option + { log : Log.t + ; original_cwd : string + ; display : Config.Display.t + ; concurrency : int + ; 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 + Fiber.Var.get_exn t_var >>= fun t -> + 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 - Fiber.Ivar.fill (Queue.pop waiting_for_available_job) t + (if not (Queue.is_empty t.waiting_for_available_job) then + 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 };