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

@@ -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
 

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 <- []

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

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
+

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

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;
 }
 

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 <- []
-
-

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