1
/***********************************************************************/
5
/* Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt */
7
/* Copyright 1995 Institut National de Recherche en Informatique et */
8
/* en Automatique. All rights reserved. This file is distributed */
9
/* under the terms of the GNU Library General Public License, with */
10
/* the special exception on linking described in file ../../LICENSE. */
12
/***********************************************************************/
14
/* $Id: win32.c 8468 2007-10-31 09:12:29Z xleroy $ */
16
/* Thread interface for Win32 threads */
24
#include "backtrace.h"
42
/* Initial size of stack when a thread is created (4 Ko) */
43
#define Thread_stack_size (Stack_size / 4)
45
/* Max computation time before rescheduling, in milliseconds (50ms) */
46
#define Thread_timeout 50
48
/* Signal used for timer preemption (any unused, legal signal number) */
49
#define SIGTIMER SIGTERM
51
/* The ML value describing a thread (heap-allocated) */
53
struct caml_thread_handle {
54
value final_fun; /* Finalization function */
55
HANDLE handle; /* Windows handle */
58
struct caml_thread_descr {
59
value ident; /* Unique integer ID */
60
value start_closure; /* The closure to start this thread */
61
struct caml_thread_handle * thread_handle; /* Finalized object with handle */
64
#define Ident(v) (((struct caml_thread_descr *)(v))->ident)
65
#define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure)
66
#define Threadhandle(v) (((struct caml_thread_descr *)(v))->thread_handle)
68
/* The infos on threads (allocated via malloc()) */
70
struct caml_thread_struct {
71
HANDLE wthread; /* The Windows thread handle */
72
value descr; /* The heap-allocated descriptor (root) */
73
struct caml_thread_struct * next; /* Double linking of running threads */
74
struct caml_thread_struct * prev;
76
char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */
77
uintnat last_retaddr; /* Saved value of caml_last_return_address */
78
value * gc_regs; /* Saved value of caml_gc_regs */
79
char * exception_pointer; /* Saved value of caml_exception_pointer */
80
struct caml__roots_block * local_roots; /* Saved value of local_roots */
82
value * stack_low; /* The execution stack for this thread */
84
value * stack_threshold;
85
value * sp; /* Saved value of extern_sp for this thread */
86
value * trapsp; /* Saved value of trapsp for this thread */
87
struct caml__roots_block * local_roots; /* Saved value of local_roots */
88
struct longjmp_buffer * external_raise; /* Saved external_raise */
89
int backtrace_pos; /* Saved backtrace_pos */
90
code_t * backtrace_buffer; /* Saved backtrace_buffer */
91
value backtrace_last_exn; /* Saved backtrace_last_exn (root) */
95
typedef struct caml_thread_struct * caml_thread_t;
97
/* The descriptor for the currently executing thread (thread-specific) */
99
static caml_thread_t curr_thread = NULL;
101
/* The global mutex used to ensure that at most one thread is running
103
static HANDLE caml_mutex;
105
/* The key used for storing the thread descriptor in the specific data
106
of the corresponding Posix thread. */
107
static DWORD thread_descriptor_key;
109
/* The key used for unlocking I/O channels on exceptions */
110
static DWORD last_channel_locked_key;
112
/* Identifier for next thread creation */
113
static intnat thread_next_ident = 0;
115
/* Forward declarations */
117
static void caml_wthread_error (char * msg);
119
/* Hook for scanning the stacks of the other threads */
121
static void (*prev_scan_roots_hook) (scanning_action);
123
static void caml_thread_scan_roots(scanning_action action)
129
(*action)(th->descr, &th->descr);
131
(*action)(th->backtrace_last_exn, &th->backtrace_last_exn);
133
/* Don't rescan the stack of the current thread, it was done already */
134
if (th != curr_thread) {
136
if (th->bottom_of_stack != NULL)
137
do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
138
th->gc_regs, th->local_roots);
140
do_local_roots(action, th->sp, th->stack_high, th->local_roots);
144
} while (th != curr_thread);
146
if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
149
/* Hooks for enter_blocking_section and leave_blocking_section */
151
static void caml_thread_enter_blocking_section(void)
153
/* Save the stack-related global variables in the thread descriptor
154
of the current thread */
156
curr_thread->bottom_of_stack = caml_bottom_of_stack;
157
curr_thread->last_retaddr = caml_last_return_address;
158
curr_thread->gc_regs = caml_gc_regs;
159
curr_thread->exception_pointer = caml_exception_pointer;
160
curr_thread->local_roots = local_roots;
162
curr_thread->stack_low = stack_low;
163
curr_thread->stack_high = stack_high;
164
curr_thread->stack_threshold = stack_threshold;
165
curr_thread->sp = extern_sp;
166
curr_thread->trapsp = trapsp;
167
curr_thread->local_roots = local_roots;
168
curr_thread->external_raise = external_raise;
169
curr_thread->backtrace_pos = backtrace_pos;
170
curr_thread->backtrace_buffer = backtrace_buffer;
171
curr_thread->backtrace_last_exn = backtrace_last_exn;
173
/* Release the global mutex */
174
ReleaseMutex(caml_mutex);
177
static void caml_thread_leave_blocking_section(void)
179
WaitForSingleObject(caml_mutex, INFINITE);
180
/* Update curr_thread to point to the thread descriptor corresponding
181
to the thread currently executing */
182
curr_thread = TlsGetValue(thread_descriptor_key);
183
/* Restore the stack-related global variables */
185
caml_bottom_of_stack= curr_thread->bottom_of_stack;
186
caml_last_return_address = curr_thread->last_retaddr;
187
caml_gc_regs = curr_thread->gc_regs;
188
caml_exception_pointer = curr_thread->exception_pointer;
189
local_roots = curr_thread->local_roots;
191
stack_low = curr_thread->stack_low;
192
stack_high = curr_thread->stack_high;
193
stack_threshold = curr_thread->stack_threshold;
194
extern_sp = curr_thread->sp;
195
trapsp = curr_thread->trapsp;
196
local_roots = curr_thread->local_roots;
197
external_raise = curr_thread->external_raise;
198
backtrace_pos = curr_thread->backtrace_pos;
199
backtrace_buffer = curr_thread->backtrace_buffer;
200
backtrace_last_exn = curr_thread->backtrace_last_exn;
204
static int caml_thread_try_leave_blocking_section(void)
206
/* Disable immediate processing of signals (PR#3659).
207
try_leave_blocking_section always fails, forcing the signal to be
208
recorded and processed at the next leave_blocking_section or
213
/* Hooks for I/O locking */
215
static void caml_io_mutex_free(struct channel * chan)
217
HANDLE mutex = chan->mutex;
223
static void caml_io_mutex_lock(struct channel * chan)
225
if (chan->mutex == NULL) {
226
HANDLE mutex = CreateMutex(NULL, FALSE, NULL);
227
if (mutex == NULL) caml_wthread_error("Thread.iolock");
228
chan->mutex = (void *) mutex;
230
/* PR#4351: first try to acquire mutex without releasing the master lock */
231
if (WaitForSingleObject((HANDLE) chan->mutex, 0) == WAIT_OBJECT_0) {
232
TlsSetValue(last_channel_locked_key, (void *) chan);
235
enter_blocking_section();
236
WaitForSingleObject((HANDLE) chan->mutex, INFINITE);
237
/* Problem: if a signal occurs at this point,
238
and the signal handler raises an exception, we will not
239
unlock the mutex. The alternative (doing the setspecific
240
before locking the mutex is also incorrect, since we could
241
then unlock a mutex that is unlocked or locked by someone else. */
242
TlsSetValue(last_channel_locked_key, (void *) chan);
243
leave_blocking_section();
246
static void caml_io_mutex_unlock(struct channel * chan)
248
ReleaseMutex((HANDLE) chan->mutex);
249
TlsSetValue(last_channel_locked_key, NULL);
252
static void caml_io_mutex_unlock_exn(void)
254
struct channel * chan = TlsGetValue(last_channel_locked_key);
255
if (chan != NULL) caml_io_mutex_unlock(chan);
258
/* The "tick" thread fakes a signal at regular intervals. */
260
static DWORD WINAPI caml_thread_tick(void * arg)
263
Sleep(Thread_timeout);
264
caml_pending_signals[SIGTIMER] = 1;
265
caml_signals_are_pending = 1;
267
young_limit = young_end;
274
static void caml_thread_finalize(value vthread)
276
CloseHandle(((struct caml_thread_handle *)vthread)->handle);
279
/* Initialize the thread machinery */
281
CAMLprim value caml_thread_initialize(value unit)
283
value vthread = Val_unit;
288
/* Protect against repeated initialization (PR#1325) */
289
if (curr_thread != NULL) return Val_unit;
290
Begin_root (vthread);
291
/* Initialize the main mutex and acquire it */
292
caml_mutex = CreateMutex(NULL, TRUE, NULL);
293
if (caml_mutex == NULL) caml_wthread_error("Thread.init");
294
/* Initialize the TLS keys */
295
thread_descriptor_key = TlsAlloc();
296
last_channel_locked_key = TlsAlloc();
297
/* Create a finalized value to hold thread handle */
298
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
299
caml_thread_finalize, 1, 1000);
300
((struct caml_thread_handle *)vthread)->handle = NULL;
301
/* Create a descriptor for the current thread */
302
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
303
Ident(descr) = Val_long(thread_next_ident);
304
Start_closure(descr) = Val_unit;
305
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
307
/* Create an info block for the current thread */
309
(caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
310
DuplicateHandle(GetCurrentProcess(), GetCurrentThread(),
311
GetCurrentProcess(), &(curr_thread->wthread),
312
0, FALSE, DUPLICATE_SAME_ACCESS);
313
if (curr_thread->wthread == NULL) caml_wthread_error("Thread.init");
314
((struct caml_thread_handle *)vthread)->handle = curr_thread->wthread;
315
curr_thread->descr = descr;
316
curr_thread->next = curr_thread;
317
curr_thread->prev = curr_thread;
318
/* The stack-related fields will be filled in at the next
319
enter_blocking_section */
320
/* Associate the thread descriptor with the thread */
321
TlsSetValue(thread_descriptor_key, (void *) curr_thread);
322
/* Set up the hooks */
323
prev_scan_roots_hook = scan_roots_hook;
324
scan_roots_hook = caml_thread_scan_roots;
325
enter_blocking_section_hook = caml_thread_enter_blocking_section;
326
leave_blocking_section_hook = caml_thread_leave_blocking_section;
327
try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
328
caml_channel_mutex_free = caml_io_mutex_free;
329
caml_channel_mutex_lock = caml_io_mutex_lock;
330
caml_channel_mutex_unlock = caml_io_mutex_unlock;
331
caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
332
/* Fork the tick thread */
333
tick_thread = CreateThread(NULL, 0, caml_thread_tick, NULL, 0, &th_id);
334
if (tick_thread == NULL) caml_wthread_error("Thread.init");
335
CloseHandle(tick_thread);
340
/* Create a thread */
342
static DWORD WINAPI caml_thread_start(void * arg)
344
caml_thread_t th = (caml_thread_t) arg;
347
/* Associate the thread descriptor with the thread */
348
TlsSetValue(thread_descriptor_key, (void *) th);
349
TlsSetValue(last_channel_locked_key, NULL);
350
/* Acquire the global mutex and set up the stack variables */
351
leave_blocking_section();
352
/* Callback the closure */
353
clos = Start_closure(th->descr);
354
modify(&(Start_closure(th->descr)), Val_unit);
355
callback_exn(clos, Val_unit);
356
/* Remove th from the doubly-linked list of threads */
357
th->next->prev = th->prev;
358
th->prev->next = th->next;
359
/* Release the main mutex (forever) */
360
ReleaseMutex(caml_mutex);
362
/* Free the memory resources */
363
stat_free(th->stack_low);
364
if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
366
/* Free the thread descriptor */
368
/* The thread now stops running */
372
CAMLprim value caml_thread_new(value clos)
375
value vthread = Val_unit;
379
Begin_roots2 (clos, vthread)
380
/* Create a finalized value to hold thread handle */
381
vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
382
caml_thread_finalize, 1, 1000);
383
((struct caml_thread_handle *)vthread)->handle = NULL;
384
/* Create a descriptor for the new thread */
385
descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
386
Ident(descr) = Val_long(thread_next_ident);
387
Start_closure(descr) = clos;
388
Threadhandle(descr) = (struct caml_thread_handle *) vthread;
390
/* Create an info block for the current thread */
391
th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
394
th->bottom_of_stack = NULL;
395
th->exception_pointer = NULL;
396
th->local_roots = NULL;
398
/* Allocate the stacks */
399
th->stack_low = (value *) stat_alloc(Thread_stack_size);
400
th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
401
th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
402
th->sp = th->stack_high;
403
th->trapsp = th->stack_high;
404
th->local_roots = NULL;
405
th->external_raise = NULL;
406
th->backtrace_pos = 0;
407
th->backtrace_buffer = NULL;
408
th->backtrace_last_exn = Val_unit;
410
/* Add thread info block to the list of threads */
411
th->next = curr_thread->next;
412
th->prev = curr_thread;
413
curr_thread->next->prev = th;
414
curr_thread->next = th;
415
/* Fork the new thread */
417
CreateThread(NULL, 0, caml_thread_start, (void *) th, 0, &th_id);
418
if (th->wthread == NULL) {
419
/* Fork failed, remove thread info block from list of threads */
420
th->next->prev = curr_thread;
421
curr_thread->next = th->next;
423
stat_free(th->stack_low);
426
caml_wthread_error("Thread.create");
428
((struct caml_thread_handle *)vthread)->handle = th->wthread;
433
/* Return the current thread */
435
CAMLprim value caml_thread_self(value unit)
437
if (curr_thread == NULL) invalid_argument("Thread.self: not initialized");
438
return curr_thread->descr;
441
/* Return the identifier of a thread */
443
CAMLprim value caml_thread_id(value th)
448
/* Print uncaught exception and backtrace */
450
CAMLprim value caml_thread_uncaught_exception(value exn)
452
char * msg = format_caml_exception(exn);
453
fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
454
Int_val(Ident(curr_thread->descr)), msg);
457
if (backtrace_active) print_exception_backtrace();
463
/* Allow re-scheduling */
465
CAMLprim value caml_thread_yield(value unit)
467
enter_blocking_section();
469
leave_blocking_section();
473
/* Suspend the current thread until another thread terminates */
475
CAMLprim value caml_thread_join(value th)
479
Begin_root(th) /* prevent deallocation of handle */
480
h = Threadhandle(th)->handle;
481
enter_blocking_section();
482
WaitForSingleObject(h, INFINITE);
483
leave_blocking_section();
488
/* Mutex operations */
490
#define Mutex_val(v) (*((HANDLE *) Data_custom_val(v)))
491
#define Max_mutex_number 1000
493
static void caml_mutex_finalize(value mut)
495
CloseHandle(Mutex_val(mut));
498
static int caml_mutex_compare(value wrapper1, value wrapper2)
500
HANDLE h1 = Mutex_val(wrapper1);
501
HANDLE h2 = Mutex_val(wrapper2);
502
return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
505
static struct custom_operations caml_mutex_ops = {
510
custom_serialize_default,
511
custom_deserialize_default
514
CAMLprim value caml_mutex_new(value unit)
517
mut = alloc_custom(&caml_mutex_ops, sizeof(HANDLE), 1, Max_mutex_number);
518
Mutex_val(mut) = CreateMutex(0, FALSE, NULL);
519
if (Mutex_val(mut) == NULL) caml_wthread_error("Mutex.create");
523
CAMLprim value caml_mutex_lock(value mut)
526
/* PR#4351: first try to acquire mutex without releasing the master lock */
527
retcode = WaitForSingleObject(Mutex_val(mut), 0);
528
if (retcode == WAIT_OBJECT_0) return Val_unit;
529
Begin_root(mut) /* prevent deallocation of mutex */
530
enter_blocking_section();
531
retcode = WaitForSingleObject(Mutex_val(mut), INFINITE);
532
leave_blocking_section();
534
if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock");
538
CAMLprim value caml_mutex_unlock(value mut)
541
/* PR#4351: no need to release and reacquire master lock */
542
retcode = ReleaseMutex(Mutex_val(mut));
543
if (!retcode) caml_wthread_error("Mutex.unlock");
547
CAMLprim value caml_mutex_try_lock(value mut)
550
retcode = WaitForSingleObject(Mutex_val(mut), 0);
551
if (retcode == WAIT_FAILED || retcode == WAIT_ABANDONED)
552
caml_wthread_error("Mutex.try_lock");
553
return Val_bool(retcode == WAIT_OBJECT_0);
558
CAMLprim value caml_thread_delay(value val)
560
enter_blocking_section();
561
Sleep((DWORD)(Double_val(val)*1000)); /* milliseconds */
562
leave_blocking_section();
566
/* Conditions operations */
568
struct caml_condvar {
569
uintnat count; /* Number of waiting threads */
570
HANDLE sem; /* Semaphore on which threads are waiting */
573
#define Condition_val(v) ((struct caml_condvar *) Data_custom_val(v))
574
#define Max_condition_number 1000
576
static void caml_condition_finalize(value cond)
578
CloseHandle(Condition_val(cond)->sem);
581
static int caml_condition_compare(value wrapper1, value wrapper2)
583
HANDLE h1 = Condition_val(wrapper1)->sem;
584
HANDLE h2 = Condition_val(wrapper2)->sem;
585
return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
588
static struct custom_operations caml_condition_ops = {
590
caml_condition_finalize,
591
caml_condition_compare,
593
custom_serialize_default,
594
custom_deserialize_default
597
CAMLprim value caml_condition_new(value unit)
600
cond = alloc_custom(&caml_condition_ops, sizeof(struct caml_condvar),
601
1, Max_condition_number);
602
Condition_val(cond)->sem = CreateSemaphore(NULL, 0, 0x7FFFFFFF, NULL);
603
if (Condition_val(cond)->sem == NULL)
604
caml_wthread_error("Condition.create");
605
Condition_val(cond)->count = 0;
609
CAMLprim value caml_condition_wait(value cond, value mut)
612
HANDLE m = Mutex_val(mut);
613
HANDLE s = Condition_val(cond)->sem;
616
Condition_val(cond)->count ++;
617
Begin_roots2(cond, mut) /* prevent deallocation of cond and mutex */
618
enter_blocking_section();
621
/* Wait for semaphore to be non-null, and decrement it.
622
Simultaneously, re-acquire mutex. */
625
retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE);
626
leave_blocking_section();
628
if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
632
CAMLprim value caml_condition_signal(value cond)
634
HANDLE s = Condition_val(cond)->sem;
636
if (Condition_val(cond)->count > 0) {
637
Condition_val(cond)->count --;
638
/* Increment semaphore by 1, waking up one waiter */
639
ReleaseSemaphore(s, 1, NULL);
644
CAMLprim value caml_condition_broadcast(value cond)
646
HANDLE s = Condition_val(cond)->sem;
647
uintnat c = Condition_val(cond)->count;
650
Condition_val(cond)->count = 0;
651
/* Increment semaphore by c, waking up all waiters */
652
ReleaseSemaphore(s, c, NULL);
659
static void caml_wthread_error(char * msg)
662
sprintf(errmsg, "%s: error code %lx", msg, GetLastError());
663
raise_sys_error(copy_string(errmsg));
added
removed
otherlibs/systhreads/win32.c
