diff --git a/ocaml/message-switch/async/protocol_async.ml b/ocaml/message-switch/async/protocol_async.ml index 8c81a1e66d0..5898d22f77f 100644 --- a/ocaml/message-switch/async/protocol_async.ml +++ b/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) diff --git a/ocaml/message-switch/async/protocol_async.mli b/ocaml/message-switch/async/protocol_async.mli index f691c24c989..d18b37b742c 100644 --- a/ocaml/message-switch/async/protocol_async.mli +++ b/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 diff --git a/ocaml/message-switch/core/dune b/ocaml/message-switch/core/dune index 4874cf7e439..6debbc895c7 100644 --- a/ocaml/message-switch/core/dune +++ b/ocaml/message-switch/core/dune @@ -10,6 +10,7 @@ sexplib0 uri xapi-log + xapi-stdext-threads ) (preprocess (pps ppx_deriving_rpc ppx_sexp_conv)) ) diff --git a/ocaml/message-switch/core/mtest.ml b/ocaml/message-switch/core/mtest.ml new file mode 100644 index 00000000000..3b8da9803fe --- /dev/null +++ b/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 diff --git a/ocaml/message-switch/core/s.ml b/ocaml/message-switch/core/s.ml index 726e34aea92..423304d1b24 100644 --- a/ocaml/message-switch/core/s.ml +++ b/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 diff --git a/ocaml/message-switch/core_test/dune b/ocaml/message-switch/core_test/dune index dd7d00472f8..449f2fae5c5 100644 --- a/ocaml/message-switch/core_test/dune +++ b/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 diff --git a/ocaml/message-switch/core_test/lock_test_async.ml b/ocaml/message-switch/core_test/lock_test_async.ml new file mode 100644 index 00000000000..85cde8eaecb --- /dev/null +++ b/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 ()) diff --git a/ocaml/message-switch/core_test/lock_test_lwt.ml b/ocaml/message-switch/core_test/lock_test_lwt.ml new file mode 100644 index 00000000000..784599dafa4 --- /dev/null +++ b/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 diff --git a/ocaml/message-switch/lwt/protocol_lwt.ml b/ocaml/message-switch/lwt/protocol_lwt.ml index 2ba53ed69cd..26c9c874d55 100644 --- a/ocaml/message-switch/lwt/protocol_lwt.ml +++ b/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) diff --git a/ocaml/message-switch/lwt/protocol_lwt.mli b/ocaml/message-switch/lwt/protocol_lwt.mli index c9bd220155d..64ca15c0e8e 100644 --- a/ocaml/message-switch/lwt/protocol_lwt.mli +++ b/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 diff --git a/quality-gate.sh b/quality-gate.sh index 56e53e75b56..01fdd3e4094 100755 --- a/quality-gate.sh +++ b/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"