1996-09-04 07:17:43 -07:00
|
|
|
/***********************************************************************/
|
|
|
|
/* */
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Objective Caml */
|
1996-09-04 07:17:43 -07:00
|
|
|
/* */
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt */
|
1996-09-04 07:17:43 -07:00
|
|
|
/* */
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Copyright 1995 Institut National de Recherche en Informatique et */
|
1996-09-04 07:17:43 -07:00
|
|
|
/* Automatique. Distributed only by permission. */
|
|
|
|
/* */
|
|
|
|
/***********************************************************************/
|
|
|
|
|
|
|
|
/* $Id$ */
|
|
|
|
|
|
|
|
/* Thread interface for Win32 threads */
|
|
|
|
|
|
|
|
#include <windows.h>
|
|
|
|
#include "alloc.h"
|
1997-09-01 07:26:16 -07:00
|
|
|
#include "callback.h"
|
1996-09-04 07:17:43 -07:00
|
|
|
#include "fail.h"
|
1997-09-01 07:26:16 -07:00
|
|
|
#include "io.h"
|
1996-09-04 07:17:43 -07:00
|
|
|
#include "memory.h"
|
|
|
|
#include "misc.h"
|
|
|
|
#include "mlvalues.h"
|
|
|
|
#include "roots.h"
|
|
|
|
#include "signals.h"
|
1997-11-20 07:34:38 -08:00
|
|
|
#ifdef NATIVE_CODE
|
|
|
|
#include "stack.h"
|
|
|
|
#else
|
1996-09-04 07:17:43 -07:00
|
|
|
#include "stacks.h"
|
1997-11-20 07:34:38 -08:00
|
|
|
#endif
|
1996-09-04 07:17:43 -07:00
|
|
|
#include "sys.h"
|
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Initial size of stack when a thread is created (4 Ko) */
|
|
|
|
#define Thread_stack_size (Stack_size / 4)
|
|
|
|
|
|
|
|
/* Max computation time before rescheduling, in microseconds (50ms) */
|
|
|
|
#define Thread_timeout 50000
|
1996-09-04 07:17:43 -07:00
|
|
|
|
|
|
|
/* Signal used for timer preemption (any unused signal number) */
|
|
|
|
#define SIGTIMER 1
|
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
/* The ML value describing a thread (heap-allocated) */
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
struct caml_thread_handle {
|
1996-09-04 07:17:43 -07:00
|
|
|
value final_fun; /* Finalization function */
|
1997-09-01 07:26:16 -07:00
|
|
|
HANDLE handle; /* Windows handle */
|
|
|
|
};
|
|
|
|
|
|
|
|
struct caml_thread_descr {
|
|
|
|
value ident; /* Unique integer ID */
|
|
|
|
value start_closure; /* The closure to start this thread */
|
|
|
|
struct caml_thread_handle * thread_handle; /* Finalized object with handle */
|
1996-09-04 07:17:43 -07:00
|
|
|
};
|
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
#define Ident(v) (((struct caml_thread_descr *)(v))->ident)
|
|
|
|
#define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure)
|
|
|
|
#define Threadhandle(v) (((struct caml_thread_descr *)(v))->thread_handle)
|
|
|
|
|
|
|
|
/* The infos on threads (allocated via malloc()) */
|
|
|
|
|
1996-09-08 08:41:59 -07:00
|
|
|
struct caml_thread_struct {
|
1997-09-01 07:26:16 -07:00
|
|
|
HANDLE wthread; /* The Windows thread handle */
|
|
|
|
value descr; /* The heap-allocated descriptor */
|
|
|
|
struct caml_thread_struct * next; /* Double linking of running threads */
|
|
|
|
struct caml_thread_struct * prev;
|
|
|
|
#ifdef NATIVE_CODE
|
1997-12-02 05:12:07 -08:00
|
|
|
char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */
|
|
|
|
unsigned long last_retaddr; /* Saved value of caml_last_return_address */
|
|
|
|
value * gc_regs; /* Saved value of caml_gc_regs */
|
1997-09-01 07:26:16 -07:00
|
|
|
char * exception_pointer; /* Saved value of caml_exception_pointer */
|
|
|
|
struct caml__roots_block * local_roots; /* Saved value of local_roots */
|
|
|
|
#else
|
1996-09-04 07:17:43 -07:00
|
|
|
value * stack_low; /* The execution stack for this thread */
|
|
|
|
value * stack_high;
|
|
|
|
value * stack_threshold;
|
|
|
|
value * sp; /* Saved value of extern_sp for this thread */
|
|
|
|
value * trapsp; /* Saved value of trapsp for this thread */
|
1997-08-29 08:37:22 -07:00
|
|
|
struct caml__roots_block * local_roots; /* Saved value of local_roots */
|
1997-09-01 07:26:16 -07:00
|
|
|
struct longjmp_buffer * external_raise; /* Saved external_raise */
|
|
|
|
#endif
|
1996-09-04 07:17:43 -07:00
|
|
|
};
|
|
|
|
|
1996-09-08 08:41:59 -07:00
|
|
|
typedef struct caml_thread_struct * caml_thread_t;
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
/* The descriptor for the currently executing thread (thread-specific) */
|
|
|
|
|
1997-09-02 09:01:39 -07:00
|
|
|
static __declspec( thread ) caml_thread_t curr_thread = NULL;
|
1996-09-04 07:17:43 -07:00
|
|
|
|
|
|
|
/* The global mutex used to ensure that at most one thread is running
|
|
|
|
Caml code */
|
1997-09-01 07:26:16 -07:00
|
|
|
static HANDLE caml_mutex;
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
/* The thread-specific variable holding last locked I/O channel */
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
static __declspec( thread ) struct channel * last_channel_locked = NULL;
|
1996-09-04 07:17:43 -07:00
|
|
|
|
|
|
|
/* Identifier for next thread creation */
|
|
|
|
static long thread_next_ident = 0;
|
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Forward declarations */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_wthread_error (char * msg);
|
1997-09-01 07:26:16 -07:00
|
|
|
|
1996-09-04 07:17:43 -07:00
|
|
|
/* Hook for scanning the stacks of the other threads */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void (*prev_scan_roots_hook) (scanning_action);
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_thread_scan_roots(scanning_action action)
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1996-09-08 08:41:59 -07:00
|
|
|
caml_thread_t th;
|
1997-09-01 07:26:16 -07:00
|
|
|
|
1997-10-16 09:12:40 -07:00
|
|
|
th = curr_thread;
|
|
|
|
do {
|
1997-09-01 07:26:16 -07:00
|
|
|
(*action)(th->descr, &th->descr);
|
1997-10-16 09:12:40 -07:00
|
|
|
/* Don't rescan the stack of the current thread, it was done already */
|
|
|
|
if (th != curr_thread) {
|
1997-09-01 07:26:16 -07:00
|
|
|
#ifdef NATIVE_CODE
|
1997-12-02 05:12:07 -08:00
|
|
|
if (th->bottom_of_stack != NULL)
|
|
|
|
do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
|
|
|
|
th->gc_regs, th->local_roots);
|
1997-09-01 07:26:16 -07:00
|
|
|
#else
|
1997-10-16 09:12:40 -07:00
|
|
|
do_local_roots(action, th->sp, th->stack_high, th->local_roots);
|
1997-09-01 07:26:16 -07:00
|
|
|
#endif
|
1997-10-16 09:12:40 -07:00
|
|
|
}
|
|
|
|
th = th->next;
|
|
|
|
} while (th != curr_thread);
|
1996-09-04 07:17:43 -07:00
|
|
|
/* Hook */
|
|
|
|
if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Hooks for enter_blocking_section and leave_blocking_section */
|
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
static void (*prev_enter_blocking_section_hook) () = NULL;
|
|
|
|
static void (*prev_leave_blocking_section_hook) () = NULL;
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_thread_enter_blocking_section(void)
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
if (prev_enter_blocking_section_hook != NULL)
|
|
|
|
(*prev_enter_blocking_section_hook)();
|
|
|
|
/* Save the stack-related global variables in the thread descriptor
|
|
|
|
of the current thread */
|
1997-09-01 07:26:16 -07:00
|
|
|
#ifdef NATIVE_CODE
|
1997-12-02 05:12:07 -08:00
|
|
|
curr_thread->bottom_of_stack = caml_bottom_of_stack;
|
|
|
|
curr_thread->last_retaddr = caml_last_return_address;
|
|
|
|
curr_thread->gc_regs = caml_gc_regs;
|
1997-09-01 07:26:16 -07:00
|
|
|
curr_thread->exception_pointer = caml_exception_pointer;
|
|
|
|
curr_thread->local_roots = local_roots;
|
|
|
|
#else
|
1996-09-04 07:17:43 -07:00
|
|
|
curr_thread->stack_low = stack_low;
|
|
|
|
curr_thread->stack_high = stack_high;
|
|
|
|
curr_thread->stack_threshold = stack_threshold;
|
|
|
|
curr_thread->sp = extern_sp;
|
|
|
|
curr_thread->trapsp = trapsp;
|
|
|
|
curr_thread->local_roots = local_roots;
|
1997-09-01 07:26:16 -07:00
|
|
|
curr_thread->external_raise = external_raise;
|
|
|
|
#endif
|
1996-09-04 07:17:43 -07:00
|
|
|
/* Release the global mutex */
|
1997-09-01 07:26:16 -07:00
|
|
|
ReleaseMutex(caml_mutex);
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_thread_leave_blocking_section(void)
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
/* Re-acquire the global mutex */
|
1997-09-01 07:26:16 -07:00
|
|
|
WaitForSingleObject(caml_mutex, INFINITE);
|
1996-09-04 07:17:43 -07:00
|
|
|
/* Restore the stack-related global variables */
|
1997-09-01 07:26:16 -07:00
|
|
|
#ifdef NATIVE_CODE
|
1997-12-02 05:12:07 -08:00
|
|
|
caml_bottom_of_stack= curr_thread->bottom_of_stack;
|
|
|
|
caml_last_return_address = curr_thread->last_retaddr;
|
|
|
|
caml_gc_regs = curr_thread->gc_regs;
|
1997-09-01 07:26:16 -07:00
|
|
|
caml_exception_pointer = curr_thread->exception_pointer;
|
|
|
|
local_roots = curr_thread->local_roots;
|
|
|
|
#else
|
1996-09-04 07:17:43 -07:00
|
|
|
stack_low = curr_thread->stack_low;
|
|
|
|
stack_high = curr_thread->stack_high;
|
|
|
|
stack_threshold = curr_thread->stack_threshold;
|
|
|
|
extern_sp = curr_thread->sp;
|
|
|
|
trapsp = curr_thread->trapsp;
|
|
|
|
local_roots = curr_thread->local_roots;
|
1997-09-01 07:26:16 -07:00
|
|
|
external_raise = curr_thread->external_raise;
|
|
|
|
#endif
|
1996-09-04 07:17:43 -07:00
|
|
|
if (prev_leave_blocking_section_hook != NULL)
|
|
|
|
(*prev_leave_blocking_section_hook)();
|
|
|
|
}
|
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Hooks for I/O locking */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_io_mutex_free(struct channel * chan)
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
|
|
|
HANDLE mutex = chan->mutex;
|
|
|
|
if (mutex != NULL) {
|
|
|
|
CloseHandle(mutex);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_io_mutex_lock(struct channel * chan)
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
|
|
|
if (chan->mutex == NULL) {
|
1997-09-02 09:01:39 -07:00
|
|
|
HANDLE mutex = CreateMutex(NULL, FALSE, NULL);
|
1997-09-01 07:26:16 -07:00
|
|
|
if (mutex == NULL) caml_wthread_error("Thread.iolock");
|
|
|
|
chan->mutex = (void *) mutex;
|
|
|
|
}
|
|
|
|
enter_blocking_section();
|
|
|
|
WaitForSingleObject((HANDLE) chan->mutex, INFINITE);
|
|
|
|
leave_blocking_section();
|
|
|
|
last_channel_locked = chan;
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_io_mutex_unlock(struct channel * chan)
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
|
|
|
ReleaseMutex((HANDLE) chan->mutex);
|
|
|
|
last_channel_locked = NULL;
|
|
|
|
}
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_io_mutex_unlock_exn(void)
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
|
|
|
if (last_channel_locked != NULL) caml_io_mutex_unlock(last_channel_locked);
|
|
|
|
}
|
|
|
|
|
1997-12-02 05:12:07 -08:00
|
|
|
/* The "tick" thread fakes a signal at regular intervals. */
|
1997-09-01 07:26:16 -07:00
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void * caml_thread_tick(void)
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
while(1) {
|
|
|
|
Sleep(Thread_timeout);
|
|
|
|
pending_signal = SIGTIMER;
|
1997-09-01 07:26:16 -07:00
|
|
|
#ifdef NATIVE_CODE
|
|
|
|
young_limit = young_end;
|
|
|
|
#else
|
1996-09-04 07:17:43 -07:00
|
|
|
something_to_do = 1;
|
1997-09-01 07:26:16 -07:00
|
|
|
#endif
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_thread_finalize(value vthread)
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-01 07:26:16 -07:00
|
|
|
CloseHandle(((struct caml_thread_handle *)vthread)->handle);
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Initialize the thread machinery */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_thread_initialize(value unit) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-01 07:26:16 -07:00
|
|
|
value vthread = Val_unit;
|
|
|
|
value descr;
|
1996-09-04 07:17:43 -07:00
|
|
|
HANDLE tick_thread;
|
1997-09-01 07:26:16 -07:00
|
|
|
unsigned long tick_id;
|
|
|
|
|
|
|
|
Begin_root (vthread);
|
1997-09-02 09:01:39 -07:00
|
|
|
/* Initialize the main mutex and acquire it */
|
1997-09-01 07:26:16 -07:00
|
|
|
caml_mutex = CreateMutex(NULL, TRUE, NULL);
|
|
|
|
if (caml_mutex == NULL) caml_wthread_error("Thread.init");
|
|
|
|
/* Create a finalized value to hold thread handle */
|
1997-10-16 09:12:40 -07:00
|
|
|
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
|
|
|
|
caml_thread_finalize, 1, 1000);
|
1997-09-01 07:26:16 -07:00
|
|
|
((struct caml_thread_handle *)vthread)->handle = NULL;
|
|
|
|
/* Create a descriptor for the current thread */
|
1997-10-16 09:12:40 -07:00
|
|
|
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
|
1997-09-01 07:26:16 -07:00
|
|
|
Ident(descr) = Val_long(thread_next_ident);
|
|
|
|
Start_closure(descr) = Val_unit;
|
1997-09-02 09:01:39 -07:00
|
|
|
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
|
1997-09-01 07:26:16 -07:00
|
|
|
thread_next_ident++;
|
|
|
|
/* Create an info block for the current thread */
|
|
|
|
curr_thread =
|
|
|
|
(caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
|
|
|
|
DuplicateHandle(GetCurrentProcess(), GetCurrentThread(),
|
|
|
|
GetCurrentProcess(), &(curr_thread->wthread),
|
|
|
|
0, FALSE, DUPLICATE_SAME_ACCESS);
|
|
|
|
if (curr_thread->wthread == NULL) caml_wthread_error("Thread.init");
|
|
|
|
((struct caml_thread_handle *)vthread)->handle = curr_thread->wthread;
|
|
|
|
curr_thread->descr = descr;
|
|
|
|
curr_thread->next = curr_thread;
|
|
|
|
curr_thread->prev = curr_thread;
|
|
|
|
/* The stack-related fields will be filled in at the next
|
|
|
|
enter_blocking_section */
|
|
|
|
/* Set up the hooks */
|
|
|
|
prev_scan_roots_hook = scan_roots_hook;
|
|
|
|
scan_roots_hook = caml_thread_scan_roots;
|
|
|
|
prev_enter_blocking_section_hook = enter_blocking_section_hook;
|
|
|
|
enter_blocking_section_hook = caml_thread_enter_blocking_section;
|
|
|
|
prev_leave_blocking_section_hook = leave_blocking_section_hook;
|
|
|
|
leave_blocking_section_hook = caml_thread_leave_blocking_section;
|
|
|
|
channel_mutex_free = caml_io_mutex_free;
|
|
|
|
channel_mutex_lock = caml_io_mutex_lock;
|
|
|
|
channel_mutex_unlock = caml_io_mutex_unlock;
|
|
|
|
channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
|
|
|
|
/* Fork the tick thread */
|
|
|
|
tick_thread =
|
|
|
|
CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)&caml_thread_tick,
|
|
|
|
NULL, 0, &tick_id);
|
|
|
|
if (tick_thread == NULL) caml_wthread_error("Thread.init");
|
|
|
|
CloseHandle(tick_thread);
|
|
|
|
End_roots();
|
1996-09-04 07:17:43 -07:00
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Create a thread */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_thread_start(caml_thread_t th)
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
value clos;
|
1997-09-01 07:26:16 -07:00
|
|
|
|
1997-09-02 09:01:39 -07:00
|
|
|
/* Initialize the per-thread variables */
|
|
|
|
curr_thread = th;
|
|
|
|
last_channel_locked = NULL;
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Acquire the global mutex and set up the stack variables */
|
|
|
|
leave_blocking_section();
|
1996-09-04 07:17:43 -07:00
|
|
|
/* Callback the closure */
|
1997-09-01 07:26:16 -07:00
|
|
|
clos = Start_closure(th->descr);
|
|
|
|
Modify(&(Start_closure(th->descr)), Val_unit);
|
1996-09-04 07:17:43 -07:00
|
|
|
callback(clos, Val_unit);
|
1997-11-25 07:29:46 -08:00
|
|
|
/* Remove th from the doubly-linked list of threads */
|
|
|
|
th->next->prev = th->prev;
|
|
|
|
th->prev->next = th->next;
|
1998-04-25 07:09:56 -07:00
|
|
|
/* Release the main mutex (forever) */
|
|
|
|
enter_blocking_section();
|
1997-11-25 07:29:46 -08:00
|
|
|
#ifndef NATIVE_CODE
|
|
|
|
/* Free the memory resources */
|
|
|
|
stat_free(th->stack_low);
|
|
|
|
#endif
|
|
|
|
/* Free the thread descriptor */
|
|
|
|
stat_free(th);
|
|
|
|
/* The thread now stops running */
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_thread_new(value clos) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1996-09-08 08:41:59 -07:00
|
|
|
caml_thread_t th;
|
1997-09-01 07:26:16 -07:00
|
|
|
value vthread = Val_unit;
|
|
|
|
value descr;
|
1996-09-04 07:17:43 -07:00
|
|
|
unsigned long th_id;
|
1997-05-26 10:16:31 -07:00
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
Begin_roots2 (clos, vthread)
|
|
|
|
/* Create a finalized value to hold thread handle */
|
1997-10-16 09:12:40 -07:00
|
|
|
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
|
|
|
|
caml_thread_finalize, 1, 1000);
|
1997-09-01 07:26:16 -07:00
|
|
|
((struct caml_thread_handle *)vthread)->handle = NULL;
|
|
|
|
/* Create a descriptor for the new thread */
|
1997-10-16 09:12:40 -07:00
|
|
|
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
|
1997-09-01 07:26:16 -07:00
|
|
|
Ident(descr) = Val_long(thread_next_ident);
|
|
|
|
Start_closure(descr) = clos;
|
1997-09-02 09:01:39 -07:00
|
|
|
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
|
1997-09-01 07:26:16 -07:00
|
|
|
thread_next_ident++;
|
|
|
|
/* Create an info block for the current thread */
|
|
|
|
th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
|
|
|
|
th->descr = descr;
|
|
|
|
#ifdef NATIVE_CODE
|
|
|
|
th->bottom_of_stack = NULL;
|
1997-12-02 05:12:07 -08:00
|
|
|
th->exception_pointer = NULL;
|
1997-09-01 07:26:16 -07:00
|
|
|
th->local_roots = NULL;
|
|
|
|
#else
|
|
|
|
/* Allocate the stacks */
|
1997-05-26 10:16:31 -07:00
|
|
|
th->stack_low = (value *) stat_alloc(Thread_stack_size);
|
|
|
|
th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
|
|
|
|
th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
|
|
|
|
th->sp = th->stack_high;
|
|
|
|
th->trapsp = th->stack_high;
|
|
|
|
th->local_roots = NULL;
|
1997-09-01 07:26:16 -07:00
|
|
|
th->external_raise = NULL;
|
|
|
|
#endif
|
|
|
|
/* Add thread info block to the list of threads */
|
|
|
|
th->next = curr_thread->next;
|
|
|
|
th->prev = curr_thread;
|
|
|
|
curr_thread->next->prev = th;
|
|
|
|
curr_thread->next = th;
|
1997-05-26 10:16:31 -07:00
|
|
|
/* Fork the new thread */
|
1997-09-01 07:26:16 -07:00
|
|
|
th->wthread =
|
1997-05-26 10:16:31 -07:00
|
|
|
CreateThread(NULL,0, (LPTHREAD_START_ROUTINE) caml_thread_start,
|
|
|
|
(void *) th, 0, &th_id);
|
1997-11-20 07:34:38 -08:00
|
|
|
if (th->wthread == NULL) {
|
|
|
|
/* Fork failed, remove thread info block from list of threads */
|
|
|
|
th->next->prev = curr_thread;
|
|
|
|
curr_thread->next = th->next;
|
|
|
|
#ifndef NATIVE_CODE
|
|
|
|
stat_free(th->stack_low);
|
|
|
|
#endif
|
|
|
|
stat_free(th);
|
|
|
|
caml_wthread_error("Thread.create");
|
|
|
|
}
|
1997-09-01 07:26:16 -07:00
|
|
|
((struct caml_thread_handle *)vthread)->handle = th->wthread;
|
1997-05-26 10:16:31 -07:00
|
|
|
End_roots();
|
1997-09-01 07:26:16 -07:00
|
|
|
return descr;
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Return the current thread */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_thread_self(value unit) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-01 07:26:16 -07:00
|
|
|
if (curr_thread == NULL) invalid_argument("Thread.self: not initialized");
|
|
|
|
return curr_thread->descr;
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Return the identifier of a thread */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_thread_id(value th) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-01 07:26:16 -07:00
|
|
|
return Ident(th);
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
/* Allow re-scheduling */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_thread_yield(value unit) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
enter_blocking_section();
|
|
|
|
Sleep(0);
|
|
|
|
leave_blocking_section();
|
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Suspend the current thread until another thread terminates */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_thread_join(value th) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-01 07:26:16 -07:00
|
|
|
HANDLE h = Threadhandle(th)->handle;
|
1996-09-04 07:17:43 -07:00
|
|
|
enter_blocking_section();
|
1997-09-01 07:26:16 -07:00
|
|
|
WaitForSingleObject(h, INFINITE);
|
1996-09-04 07:17:43 -07:00
|
|
|
leave_blocking_section();
|
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Mutex operations */
|
|
|
|
|
|
|
|
#define Mutex_val(v) (*((HANDLE *)(&Field(v, 1))))
|
|
|
|
#define Max_mutex_number 1000
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_mutex_finalize(value mut)
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-01 07:26:16 -07:00
|
|
|
CloseHandle(Mutex_val(mut));
|
1996-09-04 07:17:43 -07:00
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_mutex_new(value unit) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
value mut;
|
|
|
|
mut = alloc_final(1 + sizeof(HANDLE) / sizeof(value),
|
1996-09-08 08:41:59 -07:00
|
|
|
caml_mutex_finalize, 1, Max_mutex_number);
|
1996-09-04 07:17:43 -07:00
|
|
|
Mutex_val(mut) = CreateMutex(0, FALSE, NULL);
|
1997-09-01 07:26:16 -07:00
|
|
|
if (Mutex_val(mut) == NULL) caml_wthread_error("Mutex.create");
|
1996-09-04 07:17:43 -07:00
|
|
|
return mut;
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_mutex_lock(value mut) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
int retcode;
|
1998-04-25 07:09:56 -07:00
|
|
|
Begin_root(mut) /* prevent deallocation of mutex */
|
|
|
|
enter_blocking_section();
|
|
|
|
retcode = WaitForSingleObject(Mutex_val(mut), INFINITE);
|
|
|
|
leave_blocking_section();
|
|
|
|
End_roots();
|
1997-09-01 07:26:16 -07:00
|
|
|
if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock");
|
1996-09-04 07:17:43 -07:00
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_mutex_unlock(value mut) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
BOOL retcode;
|
1998-04-25 07:09:56 -07:00
|
|
|
Begin_root(mut) /* prevent deallocation of mutex */
|
|
|
|
enter_blocking_section();
|
|
|
|
retcode = ReleaseMutex(Mutex_val(mut));
|
|
|
|
leave_blocking_section();
|
|
|
|
End_roots();
|
1997-09-01 07:26:16 -07:00
|
|
|
if (!retcode) caml_wthread_error("Mutex.unlock");
|
1996-09-04 07:17:43 -07:00
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_mutex_try_lock(value mut) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
int retcode;
|
|
|
|
retcode = WaitForSingleObject(Mutex_val(mut), 0);
|
|
|
|
if (retcode == WAIT_FAILED || retcode == WAIT_ABANDONED)
|
1997-09-01 07:26:16 -07:00
|
|
|
caml_wthread_error("Mutex.try_lock");
|
1996-09-04 07:17:43 -07:00
|
|
|
return Val_bool(retcode == WAIT_OBJECT_0);
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Delay */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_thread_delay(value val) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
|
|
|
enter_blocking_section();
|
|
|
|
Sleep((DWORD)(Double_val(val)*1000)); /* milliseconds */
|
|
|
|
leave_blocking_section();
|
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
1997-09-01 07:26:16 -07:00
|
|
|
/* Conditions operations */
|
|
|
|
|
|
|
|
struct caml_condvar {
|
|
|
|
void (*final_fun)(); /* Finalization function */
|
|
|
|
unsigned long count; /* Number of waiting threads */
|
1997-09-02 09:01:39 -07:00
|
|
|
HANDLE sem; /* Semaphore on which threads are waiting */
|
1997-09-01 07:26:16 -07:00
|
|
|
};
|
|
|
|
|
|
|
|
#define Condition_val(v) ((struct caml_condvar *)(v))
|
|
|
|
#define Max_condition_number 1000
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_condition_finalize(value cond)
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
1997-09-02 09:01:39 -07:00
|
|
|
CloseHandle(Condition_val(cond)->sem);
|
1997-09-01 07:26:16 -07:00
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_condition_new(value unit) /* ML */
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
|
|
|
value cond;
|
|
|
|
cond = alloc_final(sizeof(struct caml_condvar) / sizeof(value),
|
|
|
|
caml_condition_finalize, 1, Max_condition_number);
|
1997-09-02 09:01:39 -07:00
|
|
|
Condition_val(cond)->sem = CreateSemaphore(NULL, 0, 0x7FFFFFFF, NULL);
|
|
|
|
if (Condition_val(cond)->sem == NULL)
|
1997-09-01 07:26:16 -07:00
|
|
|
caml_wthread_error("Condition.create");
|
|
|
|
Condition_val(cond)->count = 0;
|
|
|
|
return cond;
|
|
|
|
}
|
1996-09-04 07:17:43 -07:00
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_condition_wait(value cond, value mut) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-04 06:46:50 -07:00
|
|
|
int retcode;
|
1997-09-01 07:26:16 -07:00
|
|
|
HANDLE m = Mutex_val(mut);
|
1997-09-02 09:01:39 -07:00
|
|
|
HANDLE s = Condition_val(cond)->sem;
|
1997-09-04 06:46:50 -07:00
|
|
|
HANDLE handles[2];
|
1997-09-01 07:26:16 -07:00
|
|
|
|
|
|
|
Condition_val(cond)->count ++;
|
1998-04-25 07:09:56 -07:00
|
|
|
Begin_roots2(cond, mut) /* prevent deallocation of cond and mutex */
|
|
|
|
enter_blocking_section();
|
|
|
|
/* Release mutex */
|
|
|
|
ReleaseMutex(m);
|
|
|
|
/* Wait for semaphore to be non-null, and decrement it.
|
|
|
|
Simultaneously, re-acquire mutex. */
|
|
|
|
handles[0] = s;
|
|
|
|
handles[1] = m;
|
|
|
|
retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE);
|
|
|
|
leave_blocking_section();
|
|
|
|
End_roots();
|
1997-09-04 06:46:50 -07:00
|
|
|
if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
|
1997-09-01 07:26:16 -07:00
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_condition_signal(value cond) /* ML */
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
1997-09-02 09:01:39 -07:00
|
|
|
HANDLE s = Condition_val(cond)->sem;
|
1997-09-01 07:26:16 -07:00
|
|
|
|
|
|
|
if (Condition_val(cond)->count > 0) {
|
|
|
|
Condition_val(cond)->count --;
|
1998-04-25 07:09:56 -07:00
|
|
|
Begin_roots(cond) /* prevent deallocation of cond */
|
|
|
|
enter_blocking_section();
|
|
|
|
/* Increment semaphore by 1, waking up one waiter */
|
|
|
|
ReleaseSemaphore(s, 1, NULL);
|
|
|
|
leave_blocking_section();
|
|
|
|
End_roots();
|
1997-09-01 07:26:16 -07:00
|
|
|
}
|
1996-09-04 07:17:43 -07:00
|
|
|
return Val_unit;
|
|
|
|
}
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
value caml_condition_broadcast(value cond) /* ML */
|
1996-09-04 07:17:43 -07:00
|
|
|
{
|
1997-09-02 09:01:39 -07:00
|
|
|
HANDLE s = Condition_val(cond)->sem;
|
1997-09-01 07:26:16 -07:00
|
|
|
unsigned long c = Condition_val(cond)->count;
|
|
|
|
|
|
|
|
if (c > 0) {
|
|
|
|
Condition_val(cond)->count = 0;
|
1998-04-25 07:09:56 -07:00
|
|
|
Begin_roots(cond) /* prevent deallocation of cond */
|
|
|
|
enter_blocking_section();
|
|
|
|
/* Increment semaphore by c, waking up all waiters */
|
|
|
|
ReleaseSemaphore(s, c, NULL);
|
|
|
|
leave_blocking_section();
|
|
|
|
End_roots();
|
1997-09-01 07:26:16 -07:00
|
|
|
}
|
1996-09-04 07:17:43 -07:00
|
|
|
return Val_unit;
|
|
|
|
}
|
1997-09-01 07:26:16 -07:00
|
|
|
|
|
|
|
/* Error report */
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void caml_wthread_error(char * msg)
|
1997-09-01 07:26:16 -07:00
|
|
|
{
|
1997-09-02 09:01:39 -07:00
|
|
|
char errmsg[1024];
|
|
|
|
sprintf(errmsg, "%s: error code %x\n", msg, GetLastError());
|
|
|
|
raise_sys_error(copy_string(errmsg));
|
1997-09-01 07:26:16 -07:00
|
|
|
}
|