diff --git a/CHANGES.md b/CHANGES.md index a1640c78..9560438d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -20,6 +20,9 @@ next `merge_into` field that were in `jbuild` files in sub-directories where incorectly interpreted (#264) +- Add support for locks in actions, for tests that can't be run + concurrently (#263) + 1.0+beta13 (05/09/2017) ----------------------- diff --git a/doc/jbuild.rst b/doc/jbuild.rst index 9b103b6b..c9067f66 100644 --- a/doc/jbuild.rst +++ b/doc/jbuild.rst @@ -301,6 +301,9 @@ See the `User actions`_ section for more details. rules is to generate default configuration files that may be generated by a configure script. +- ``(locks ())`` specify that the action must be run while + holding the following locks. See the `Locks`_ section for more details. + Note that contrary to makefiles or other build systems, user rules currently don't support patterns, such as a rule to produce ``%.y`` from ``%.x`` for any given ``%``. This might be supported in the future. @@ -426,6 +429,9 @@ The syntax is as follows: ```` and should be filtered out if ```` is filtered out from the command line, either with ``--only-packages `` or ``-p `` +- ``(locks ())`` specify that the action must be run while + holding the following locks. See the `Locks`_ section for more details. + The typical use of the ``alias`` stanza is to define tests: .. code:: scheme @@ -1026,6 +1032,56 @@ of your project. What you should write instead is: (deps (blah.mll)) (action (chdir ${ROOT} (run ocamllex -o ${@} ${<}))))) +Locks +----- + +Given two rules that are independant, Jbuilder will assume that there +associated action can be run concurrently. Two rules are considered +independant if none of them depend on the other, either directly or +through a chain of dependencies. This basic assumption allows to +parallelize the build. + +However, it is sometimes the case that two independant rules cannot be +executed concurrently. For instance this can happen for more +complicated tests. In order to prevent jbuilder from running the +actions at the same time, you can sepcify that both actions take the +same lock: + +.. code:: scheme + + (alias + ((name runtest) + (deps (foo)) + (locks (m)) + (action (run test.exe ${<})))) + + (alias + ((name runtest) + (deps (bar)) + (locks (m)) + (action (run test.exe ${<})))) + +Jbuilder will make sure that the executions of ``test.exe foo`` and +``test.exe bar`` are serialized. + +Although they don't live in the filesystem, lock names are interpreted +as file names. So for instance ``(with-lock m ...)`` in ``src/jbuild`` +and ``(with-lock ../src/m)`` in ``test/jbuild`` refer to the same +lock. + +Note also that locks are per build context. So if your workspace has +two build contexts setup, the same rule might still be executed +concurrently between the two build contexts. If you want a lock that +is global to all build contexts, simply use an absolute filename: + +.. code:: scheme + + (alias + ((name runtest) + (deps (foo)) + (locks (/tcp-port/1042)) + (action (run test.exe ${<})))) + .. _ocaml-syntax: OCaml syntax diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 3ab28a4b..de9b50ff 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -154,16 +154,18 @@ module Rule = struct ; targets : Target.t list ; sandbox : bool ; fallback : Jbuild.Rule.Fallback.t + ; locks : Path.t list ; loc : Loc.t option } let make ?(sandbox=false) ?(fallback=Jbuild.Rule.Fallback.Not_possible) - ?context ?loc build = + ?context ?(locks=[]) ?loc build = { context ; build ; targets = targets build ; sandbox ; fallback + ; locks ; loc } end diff --git a/src/build_interpret.mli b/src/build_interpret.mli index c1e76fb0..39ac5c20 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -16,6 +16,7 @@ module Rule : sig ; targets : Target.t list ; sandbox : bool ; fallback : Jbuild.Rule.Fallback.t + ; locks : Path.t list ; loc : Loc.t option } @@ -23,6 +24,7 @@ module Rule : sig : ?sandbox:bool -> ?fallback:Jbuild.Rule.Fallback.t -> ?context:Context.t + -> ?locks:Path.t list -> ?loc:Loc.t -> (unit, Action.t) Build.t -> t diff --git a/src/build_system.ml b/src/build_system.ml index 1219dcc2..5ec9745e 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -405,6 +405,16 @@ let make_local_parent_dirs t paths ~map_path = let sandbox_dir = Path.of_string "_build/.sandbox" +let locks : (Path.t, Future.Mutex.t) Hashtbl.t = Hashtbl.create 32 + +let rec with_locks mutexes ~f = + match mutexes with + | [] -> f () + | m :: mutexes -> + Future.Mutex.with_lock + (Hashtbl.find_or_add locks m ~f:(fun _ -> Future.Mutex.create ())) + (fun () -> with_locks mutexes ~f) + let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = let { Pre_rule. context @@ -412,6 +422,7 @@ let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = ; targets = target_specs ; sandbox ; fallback + ; locks ; loc } = pre_rule @@ -500,7 +511,8 @@ let compile_rule t ~all_targets_by_dir ?(copy_source=false) pre_rule = action in make_local_dirs t (Action.chdirs action); - Action.exec ~targets action >>| fun () -> + with_locks locks ~f:(fun () -> + Action.exec ~targets action) >>| fun () -> Option.iter sandbox_dir ~f:Path.rm_rf; (* All went well, these targets are no longer pending *) pending_targets := Pset.diff !pending_targets targets_to_remove; diff --git a/src/future.ml b/src/future.ml index ecdc0486..b6e12a42 100644 --- a/src/future.ml +++ b/src/future.ml @@ -98,6 +98,17 @@ let with_exn_handler f ~handler = handler exn bt; reraise exn +let finalize f ~finally = + let finalize = lazy(finally ()) in + with_exn_handler + (fun () -> + f () >>| fun x -> + Lazy.force finalize; + x) + ~handler:(fun exn _ -> + Lazy.force finalize; + reraise exn) + let both a b = a >>= fun a -> b >>= fun b -> @@ -134,6 +145,41 @@ let rec all_unit = function x >>= fun () -> all_unit l +type to_fill = To_fill : 'a Ivar.t * 'a -> to_fill + +let to_fill = Queue.create () + +module Mutex = struct + type t = + { mutable locked : bool + ; mutable waiters : unit Ivar.t Queue.t + } + + let lock t = + if t.locked then + create (fun ivar -> Queue.push ivar t.waiters) + else begin + t.locked <- true; + return () + end + + let unlock t = + assert t.locked; + if Queue.is_empty t.waiters then + t.locked <- false + else + Queue.push (To_fill (Queue.pop t.waiters, ())) to_fill + + let with_lock t f = + lock t >>= fun () -> + finalize f ~finally:(fun () -> unlock t) + + let create () = + { locked = false + ; waiters = Queue.create () + } +end + type accepted_codes = | These of int list | All @@ -655,6 +701,10 @@ module Scheduler = struct done; let job, status = Running_jobs.wait () in process_done job status; + while not (Queue.is_empty to_fill) do + let (To_fill (ivar, x)) = Queue.pop to_fill in + Ivar.fill ivar x + done; go_rec cwd log t let go ?(log=Log.no_log) t = diff --git a/src/future.mli b/src/future.mli index 1376fac2..aae9c0d4 100644 --- a/src/future.mli +++ b/src/future.mli @@ -15,6 +15,13 @@ val all_unit : unit t list -> unit t val with_exn_handler : (unit -> 'a) -> handler:(exn -> Printexc.raw_backtrace -> unit) -> 'a +module Mutex : sig + type 'a future = 'a t + type t + val create : unit -> t + val with_lock : t -> (unit -> 'a future) -> 'a future +end with type 'a future := 'a t + type accepted_codes = | These of int list | All diff --git a/src/gen_rules.ml b/src/gen_rules.ml index b3be7037..b0dbd779 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -549,6 +549,10 @@ module Gen(P : Params) = struct | User rules | +-----------------------------------------------------------------+ *) + let interpret_locks ~dir ~scope locks = + List.map locks ~f:(fun s -> + Path.relative dir (SC.expand_vars sctx ~dir ~scope s)) + let user_rule (rule : Rule.t) ~dir ~scope = let targets : SC.Action.targets = match rule.targets with @@ -556,6 +560,7 @@ module Gen(P : Params) = struct | Static fns -> Static (List.map fns ~f:(Path.relative dir)) in SC.add_rule sctx ~fallback:rule.fallback ~loc:rule.loc + ~locks:(interpret_locks ~dir ~scope rule.locks) (SC.Deps.interpret sctx ~scope ~dir rule.deps >>> SC.Action.run @@ -584,6 +589,7 @@ module Gen(P : Params) = struct Alias.add_deps (SC.aliases sctx) alias [digest_path]; let deps = SC.Deps.interpret sctx ~scope ~dir alias_conf.deps in SC.add_rule sctx + ~locks:(interpret_locks ~dir ~scope alias_conf.locks) (match alias_conf.action with | None -> deps diff --git a/src/jbuild.ml b/src/jbuild.ml index da7cb441..a2ca8ae4 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -724,6 +724,7 @@ module Rule = struct ; deps : Dep_conf.t list ; action : Action.Unexpanded.t ; fallback : Fallback.t + ; locks : String_with_vars.t list ; loc : Loc.t } @@ -734,18 +735,21 @@ module Rule = struct ; deps = [] ; action = Action.Unexpanded.t sexp ; fallback = No - ; loc = Loc.none + ; locks = [] + ; loc = Loc.none } | _ -> record (field "targets" (list file_in_current_dir) >>= fun targets -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> field "action" Action.Unexpanded.t >>= fun action -> + field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> field_b "fallback" >>= fun fallback -> return { targets = Static targets ; deps ; action ; fallback = if fallback then Yes else No + ; locks ; loc = Loc.none }) sexp @@ -767,6 +771,7 @@ module Rule = struct ; S.virt_var __POS__"<" ])) ; fallback = Not_possible + ; locks = [] ; loc }) @@ -782,6 +787,7 @@ module Rule = struct Run (S.virt_text __POS__ "ocamlyacc", [S.virt_var __POS__ "<"])) ; fallback = Not_possible + ; locks = [] ; loc }) end @@ -820,7 +826,8 @@ module Menhir = struct (S.virt_var __POS__ "ROOT", Run (S.virt_text __POS__ "menhir", t.flags @ [S.virt_var __POS__ "<"])) - ; fallback = Not_possible + ; fallback = Not_possible + ; locks = [] ; loc }) | Some merge_into -> @@ -840,6 +847,7 @@ module Menhir = struct ; [ S.virt_var __POS__ "!^" ] ])) ; fallback = Not_possible + ; locks = [] ; loc }] end @@ -869,9 +877,10 @@ end module Alias_conf = struct type t = - { name : string - ; deps : Dep_conf.t list - ; action : Action.Unexpanded.t option + { name : string + ; deps : Dep_conf.t list + ; action : Action.Unexpanded.t option + ; locks : String_with_vars.t list ; package : Package.t option } @@ -881,11 +890,13 @@ module Alias_conf = struct field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> field_o "package" (Scope.package pkgs) >>= fun package -> field_o "action" Action.Unexpanded.t >>= fun action -> + field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> return { name ; deps ; action ; package + ; locks }) end diff --git a/src/jbuild.mli b/src/jbuild.mli index a1988d91..5fe849c4 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -205,6 +205,7 @@ module Rule : sig ; deps : Dep_conf.t list ; action : Action.Unexpanded.t ; fallback : Fallback.t + ; locks : String_with_vars.t list ; loc : Loc.t } end @@ -218,9 +219,10 @@ end module Alias_conf : sig type t = - { name : string - ; deps : Dep_conf.t list - ; action : Action.Unexpanded.t option + { name : string + ; deps : Dep_conf.t list + ; action : Action.Unexpanded.t option + ; locks : String_with_vars.t list ; package : Package.t option } end diff --git a/src/super_context.ml b/src/super_context.ml index af523e72..cf3e2ec7 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -213,9 +213,12 @@ let create | _ -> Chdir (context.build_dir, action)) } -let add_rule t ?sandbox ?fallback ?loc build = +let add_rule t ?sandbox ?fallback ?locks ?loc build = let build = Build.O.(>>>) build t.chdir in - let rule = Build_interpret.Rule.make ?sandbox ?fallback ?loc ~context:t.context build in + let rule = + Build_interpret.Rule.make ?sandbox ?fallback ?locks ?loc + ~context:t.context build + in t.rules <- rule :: t.rules; t.known_targets_by_src_dir_so_far <- List.fold_left rule.targets ~init:t.known_targets_by_src_dir_so_far diff --git a/src/super_context.mli b/src/super_context.mli index a32ad691..23404c80 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -45,6 +45,7 @@ val add_rule : t -> ?sandbox:bool -> ?fallback:Jbuild.Rule.Fallback.t + -> ?locks:Path.t list -> ?loc:Loc.t -> (unit, Action.t) Build.t -> unit diff --git a/test/jbuild b/test/jbuild index c8bc2cbe..8a85ce36 100644 --- a/test/jbuild +++ b/test/jbuild @@ -21,3 +21,56 @@ (deps ((alias sleep5) (alias sleep4-and-fail) (alias sleep1-and-fail))))) + +;; execute this to test locks +;; +;; $ ./_build/default/bin/main.exe build -j10 @test/locks +;; + +(alias + ((name locks) + (deps ((glob_files *.{foo,bar}))) + (action (bash "\ +echo 'expected result: 10' +echo 'without locking:' $(< x) +echo 'with locking: ' $(< y) +rm -f *.{foo,bar} x y")))) + +(rule (with-stdout-to incr.ml (echo "\ +let fn = Sys.argv.(1) in +let x = + match open_in fn with + | ic -> + let x = int_of_string (input_line ic) in + close_in ic; + x + | exception _ -> 0 +in +Unix.sleepf 0.2; +Printf.fprintf (open_out fn) \"%d\\n\" (x + 1); +Printf.fprintf (open_out Sys.argv.(2)) \"%g\n%!\" (Sys.time ()) +"))) + +(executable ((name incr) (libraries (unix)))) + +(rule ((targets (01.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (02.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (03.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (04.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (05.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (06.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (07.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (08.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (09.foo)) (action (run ./incr.exe x ${@})))) +(rule ((targets (10.foo)) (action (run ./incr.exe x ${@})))) + +(rule ((targets (01.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (02.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (03.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (04.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (05.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (06.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (07.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (08.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (09.bar)) (action (run ./incr.exe y ${@})) (locks (m)))) +(rule ((targets (10.bar)) (action (run ./incr.exe y ${@})) (locks (m))))