CAMLprim value caml_thread_initialize(value unit)
{
value vthread = Val_unit;
value descr;
HANDLE tick_thread;
DWORD th_id;
/* Protect against repeated initialization (PR#1325) */
if (curr_thread != NULL) return Val_unit;
Begin_root (vthread);
/* Initialize the main mutex and acquire it */
caml_mutex = CreateMutex(NULL, TRUE, NULL);
if (caml_mutex == NULL) caml_wthread_error("Thread.init");
/* Initialize the TLS keys */
thread_descriptor_key = TlsAlloc();
last_channel_locked_key = TlsAlloc();
/* Create a finalized value to hold thread handle */
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
caml_thread_finalize, 1, 1000);
((struct caml_thread_handle *)vthread)->handle = NULL;
/* Create a descriptor for the current thread */
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
Ident(descr) = Val_long(thread_next_ident);
Start_closure(descr) = Val_unit;
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
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 */
/* Associate the thread descriptor with the thread */
TlsSetValue(thread_descriptor_key, (void *) curr_thread);
/* Set up the hooks */
prev_scan_roots_hook = scan_roots_hook;
scan_roots_hook = caml_thread_scan_roots;
enter_blocking_section_hook = caml_thread_enter_blocking_section;
leave_blocking_section_hook = caml_thread_leave_blocking_section;
try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
caml_channel_mutex_free = caml_io_mutex_free;
caml_channel_mutex_lock = caml_io_mutex_lock;
caml_channel_mutex_unlock = caml_io_mutex_unlock;
caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
/* Fork the tick thread */
tick_thread = CreateThread(NULL, 0, caml_thread_tick, NULL, 0, &th_id);
if (tick_thread == NULL) caml_wthread_error("Thread.init");
CloseHandle(tick_thread);
End_roots();
return Val_unit;
}
CAMLprim value caml_thread_new(value clos)
{
caml_thread_t th;
value vthread = Val_unit;
value descr;
DWORD th_id;
Begin_roots2 (clos, vthread)
/* Create a finalized value to hold thread handle */
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
caml_thread_finalize, 1, 1000);
((struct caml_thread_handle *)vthread)->handle = NULL;
/* Create a descriptor for the new thread */
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
Ident(descr) = Val_long(thread_next_ident);
Start_closure(descr) = clos;
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
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;
th->exception_pointer = NULL;
th->local_roots = NULL;
#else
/* Allocate the stacks */
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;
th->external_raise = NULL;
th->backtrace_pos = 0;
th->backtrace_buffer = NULL;
th->backtrace_last_exn = Val_unit;
#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;
/* Fork the new thread */
th->wthread =
CreateThread(NULL, 0, caml_thread_start, (void *) th, 0, &th_id);
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");
}
((struct caml_thread_handle *)vthread)->handle = th->wthread;
End_roots();
return descr;
}
CAMLprim value caml_mutex_try_lock(value mut)
{
int retcode;
retcode = WaitForSingleObject(Mutex_val(mut), 0);
if (retcode == WAIT_FAILED || retcode == WAIT_ABANDONED)
caml_wthread_error("Mutex.try_lock");
return Val_bool(retcode == WAIT_OBJECT_0);
}
CAMLprim value caml_mutex_unlock(value mut)
{
BOOL retcode;
/* PR#4351: no need to release and reacquire master lock */
retcode = ReleaseMutex(Mutex_val(mut));
if (!retcode) caml_wthread_error("Mutex.unlock");
return Val_unit;
}
CAMLprim value caml_mutex_new(value unit)
{
value mut;
mut = alloc_custom(&caml_mutex_ops, sizeof(HANDLE), 1, Max_mutex_number);
Mutex_val(mut) = CreateMutex(0, FALSE, NULL);
if (Mutex_val(mut) == NULL) caml_wthread_error("Mutex.create");
return mut;
}
CAMLprim value caml_condition_new(value unit)
{
value cond;
cond = alloc_custom(&caml_condition_ops, sizeof(struct caml_condvar),
1, Max_condition_number);
Condition_val(cond)->sem = CreateSemaphore(NULL, 0, 0x7FFFFFFF, NULL);
if (Condition_val(cond)->sem == NULL)
caml_wthread_error("Condition.create");
Condition_val(cond)->count = 0;
return cond;
}
CAMLprim value caml_mutex_unlock(value mut)
{
BOOL retcode;
Begin_root(mut) /* prevent deallocation of mutex */
enter_blocking_section();
retcode = ReleaseMutex(Mutex_val(mut));
leave_blocking_section();
End_roots();
if (!retcode) caml_wthread_error("Mutex.unlock");
return Val_unit;
}
CAMLprim value caml_mutex_lock(value mut)
{
int retcode;
Begin_root(mut) /* prevent deallocation of mutex */
enter_blocking_section();
retcode = WaitForSingleObject(Mutex_val(mut), INFINITE);
leave_blocking_section();
End_roots();
if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock");
return Val_unit;
}
CAMLprim value caml_mutex_lock(value mut)
{
int retcode;
/* PR#4351: first try to acquire mutex without releasing the master lock */
retcode = WaitForSingleObject(Mutex_val(mut), 0);
if (retcode == WAIT_OBJECT_0) return Val_unit;
Begin_root(mut) /* prevent deallocation of mutex */
enter_blocking_section();
retcode = WaitForSingleObject(Mutex_val(mut), INFINITE);
leave_blocking_section();
End_roots();
if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock");
return Val_unit;
}
static void caml_io_mutex_lock(struct channel * chan)
{
if (chan->mutex == NULL) {
HANDLE mutex = CreateMutex(NULL, FALSE, NULL);
if (mutex == NULL) caml_wthread_error("Thread.iolock");
chan->mutex = (void *) mutex;
}
enter_blocking_section();
WaitForSingleObject((HANDLE) chan->mutex, INFINITE);
/* Problem: if a signal occurs at this point,
and the signal handler raises an exception, we will not
unlock the mutex. The alternative (doing the setspecific
before locking the mutex is also incorrect, since we could
then unlock a mutex that is unlocked or locked by someone else. */
TlsSetValue(last_channel_locked_key, (void *) chan);
leave_blocking_section();
}
CAMLprim value caml_condition_wait(value cond, value mut)
{
int retcode;
HANDLE m = Mutex_val(mut);
HANDLE s = Condition_val(cond)->sem;
HANDLE handles[2];
Condition_val(cond)->count ++;
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();
if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
return Val_unit;
}