88 lines
3.2 KiB
OCaml
88 lines
3.2 KiB
OCaml
(* -*- Mode: Caml; indent-tabs-mode: nil -*- *)
|
|
(******************************************************************************)
|
|
(* Lightweight thread library for Objective Caml
|
|
* http://www.ocsigen.org/lwt
|
|
* Interface Lwt_mon
|
|
******************************************************************************
|
|
* Copyright (c) 2009, Metaweb Technologies, Inc.
|
|
* All rights reserved.
|
|
*
|
|
* Redistribution and use in source and binary forms, with or without
|
|
* modification, are permitted provided that the following conditions
|
|
* are met:
|
|
* * Redistributions of source code must retain the above copyright
|
|
* notice, this list of conditions and the following disclaimer.
|
|
* * Redistributions in binary form must reproduce the above
|
|
* copyright notice, this list of conditions and the following
|
|
* disclaimer in the documentation and/or other materials provided
|
|
* with the distribution.
|
|
*
|
|
* THIS SOFTWARE IS PROVIDED BY METAWEB TECHNOLOGIES ``AS IS'' AND ANY
|
|
* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
|
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
|
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL METAWEB TECHNOLOGIES BE
|
|
* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
|
|
* BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
|
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
|
|
* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
******************************************************************************)
|
|
|
|
let return_unit = Lwt.return ()
|
|
|
|
type 'a t = {
|
|
mutable contents : 'a option;
|
|
(* Current contents *)
|
|
|
|
mutable writers : ('a * unit Lwt.u) Lwt_sequence.t;
|
|
(* Threads waiting to put a value *)
|
|
|
|
mutable readers : 'a Lwt.u Lwt_sequence.t;
|
|
(* Threads waiting for a value *)
|
|
}
|
|
|
|
let create_empty () =
|
|
{ contents = None;
|
|
writers = Lwt_sequence.create ();
|
|
readers = Lwt_sequence.create () }
|
|
|
|
let create v =
|
|
{ contents = Some v;
|
|
writers = Lwt_sequence.create ();
|
|
readers = Lwt_sequence.create () }
|
|
|
|
let put mvar v =
|
|
match mvar.contents with
|
|
| None ->
|
|
begin match Lwt_sequence.take_opt_l mvar.readers with
|
|
| None ->
|
|
mvar.contents <- Some v
|
|
| Some w ->
|
|
Lwt.wakeup_later w v
|
|
end;
|
|
return_unit
|
|
| Some _ ->
|
|
let (res, w) = Lwt.task () in
|
|
let node = Lwt_sequence.add_r (v, w) mvar.writers in
|
|
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
|
|
res
|
|
|
|
let take mvar =
|
|
match mvar.contents with
|
|
| Some v ->
|
|
begin match Lwt_sequence.take_opt_l mvar.writers with
|
|
| Some(v', w) ->
|
|
mvar.contents <- Some v';
|
|
Lwt.wakeup_later w ()
|
|
| None ->
|
|
mvar.contents <- None
|
|
end;
|
|
Lwt.return v
|
|
| None ->
|
|
let (res, w) = Lwt.task () in
|
|
let node = Lwt_sequence.add_r w mvar.readers in
|
|
Lwt.on_cancel res (fun _ -> Lwt_sequence.remove node);
|
|
res
|