diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index ba72c7852..97f706214 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -17,7 +17,7 @@ LIB_OBJS=pervasives.cmo \ $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ $(LIB)/stream.cmo $(LIB)/printf.cmo $(LIB)/format.cmo $(LIB)/arg.cmo \ $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \ - $(LIB)/oo.cmo $(LIB)/genlex.cmo + $(LIB)/oo.cmo $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo all: libthreads.a threads.cma stdlib.cma diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c index c51e80184..82a2606f3 100644 --- a/otherlibs/threads/scheduler.c +++ b/otherlibs/threads/scheduler.c @@ -480,26 +480,26 @@ value thread_delay(time) /* ML */ /* Suspend the current thread on a Unix file descriptor, with timeout */ -value thread_wait_timed_read(fd, time) /* ML */ - value fd, time; +value thread_wait_timed_read(fd_time) /* ML */ + value fd_time; { - double date = timeofday() + Double_val(time); + double date = timeofday() + Double_val(Field(fd_time, 1)); Assert(curr_thread != NULL); check_callback(); curr_thread->status = BLOCKED_READ | BLOCKED_DELAY; - curr_thread->fd = fd; + curr_thread->fd = Field(fd_time, 0); Assign(curr_thread->delay, copy_double(date)); return schedule_thread(); } -value thread_wait_timed_write(fd, time) /* ML */ - value fd, time; +value thread_wait_timed_write(fd_time) /* ML */ + value fd_time; { - double date = timeofday() + Double_val(time); + double date = timeofday() + Double_val(Field(fd_time, 1)); Assert(curr_thread != NULL); check_callback(); curr_thread->status = BLOCKED_WRITE | BLOCKED_DELAY; - curr_thread->fd = fd; + curr_thread->fd = Field(fd_time, 0); Assign(curr_thread->delay, copy_double(date)); return schedule_thread(); } diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml index 3d965a0fa..ec2e0ebca 100644 --- a/otherlibs/threads/thread.ml +++ b/otherlibs/threads/thread.ml @@ -30,7 +30,9 @@ type resumption_status = 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 followed by a RETURN operation, which will restore the correct pc - from the stack. *) + from the stack. Furthermore, the RETURNs must all have the same + frame size, which means that both the primitives and their ML wrappers + must take exactly one argument. *) external thread_initialize : unit -> unit = "thread_initialize" external thread_new : (unit -> unit) -> t = "thread_new" @@ -39,10 +41,10 @@ external thread_sleep : unit -> unit = "thread_sleep" external thread_wait_read : Unix.file_descr -> unit = "thread_wait_read" external thread_wait_write : Unix.file_descr -> unit = "thread_wait_write" external thread_wait_timed_read - : Unix.file_descr -> float -> resumption_status + : Unix.file_descr * float -> resumption_status (* remeber: 1 arg *) = "thread_wait_timed_read" external thread_wait_timed_write - : Unix.file_descr -> float -> resumption_status + : Unix.file_descr * float -> resumption_status (* remeber: 1 arg *) = "thread_wait_timed_write" external thread_join : t -> unit = "thread_join" external thread_delay : float -> unit = "thread_delay" @@ -67,19 +69,19 @@ let self () = thread_self() let kill pid = thread_kill pid let exit () = thread_kill(thread_self()) -let wait_timed_read_aux fd d = thread_wait_timed_read fd d -let wait_timed_write_aux fd d = thread_wait_timed_write fd d +let wait_timed_read_aux arg = thread_wait_timed_read arg +let wait_timed_write_aux arg = thread_wait_timed_write arg let wait_pid_aux pid = thread_wait_pid pid -let wait_timed_read fd d = wait_timed_read_aux fd d = Resumed_io -let wait_timed_write fd d = wait_timed_write_aux fd d = Resumed_io +let wait_timed_read fd d = wait_timed_read_aux (fd, d) = Resumed_io +let wait_timed_write fd d = wait_timed_write_aux (fd, d) = Resumed_io let wait_pid pid = match wait_pid_aux pid with Resumed_wait(pid, status) -> (pid, status) | _ -> invalid_arg "Thread.wait_pid" -(* For new, make sure the function passed to thread_new always terminates - by calling exit. *) +(* For Thread.create, make sure the function passed to thread_new + always terminates by calling Thread.exit. *) let create fn arg = thread_new