Ajout de Semaphore, Thread.wait_signal (a debugger et porter sous Win32)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2042 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

otherlibs/systhreads/.depend

@@ -23,11 +23,13 @@ event.cmo: condition.cmi mutex.cmi event.cmi
 event.cmx: condition.cmx mutex.cmx event.cmi 
 mutex.cmo: mutex.cmi 
 mutex.cmx: mutex.cmi 
-thread.cmo: ../unix/unix.cmi thread.cmi 
-thread.cmx: ../unix/unix.cmx thread.cmi 
+semaphore.cmo: semaphore.cmi 
+semaphore.cmx: semaphore.cmi 
+thread.cmo: semaphore.cmi ../unix/unix.cmi thread.cmi 
+thread.cmx: semaphore.cmx ../unix/unix.cmx thread.cmi 
 threadUnix.cmo: thread.cmi ../unix/unix.cmi threadUnix.cmi 
 threadUnix.cmx: thread.cmx ../unix/unix.cmx threadUnix.cmi 
-thread_posix.cmo: ../unix/unix.cmi 
-thread_posix.cmx: ../unix/unix.cmx 
+thread_posix.cmo: semaphore.cmi ../unix/unix.cmi 
+thread_posix.cmx: semaphore.cmx ../unix/unix.cmx 
 thread_win32.cmo: ../unix/unix.cmi 
 thread_win32.cmx: ../unix/unix.cmx 

otherlibs/systhreads/Makefile

@@ -6,7 +6,8 @@ CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../unix
 BYTECODE_C_OBJS=posix_b.o
 NATIVECODE_C_OBJS=posix_n.o
 
-THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
+THREAD_OBJS=semaphore.cmo thread.cmo mutex.cmo condition.cmo event.cmo \
+  threadUnix.cmo
 
 GENFILES=thread.ml
 

otherlibs/systhreads/Tests/Makefile

@@ -1,6 +1,7 @@
 PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
-  test7.byt test8.byt test9.byt testA.byt sieve.byt \
-  testio.byt testsocket.byt testwait.byt testsignal.byt torture.byt
+  test7.byt test8.byt test9.byt testA.byt testB.byt sieve.byt \
+  testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \
+  torture.byt
 
 include ../../../config/Makefile
 

otherlibs/systhreads/posix.c

@@ -16,6 +16,7 @@
 #include <errno.h>
 #include <string.h>
 #include <pthread.h>
+#include <semaphore.h>
 #include <signal.h>
 #include <sys/time.h>
 #include "alloc.h"
@@ -560,6 +561,64 @@ value caml_condition_broadcast(value wrapper)           /* ML */
   return Val_unit;
 }
 
+/* Semaphore operations.  Currently not exported to the user,
+   used only for implementing Thread.wait_signal */
+
+#define Semaphore_val(v) ((sem_t *) Field(v, 1))
+#define Max_semaphore_number 1000
+
+static void caml_semaphore_finalize(value wrapper)
+{
+  sem_t * sem = Semaphore_val(wrapper);
+  sem_destroy(sem);
+  stat_free(sem);
+}
+
+value caml_semaphore_new(value vinit)        /* ML */
+{
+  sem_t * sem;
+  value wrapper;
+  sem = stat_alloc(sizeof(sem_t));
+  if (sem_init(sem, 0, Int_val(vinit)) == -1)
+    caml_pthread_check(errno, "Semaphore.create");
+  wrapper = alloc_final(2, caml_semaphore_finalize, 1, Max_semaphore_number);
+  Semaphore_val(wrapper) = sem;
+  return wrapper;
+}
+
+value caml_semaphore_wait(value wrapper)           /* ML */
+{
+  int retcode;
+  sem_t * sem = Semaphore_val(wrapper);
+  Begin_root(wrapper)     /* prevent deallocation of semaphore */
+    enter_blocking_section();
+    retcode = 0;
+    while (sem_wait(sem) == -1) {
+      if (errno != EINTR) { retcode = errno; break; }
+    }
+    leave_blocking_section();
+  End_roots();
+  caml_pthread_check(retcode, "Semaphore.wait");
+  return Val_unit;
+}
+
+value caml_semaphore_post(value wrapper)           /* ML */
+{
+  sem_t * sem = Semaphore_val(wrapper);
+  if (sem_post(sem) == -1)
+    caml_pthread_check(errno, "Semaphore.post");
+  return Val_unit;
+}
+
+value caml_semaphore_getvalue(value wrapper) /* ML */
+{
+  sem_t * sem = Semaphore_val(wrapper);
+  int val;
+  if (sem_getvalue(sem, &val) == -1)
+    caml_pthread_check(errno, "Semaphore.getvalue");
+  return Val_int(val);
+}
+
 /* Error report */
 
 static void caml_pthread_check(int retcode, char *msg)

otherlibs/systhreads/semaphore.ml

@@ -0,0 +1,23 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
+(*  Automatique.  Distributed only by permission.                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [Semaphore]: semaphores to synchronize between threads *)
+
+(* Semaphores are an alternative to mutexes and conditions for
+   synchronizing the execution of several threads. *)
+
+type t
+external create: int -> t = "caml_semaphore_new"
+external post: t -> unit = "caml_semaphore_post"
+external wait: t -> unit = "caml_semaphore_wait"
+external getvalue: t -> int = "caml_semaphore_getvalue"

otherlibs/systhreads/semaphore.mli

@@ -0,0 +1,34 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
+(*  Automatique.  Distributed only by permission.                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [Semaphore]: semaphores to synchronize between threads *)
+
+(* Semaphores are an alternative to mutexes and conditions for
+   synchronizing the execution of several threads.  Semaphores
+   are integer counters with atomic increment (post) and decrement (wait)
+   operations. *)
+
+type t
+        (* The type of semaphores *)
+val create: int -> t
+        (* Return a new semaphore, initialized to the given integer. *)
+val post: t -> unit
+        (* Atomically increment the value of the semaphore.
+           If some threads were waiting for the semaphore to become non-zero,
+           one of them is restarted. *)
+val wait: t -> unit
+        (* Atomically decrement the value of the semaphore.
+           If the semaphore was initially zero, block until it becomes non-zero
+           via a [Semaphore.post] operation, then decrement it and return. *)
+val getvalue: t -> int
+        (* Return the current value of the semaphore. *)

otherlibs/systhreads/thread.mli

@@ -77,4 +77,10 @@ val wait_pid : int -> int * Unix.process_status
            until the process specified by the process identifier [p]
            terminates. Returns the pid of the child caught and
            its termination status, as per [Unix.wait]. *)
-
+val wait_signal : int list -> int
+        (* [wait_signal sigs] suspends the execution of the calling thread
+           until the process receives one of the signals specified in the
+           list [sigs].  It then returns the number of the signal received.
+           Signal handlers attached to the signals in [sigs] will not
+           be invoked.  Do not call [wait_signal] concurrently 
+           from several threads on the same signals. *)

otherlibs/systhreads/thread_posix.ml

@@ -71,3 +71,12 @@ let select = Unix.select
 
 let wait_pid p = Unix.waitpid [] p
 
+let wait_signal sigs =
+  let gotsig = ref 0 in
+  let sem = Semaphore.create 0 in
+  let sighandler s = gotsig := s; Semaphore.post sem in
+  let oldhdlrs =
+    List.map (fun s -> Sys.signal s (Sys.Signal_handle sighandler)) sigs in
+  Semaphore.wait sem;
+  List.iter2 (fun s act -> Sys.signal s act; ()) sigs oldhdlrs;
+  !gotsig