diff --git a/src/lock.ml b/src/lock.ml new file mode 100644 index 00000000..714a6843 --- /dev/null +++ b/src/lock.ml @@ -0,0 +1,36 @@ +type 'a t = { + mutex: Mutex.t; + mutable content: 'a; +} + +let create content : _ t = { mutex = Mutex.create (); content } + +let with_ (self : _ t) f = + Mutex.lock self.mutex; + try + let x = f self.content in + Mutex.unlock self.mutex; + x + with e -> + Mutex.unlock self.mutex; + raise e + +let[@inline] mutex self = self.mutex +let[@inline] update self f = with_ self (fun x -> self.content <- f x) + +let[@inline] update_map l f = + with_ l (fun x -> + let x', y = f x in + l.content <- x'; + y) + +let get l = + Mutex.lock l.mutex; + let x = l.content in + Mutex.unlock l.mutex; + x + +let set l x = + Mutex.lock l.mutex; + l.content <- x; + Mutex.unlock l.mutex diff --git a/src/lock.mli b/src/lock.mli new file mode 100644 index 00000000..4f6010f5 --- /dev/null +++ b/src/lock.mli @@ -0,0 +1,35 @@ +(** Mutex-protected resource. + + @since NEXT_RELEASE *) + +type 'a t +(** A value protected by a mutex *) + +val create : 'a -> 'a t +(** Create a new protected value. *) + +val with_ : 'a t -> ('a -> 'b) -> 'b +(** [with_ l f] runs [f x] where [x] is the value protected with + the lock [l], in a critical section. If [f x] fails, [with_lock l f] + fails too but the lock is released. *) + +val update : 'a t -> ('a -> 'a) -> unit +(** [update l f] replaces the content [x] of [l] with [f x], while protected + by the mutex. *) + +val update_map : 'a t -> ('a -> 'a * 'b) -> 'b +(** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l] + and returns [y], while protected by the mutex. *) + +val mutex : _ t -> Mutex.t +(** Underlying mutex. *) + +val get : 'a t -> 'a +(** Atomically get the value in the lock. The value that is returned + isn't protected! *) + +val set : 'a t -> 'a -> unit +(** Atomically set the value. + + {b NOTE} caution: using {!get} and {!set} as if this were a {!ref} + is an anti pattern and will not protect data against some race conditions. *) diff --git a/src/moonpool.ml b/src/moonpool.ml index 99fe4521..66e59733 100644 --- a/src/moonpool.ml +++ b/src/moonpool.ml @@ -5,6 +5,7 @@ let start_thread_on_some_domain f x = module Atomic = Atomic_ module Blocking_queue = Bb_queue module Chan = Chan +module Lock = Lock module Fork_join = Fork_join module Fut = Fut module Pool = Pool diff --git a/src/moonpool.mli b/src/moonpool.mli index 1aab2165..98e8e292 100644 --- a/src/moonpool.mli +++ b/src/moonpool.mli @@ -11,6 +11,7 @@ val start_thread_on_some_domain : ('a -> unit) -> 'a -> Thread.t to run the thread. This ensures that we don't always pick the same domain to run all the various threads needed in an application (timers, event loops, etc.) *) +module Lock = Lock module Fut = Fut module Chan = Chan module Fork_join = Fork_join