diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index bfebf7067..0f9ad0268 100644 --- a/otherlibs/systhreads/.depend +++ b/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 diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index c9a308e26..d0b7053cd 100644 --- a/otherlibs/systhreads/Makefile +++ b/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 diff --git a/otherlibs/systhreads/Tests/Makefile b/otherlibs/systhreads/Tests/Makefile index 7e471f059..c064d4662 100644 --- a/otherlibs/systhreads/Tests/Makefile +++ b/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 diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index f70a3b764..6931d7500 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -16,6 +16,7 @@ #include #include #include +#include #include #include #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) diff --git a/otherlibs/systhreads/semaphore.ml b/otherlibs/systhreads/semaphore.ml new file mode 100644 index 000000000..4b01b8e5c --- /dev/null +++ b/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" diff --git a/otherlibs/systhreads/semaphore.mli b/otherlibs/systhreads/semaphore.mli new file mode 100644 index 000000000..4bdae3e40 --- /dev/null +++ b/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. *) diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli index 7bea911ce..b2bc57caf 100644 --- a/otherlibs/systhreads/thread.mli +++ b/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. *) diff --git a/otherlibs/systhreads/thread_posix.ml b/otherlibs/systhreads/thread_posix.ml index 3adaf14f8..376d7e0bf 100644 --- a/otherlibs/systhreads/thread_posix.ml +++ b/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