94 lines
2.4 KiB
OCaml
94 lines
2.4 KiB
OCaml
|
(* Lwt
|
|||
|
* http://www.ocsigen.org
|
|||
|
* Copyright (C) 2008 J<EFBFBD>r<EFBFBD>me Vouillon
|
|||
|
* Laboratoire PPS - CNRS Universit<EFBFBD> Paris Diderot
|
|||
|
*
|
|||
|
* This program is free software; you can redistribute it and/or modify
|
|||
|
* it under the terms of the GNU Lesser General Public License as published by
|
|||
|
* the Free Software Foundation, with linking exceptions;
|
|||
|
* either version 2.1 of the License, or (at your option) any later version.
|
|||
|
* See COPYING file for details.
|
|||
|
*
|
|||
|
* This program is distributed in the hope that it will be useful,
|
|||
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|||
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|||
|
* GNU Lesser General Public License for more details.
|
|||
|
*
|
|||
|
* You should have received a copy of the GNU Lesser General Public License
|
|||
|
* along with this program; if not, write to the Free Software
|
|||
|
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|||
|
*)
|
|||
|
|
|||
|
open Lwt
|
|||
|
|
|||
|
(*
|
|||
|
XXX Close after some timeout
|
|||
|
...
|
|||
|
*)
|
|||
|
|
|||
|
type 'a t =
|
|||
|
{ create : unit -> 'a Lwt.t;
|
|||
|
check : 'a -> (bool -> unit) -> unit;
|
|||
|
max : int;
|
|||
|
mutable count : int;
|
|||
|
list : 'a Queue.t;
|
|||
|
waiters : 'a Lwt.u Lwt_sequence.t }
|
|||
|
|
|||
|
let create m ?(check = fun _ f -> f true) create =
|
|||
|
{ max = m;
|
|||
|
create = create;
|
|||
|
check = check;
|
|||
|
count = 0;
|
|||
|
list = Queue.create ();
|
|||
|
waiters = Lwt_sequence.create () }
|
|||
|
|
|||
|
let create_member p =
|
|||
|
try_lwt
|
|||
|
p.count <- p.count + 1; (* must be done before p.create *)
|
|||
|
lwt mem = p.create () in
|
|||
|
return mem
|
|||
|
with exn ->
|
|||
|
(* create failed, so don't increment count *)
|
|||
|
p.count <- p.count - 1;
|
|||
|
raise_lwt exn
|
|||
|
|
|||
|
let acquire p =
|
|||
|
try
|
|||
|
return (Queue.take p.list)
|
|||
|
with Queue.Empty ->
|
|||
|
if p.count < p.max then
|
|||
|
create_member p
|
|||
|
else begin
|
|||
|
let waiter, wakener = task () in
|
|||
|
let node = Lwt_sequence.add_r wakener p.waiters in
|
|||
|
on_cancel waiter (fun () -> Lwt_sequence.remove node);
|
|||
|
waiter
|
|||
|
end
|
|||
|
|
|||
|
let release p c =
|
|||
|
try
|
|||
|
wakeup_later (Lwt_sequence.take_l p.waiters) c
|
|||
|
with Lwt_sequence.Empty ->
|
|||
|
Queue.push c p.list
|
|||
|
|
|||
|
let checked_release p c =
|
|||
|
p.check c begin fun ok ->
|
|||
|
if ok then
|
|||
|
release p c
|
|||
|
else
|
|||
|
ignore (p.count <- p.count - 1;
|
|||
|
lwt c = create_member p in
|
|||
|
release p c;
|
|||
|
return ())
|
|||
|
end
|
|||
|
|
|||
|
let use p f =
|
|||
|
lwt c = acquire p in
|
|||
|
try_lwt
|
|||
|
lwt r = f c in
|
|||
|
release p c;
|
|||
|
return r
|
|||
|
with e ->
|
|||
|
checked_release p c;
|
|||
|
raise_lwt e
|