From ef689c7bf2c5ed777303db62b0959f846b690ec3 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Sun, 5 Nov 1995 17:27:32 +0000 Subject: [PATCH] Separation des locks et des conditions. Nettoyage du scheduler. git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@396 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- otherlibs/threads/Makefile | 2 +- otherlibs/threads/condition.ml | 31 +++++++++++++++++++ otherlibs/threads/condition.mli | 20 ++++++++++++ otherlibs/threads/mutex.ml | 39 ++++++++++++++++++++++++ otherlibs/threads/mutex.mli | 20 ++++++++++++ otherlibs/threads/scheduler.c | 6 +++- otherlibs/threads/thread.ml | 54 +-------------------------------- otherlibs/threads/thread.mli | 11 ------- 8 files changed, 117 insertions(+), 66 deletions(-) create mode 100644 otherlibs/threads/condition.ml create mode 100644 otherlibs/threads/condition.mli create mode 100644 otherlibs/threads/mutex.ml create mode 100644 otherlibs/threads/mutex.mli diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index dcbee74a99ca..607d7f2b50cf 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -6,7 +6,7 @@ CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) CAMLC=../../boot/cslrun ../../boot/cslc -I ../../boot -I ../unix C_OBJS=scheduler.o -CAML_OBJS=thread.cmo threadIO.cmo +CAML_OBJS=thread.cmo threadIO.cmo mutex.cmo condition.cmo all: libthreads.a threads.cma diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml new file mode 100644 index 000000000000..8995c2f2e02b --- /dev/null +++ b/otherlibs/threads/condition.ml @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* Caml Special Light *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1995 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type t = + { mutable cond_waiting: t list } + +let new () = { cond_waiting = [] } + +let wait cond lock = + cond.cond_waiting <- Thread.self() :: cond.cond_waiting; + Mutex.unlock lock; + Thread.sleep() + +let signal cond = + match cond.cond_waiting with + [] -> () + | pid :: rem -> Thread.wakeup pid; cond.cond_waiting <- rem + +let broadcast cond = + List.iter Thread.wakeup cond.cond_waiting; + cond.cond_waiting <- [] diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli new file mode 100644 index 000000000000..524470d04df6 --- /dev/null +++ b/otherlibs/threads/condition.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* Caml Special Light *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1995 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [Condition]: synchronization between threads via conditions *) + +type t +val new: unit -> t +val wait: t -> Mutex.t -> unit +val signal: t -> unit +val broadcast: t -> unit diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml new file mode 100644 index 000000000000..b7797fb6abb0 --- /dev/null +++ b/otherlibs/threads/mutex.ml @@ -0,0 +1,39 @@ +(***********************************************************************) +(* *) +(* Caml Special Light *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1995 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +type t = + { mutable locked: bool; + mutable lock_waiting: t list } + +(* We rely heavily on the fact that signals are detected only at + function applications and beginning of loops, making all other operations + atomic. *) + +let new_lock () = { locked = false; lock_waiting = [] } + +let rec lock l = + if l.locked then begin + l.lock_waiting <- Thread.self() :: l.lock_waiting; + Thread.sleep(); + lock l + end else begin + l.locked <- true + end + +let try_lock l = + if l.locked then false else begin l.locked <- true; true end + +let unlock l = + List.iter Thread.wakeup l.lock_waiting; + l.locked <- false + diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli new file mode 100644 index 000000000000..f0bd28690043 --- /dev/null +++ b/otherlibs/threads/mutex.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* Caml Special Light *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1995 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Module [Mutex]: mutually-exclusive locks *) + +type t +val new: unit -> t +val lock: t -> unit +val try_lock: t -> bool +val unlock: t -> unit diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c index 6b6ab91c96d4..17b7ec00c415 100644 --- a/otherlibs/threads/scheduler.c +++ b/otherlibs/threads/scheduler.c @@ -312,7 +312,11 @@ value thread_wait_for(time) /* ML */ value thread_wakeup(thread) /* ML */ value thread; { - ((thread_t) thread)->runnable = 1; + thread_t th = (thread_t) thread; + /* The thread is no longer waiting on I/O or timer. */ + if (th->fd != NO_FD) { th->fd = NO_FD; num_waiting_on_fd--; } + if (th->delay != NO_DELAY) { th->delay = NO_DELAY; num_waiting_on_timer--; } + th->runnable = 1; return Val_unit; } diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml index 9e272094e21a..199af9bdd44d 100644 --- a/otherlibs/threads/thread.ml +++ b/otherlibs/threads/thread.ml @@ -16,7 +16,7 @@ type t (* It is mucho important that the primitives that reschedule are called - through an ML function call, not directly. That's because when a C + through an ML function call, not directly. That's because when such a primitive returns, the bytecode interpreter is only semi-obedient: it takes sp from the new thread, but keeps pc from the old thread. But that's OK if all calls to rescheduling primitives are immediately @@ -34,7 +34,6 @@ external thread_wakeup : t -> unit = "thread_wakeup" external thread_self : unit -> t = "thread_self" external thread_kill : t -> unit = "thread_kill" -let yield () = thread_yield() let sleep () = thread_sleep() let wait_descr fd = thread_wait_descr fd let wait_inchan ic = thread_wait_inchan ic @@ -60,54 +59,3 @@ let new fn arg = let _ = Sys.signal Sys.sigvtalrm (Sys.Signal_handle(fun signal -> thread_yield())); thread_initialize() - -(* Locks *) - -type lock = - { mutable locked: bool; - mutable lock_waiting: t list } - -(* We rely heavily on the fact that signals are detected only at - function applications and beginning of loops, making all other operations - atomic. *) - -let new_lock () = { locked = false; lock_waiting = [] } - -let rec lock l = - if l.locked then begin - l.lock_waiting <- self() :: l.lock_waiting; - sleep(); - lock l - end else begin - l.locked <- true - end - -let try_lock l = - if l.locked then false else begin l.locked <- true; true end - -let unlock l = - List.iter wakeup l.lock_waiting; - l.locked <- false - -(* Conditions *) - -type condition = - { mutable cond_waiting: t list } - -let new_condition () = { cond_waiting = [] } - -let wait cond lock = - cond.cond_waiting <- self() :: cond.cond_waiting; - unlock lock; - sleep() - -let signal cond = - match cond.cond_waiting with - [] -> () - | pid :: rem -> wakeup pid; cond.cond_waiting <- rem - -let broadcast cond = - List.iter wakeup cond.cond_waiting; - cond.cond_waiting <- [] - - diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli index cc99e5f0d23d..e3d4855cfe39 100644 --- a/otherlibs/threads/thread.mli +++ b/otherlibs/threads/thread.mli @@ -18,21 +18,10 @@ val new : ('a -> 'b) -> 'a -> t val exit : unit -> unit val self : unit -> t val kill : t -> unit -val yield : unit -> unit val sleep : unit -> unit val wakeup : t -> unit val wait_descr : Unix.file_descr -> unit val wait_inchan : in_channel -> unit val delay: float -> unit -type lock -val new_lock: unit -> lock -val lock: lock -> unit -val try_lock: lock -> bool -val unlock: lock -> unit -type condition -val new_condition: unit -> condition -val wait: condition -> lock -> unit -val signal: condition -> unit -val broadcast: condition -> unit