Merge pull request #5362 from Vincent-lau/private/shul2/async-race

ocaml/message-switch/async/protocol_async.ml

@@ -35,7 +35,11 @@ module M = struct
 
     let any = Deferred.any
 
+    let all = Deferred.all
+
     let is_determined = Deferred.is_determined
+
+    let return_unit = Deferred.unit
   end
 
   let connect path =
@@ -98,6 +102,20 @@ module M = struct
       )
   end
 
+  module Condition = struct
+    open Async_kernel
+
+    type 'a t = 'a Condition.t
+
+    let create = Condition.create
+
+    let wait = Condition.wait
+
+    let broadcast = Condition.broadcast
+
+    let signal = Condition.signal
+  end
+
   module Clock = struct
     type timer = {cancel: unit Ivar.t}
 
@@ -120,3 +138,4 @@ end
 
 module Client = Message_switch_core.Make.Client (M)
 module Server = Message_switch_core.Make.Server (M)
+module Mtest = Message_switch_core.Mtest.Make (M)

ocaml/message-switch/async/protocol_async.mli

@@ -19,3 +19,5 @@ open Message_switch_core
 module Client : S.CLIENT with type 'a io = 'a Deferred.t
 
 module Server : S.SERVER with type 'a io = 'a Deferred.t
+
+module Mtest : Mtest.MTEST with type 'a io = 'a Deferred.t

ocaml/message-switch/core/dune

@@ -10,6 +10,7 @@
     sexplib0
     uri
     xapi-log
+    xapi-stdext-threads
   )
   (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))
 )

ocaml/message-switch/core/mtest.ml

@@ -0,0 +1,42 @@
+module type MTEST = sig
+  type +'a io
+
+  val mutex_provides_mutal_exclusion : unit -> unit io
+end
+
+module Make =
+functor
+  (M : S.BACKEND)
+  ->
+  struct
+    open M.IO
+
+    type 'a io = 'a M.IO.t
+
+    let ocaml_lock = Mutex.create ()
+
+    let mu = M.Mutex.create ()
+
+    let cond = M.Condition.create ()
+
+    let broadcast () = M.Condition.broadcast cond ()
+
+    let mutex_provides_mutal_exclusion () : unit io =
+      let promises =
+        List.init 100 (fun _ ->
+            M.Condition.wait cond >>= fun () ->
+            M.Mutex.with_lock mu (fun () ->
+                M.IO.return_unit >>= fun () ->
+                (* the with_lock implementation should ensure that only one
+                   monad can try to acquire this lock *)
+                assert (Mutex.try_lock ocaml_lock) ;
+                M.IO.return_unit >>= fun () ->
+                Mutex.unlock ocaml_lock ; M.IO.return_unit
+            )
+        )
+      in
+      broadcast () ;
+      ignore @@ all promises ;
+      Printf.printf "%s test.\n" (M.whoami ()) ;
+      M.IO.return_unit
+  end

ocaml/message-switch/core/s.ml

@@ -33,7 +33,11 @@ module type BACKEND = sig
 
     val any : 'a t list -> 'a t
 
+    val all : 'a t list -> 'a list t
+
     val is_determined : 'a t -> bool
+
+    val return_unit : unit t
   end
 
   val connect : string -> (IO.ic * IO.oc) IO.t
@@ -58,6 +62,18 @@ module type BACKEND = sig
     val with_lock : t -> (unit -> 'a IO.t) -> 'a IO.t
   end
 
+  module Condition : sig
+    type 'a t
+
+    val create : unit -> 'a t
+
+    val wait : 'a t -> 'a IO.t
+
+    val broadcast : 'a t -> 'a -> unit
+
+    val signal : 'a t -> 'a -> unit
+  end
+
   module Clock : sig
     type timer
 

ocaml/message-switch/core_test/dune

@@ -3,13 +3,43 @@
   (names
     client_unix_main
     server_unix_main
+    lock_test_async
+    lock_test_lwt
+  )
+  (modules 
+    client_unix_main
+    server_unix_main   
+    lock_test_async
+    lock_test_lwt
   )
   (libraries
     message-switch-unix
+    message-switch-core
+    message-switch-async
+    message-switch-lwt
     threads.posix
   )
 )
 
+(rule
+  (alias runtest)
+  (deps
+    lock_test_async.exe
+  )
+  (action (run ./lock_test_async.exe))
+  (package message-switch)
+)
+
+(rule
+  (alias runtest)
+  (deps
+    lock_test_lwt.exe
+  )
+  (action (run ./lock_test_lwt.exe))
+  (package message-switch)
+)
+
+
 (rule
   (alias runtest)
   (deps

ocaml/message-switch/core_test/lock_test_async.ml

@@ -0,0 +1,13 @@
+open Core
+open Async
+open Message_switch_async
+
+let ( >>= ) = Deferred.( >>= )
+
+let test_async_lock () = Protocol_async.Mtest.mutex_provides_mutal_exclusion ()
+
+let () =
+  don't_wait_for
+    (test_async_lock () >>= fun () -> shutdown 0 ; Deferred.return ())
+
+let () = never_returns (Scheduler.go ())

ocaml/message-switch/core_test/lock_test_lwt.ml

@@ -0,0 +1,5 @@
+open Message_switch_lwt
+
+let test_lwt_lock = Protocol_lwt.Mtest.mutex_provides_mutal_exclusion ()
+
+let () = Lwt_main.run test_lwt_lock

ocaml/message-switch/lwt/protocol_lwt.ml

@@ -31,7 +31,11 @@ module M = struct
 
     let any = Lwt.choose
 
+    let all = Lwt.all
+
     let is_determined t = Lwt.state t <> Lwt.Sleep
+
+    let return_unit = Lwt.return_unit
   end
 
   let connect path =
@@ -77,6 +81,18 @@ module M = struct
     let with_lock = Lwt_mutex.with_lock
   end
 
+  module Condition = struct
+    type 'a t = 'a Lwt_condition.t
+
+    let create = Lwt_condition.create
+
+    let signal = Lwt_condition.signal
+
+    let wait c = Lwt_condition.wait c
+
+    let broadcast = Lwt_condition.broadcast
+  end
+
   module Clock = struct
     type timer = unit Lwt.t
 
@@ -92,3 +108,4 @@ end
 
 module Client = Message_switch_core.Make.Client (M)
 module Server = Message_switch_core.Make.Server (M)
+module Mtest = Message_switch_core.Mtest.Make (M)

ocaml/message-switch/lwt/protocol_lwt.mli

@@ -19,3 +19,5 @@ open Message_switch_core
 module Client : S.CLIENT with type 'a io = 'a Lwt.t
 
 module Server : S.SERVER with type 'a io = 'a Lwt.t
+
+module Mtest : Mtest.MTEST with type 'a io = 'a Lwt.t

quality-gate.sh

@@ -25,10 +25,10 @@ verify-cert () {
 }
 
 mli-files () {
-  N=522
+  N=516
   # do not count ml files from the tests in ocaml/{tests/perftest/quicktest}
-  MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
-  MLS=$(git  ls-files -- '**/*.ml'  | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
+  MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
+  MLS=$(git  ls-files -- '**/*.ml'  | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
   num_mls_without_mlis=$(comm -23 <(sort <<<"$MLS") <(sort <<<"$MLIS") | wc -l)
   if [ "$num_mls_without_mlis" -eq "$N" ]; then
     echo "OK counted $num_mls_without_mlis .ml files without an .mli"