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-0dff7051ff02master
parent
ee8cf7ae10
commit
d57065040c
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
|
@ -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. *)
|
|
@ -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. *)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue