Add support for locks in rules

This is to allow users define more complicated tests without having
to resort to -j1.

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

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 (<lock-names>))`` 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:
   ``<name>`` and should be filtered out if ``<name>`` is filtered out from the
   command line, either with ``--only-packages <pkgs>`` or ``-p <pkgs>``
 
+- ``(locks (<lock-names>))`` 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

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

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

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;

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 =

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

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

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
 

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

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

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

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