l4/pkg/ocaml/contrib/otherlibs/systhreads/win32.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                         Objective Caml                              */
   4 /*                                                                     */
   5 /*           Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt          */
   6 /*                                                                     */
   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.  */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id: win32.c 8468 2007-10-31 09:12:29Z xleroy $ */
  15
  16 /* Thread interface for Win32 threads */
  17
  18 #include <windows.h>
  19 #include <process.h>
  20 #include <signal.h>
  21 #include <stdio.h>
  22 #include <stdlib.h>
  23 #include "alloc.h"
  24 #include "backtrace.h"
  25 #include "callback.h"
  26 #include "custom.h"
  27 #include "fail.h"
  28 #include "io.h"
  29 #include "memory.h"
  30 #include "misc.h"
  31 #include "mlvalues.h"
  32 #include "printexc.h"
  33 #include "roots.h"
  34 #include "signals.h"
  35 #ifdef NATIVE_CODE
  36 #include "stack.h"
  37 #else
  38 #include "stacks.h"
  39 #endif
  40 #include "sys.h"
  41
  42 /* Initial size of stack when a thread is created (4 Ko) */
  43 #define Thread_stack_size (Stack_size / 4)
  44
  45 /* Max computation time before rescheduling, in milliseconds (50ms) */
  46 #define Thread_timeout 50
  47
  48 /* Signal used for timer preemption (any unused, legal signal number) */
  49 #define SIGTIMER SIGTERM
  50
  51 /* The ML value describing a thread (heap-allocated) */
  52
  53 struct caml_thread_handle {
  54   value final_fun;              /* Finalization function */
  55   HANDLE handle;                /* Windows handle */
  56 };
  57
  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 */
  62 };
  63
  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)
  67
  68 /* The infos on threads (allocated via malloc()) */
  69
  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;
  75 #ifdef NATIVE_CODE
  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 */
  81 #else
  82   value * stack_low;            /* The execution stack for this thread */
  83   value * stack_high;
  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) */
  92 #endif
  93 };
  94
  95 typedef struct caml_thread_struct * caml_thread_t;
  96
  97 /* The descriptor for the currently executing thread (thread-specific) */
  98
  99 static caml_thread_t curr_thread = NULL;
 100
 101 /* The global mutex used to ensure that at most one thread is running
 102    Caml code */
 103 static HANDLE caml_mutex;
 104
 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;
 108
 109 /* The key used for unlocking I/O channels on exceptions */
 110 static DWORD last_channel_locked_key;
 111
 112 /* Identifier for next thread creation */
 113 static intnat thread_next_ident = 0;
 114
 115 /* Forward declarations */
 116
 117 static void caml_wthread_error (char * msg);
 118
 119 /* Hook for scanning the stacks of the other threads */
 120
 121 static void (*prev_scan_roots_hook) (scanning_action);
 122
 123 static void caml_thread_scan_roots(scanning_action action)
 124 {
 125   caml_thread_t th;
 126
 127   th = curr_thread;
 128   do {
 129     (*action)(th->descr, &th->descr);
 130 #ifndef NATIVE_CODE
 131     (*action)(th->backtrace_last_exn, &th->backtrace_last_exn);
 132 #endif
 133     /* Don't rescan the stack of the current thread, it was done already */
 134     if (th != curr_thread) {
 135 #ifdef NATIVE_CODE
 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);
 139 #else
 140       do_local_roots(action, th->sp, th->stack_high, th->local_roots);
 141 #endif
 142     }
 143     th = th->next;
 144   } while (th != curr_thread);
 145   /* Hook */
 146   if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
 147 }
 148
 149 /* Hooks for enter_blocking_section and leave_blocking_section */
 150
 151 static void caml_thread_enter_blocking_section(void)
 152 {
 153   /* Save the stack-related global variables in the thread descriptor
 154      of the current thread */
 155 #ifdef NATIVE_CODE
 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;
 161 #else
 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;
 172 #endif
 173   /* Release the global mutex */
 174   ReleaseMutex(caml_mutex);
 175 }
 176
 177 static void caml_thread_leave_blocking_section(void)
 178 {
 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 */
 184 #ifdef NATIVE_CODE
 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;
 190 #else
 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;
 201 #endif
 202 }
 203
 204 static int caml_thread_try_leave_blocking_section(void)
 205 {
 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
 209      polling. */
 210   return 0;
 211 }
 212
 213 /* Hooks for I/O locking */
 214
 215 static void caml_io_mutex_free(struct channel * chan)
 216 {
 217   HANDLE mutex = chan->mutex;
 218   if (mutex != NULL) {
 219     CloseHandle(mutex);
 220   }
 221 }
 222
 223 static void caml_io_mutex_lock(struct channel * chan)
 224 {
 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;
 229   }
 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);
 233     return;
 234   }
 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();
 244 }
 245
 246 static void caml_io_mutex_unlock(struct channel * chan)
 247 {
 248   ReleaseMutex((HANDLE) chan->mutex);
 249   TlsSetValue(last_channel_locked_key, NULL);
 250 }
 251
 252 static void caml_io_mutex_unlock_exn(void)
 253 {
 254   struct channel * chan = TlsGetValue(last_channel_locked_key);
 255   if (chan != NULL) caml_io_mutex_unlock(chan);
 256 }
 257
 258 /* The "tick" thread fakes a signal at regular intervals. */
 259
 260 static DWORD WINAPI caml_thread_tick(void * arg)
 261 {
 262   while(1) {
 263     Sleep(Thread_timeout);
 264     caml_pending_signals[SIGTIMER] = 1;
 265     caml_signals_are_pending = 1;
 266 #ifdef NATIVE_CODE
 267     young_limit = young_end;
 268 #else
 269     something_to_do = 1;
 270 #endif
 271   }
 272 }
 273
 274 static void caml_thread_finalize(value vthread)
 275 {
 276   CloseHandle(((struct caml_thread_handle *)vthread)->handle);
 277 }
 278
 279 /* Initialize the thread machinery */
 280
 281 CAMLprim value caml_thread_initialize(value unit)
 282 {
 283   value vthread = Val_unit;
 284   value descr;
 285   HANDLE tick_thread;
 286   DWORD th_id;
 287
 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;
 306     thread_next_ident++;
 307     /* Create an info block for the current thread */
 308     curr_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);
 336   End_roots();
 337   return Val_unit;
 338 }
 339
 340 /* Create a thread */
 341
 342 static DWORD WINAPI caml_thread_start(void * arg)
 343 {
 344   caml_thread_t th = (caml_thread_t) arg;
 345   value clos;
 346
 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);
 361 #ifndef NATIVE_CODE
 362   /* Free the memory resources */
 363   stat_free(th->stack_low);
 364   if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
 365 #endif
 366   /* Free the thread descriptor */
 367   stat_free(th);
 368   /* The thread now stops running */
 369   return 0;
 370 }
 371
 372 CAMLprim value caml_thread_new(value clos)
 373 {
 374   caml_thread_t th;
 375   value vthread = Val_unit;
 376   value descr;
 377   DWORD th_id;
 378
 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;
 389     thread_next_ident++;
 390     /* Create an info block for the current thread */
 391     th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
 392     th->descr = descr;
 393 #ifdef NATIVE_CODE
 394     th->bottom_of_stack = NULL;
 395     th->exception_pointer = NULL;
 396     th->local_roots = NULL;
 397 #else
 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;
 409 #endif
 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 */
 416     th->wthread =
 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;
 422 #ifndef NATIVE_CODE
 423       stat_free(th->stack_low);
 424 #endif
 425       stat_free(th);
 426       caml_wthread_error("Thread.create");
 427     }
 428     ((struct caml_thread_handle *)vthread)->handle = th->wthread;
 429   End_roots();
 430   return descr;
 431 }
 432
 433 /* Return the current thread */
 434
 435 CAMLprim value caml_thread_self(value unit)
 436 {
 437   if (curr_thread == NULL) invalid_argument("Thread.self: not initialized");
 438   return curr_thread->descr;
 439 }
 440
 441 /* Return the identifier of a thread */
 442
 443 CAMLprim value caml_thread_id(value th)
 444 {
 445   return Ident(th);
 446 }
 447
 448 /* Print uncaught exception and backtrace */
 449
 450 CAMLprim value caml_thread_uncaught_exception(value exn)
 451 {
 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);
 455   free(msg);
 456 #ifndef NATIVE_CODE
 457   if (backtrace_active) print_exception_backtrace();
 458 #endif
 459   fflush(stderr);
 460   return Val_unit;
 461 }
 462
 463 /* Allow re-scheduling */
 464
 465 CAMLprim value caml_thread_yield(value unit)
 466 {
 467   enter_blocking_section();
 468   Sleep(0);
 469   leave_blocking_section();
 470   return Val_unit;
 471 }
 472
 473 /* Suspend the current thread until another thread terminates */
 474
 475 CAMLprim value caml_thread_join(value th)
 476 {
 477   HANDLE h;
 478
 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();
 484   End_roots();
 485   return Val_unit;
 486 }
 487
 488 /* Mutex operations */
 489
 490 #define Mutex_val(v) (*((HANDLE *) Data_custom_val(v)))
 491 #define Max_mutex_number 1000
 492
 493 static void caml_mutex_finalize(value mut)
 494 {
 495   CloseHandle(Mutex_val(mut));
 496 }
 497
 498 static int caml_mutex_compare(value wrapper1, value wrapper2)
 499 {
 500   HANDLE h1 = Mutex_val(wrapper1);
 501   HANDLE h2 = Mutex_val(wrapper2);
 502   return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
 503 }
 504
 505 static struct custom_operations caml_mutex_ops = {
 506   "_mutex",
 507   caml_mutex_finalize,
 508   caml_mutex_compare,
 509   custom_hash_default,
 510   custom_serialize_default,
 511   custom_deserialize_default
 512 };
 513
 514 CAMLprim value caml_mutex_new(value unit)
 515 {
 516   value mut;
 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");
 520   return mut;
 521 }
 522
 523 CAMLprim value caml_mutex_lock(value mut)
 524 {
 525   int retcode;
 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();
 533   End_roots();
 534   if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock");
 535   return Val_unit;
 536 }
 537
 538 CAMLprim value caml_mutex_unlock(value mut)
 539 {
 540   BOOL retcode;
 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");
 544   return Val_unit;
 545 }
 546
 547 CAMLprim value caml_mutex_try_lock(value mut)
 548 {
 549   int retcode;
 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);
 554 }
 555
 556 /* Delay */
 557
 558 CAMLprim value caml_thread_delay(value val)
 559 {
 560   enter_blocking_section();
 561   Sleep((DWORD)(Double_val(val)*1000)); /* milliseconds */
 562   leave_blocking_section();
 563   return Val_unit;
 564 }
 565
 566 /* Conditions operations */
 567
 568 struct caml_condvar {
 569   uintnat count;          /* Number of waiting threads */
 570   HANDLE sem;                   /* Semaphore on which threads are waiting */
 571 };
 572
 573 #define Condition_val(v) ((struct caml_condvar *) Data_custom_val(v))
 574 #define Max_condition_number 1000
 575
 576 static void caml_condition_finalize(value cond)
 577 {
 578   CloseHandle(Condition_val(cond)->sem);
 579 }
 580
 581 static int caml_condition_compare(value wrapper1, value wrapper2)
 582 {
 583   HANDLE h1 = Condition_val(wrapper1)->sem;
 584   HANDLE h2 = Condition_val(wrapper2)->sem;
 585   return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
 586 }
 587
 588 static struct custom_operations caml_condition_ops = {
 589   "_condition",
 590   caml_condition_finalize,
 591   caml_condition_compare,
 592   custom_hash_default,
 593   custom_serialize_default,
 594   custom_deserialize_default
 595 };
 596
 597 CAMLprim value caml_condition_new(value unit)
 598 {
 599   value cond;
 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;
 606   return cond;
 607 }
 608
 609 CAMLprim value caml_condition_wait(value cond, value mut)
 610 {
 611   int retcode;
 612   HANDLE m = Mutex_val(mut);
 613   HANDLE s = Condition_val(cond)->sem;
 614   HANDLE handles[2];
 615
 616   Condition_val(cond)->count ++;
 617   Begin_roots2(cond, mut)       /* prevent deallocation of cond and mutex */
 618     enter_blocking_section();
 619     /* Release mutex */
 620     ReleaseMutex(m);
 621     /* Wait for semaphore to be non-null, and decrement it.
 622        Simultaneously, re-acquire mutex. */
 623     handles[0] = s;
 624     handles[1] = m;
 625     retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE);
 626     leave_blocking_section();
 627   End_roots();
 628   if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
 629   return Val_unit;
 630 }
 631
 632 CAMLprim value caml_condition_signal(value cond)
 633 {
 634   HANDLE s = Condition_val(cond)->sem;
 635
 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);
 640   }
 641   return Val_unit;
 642 }
 643
 644 CAMLprim value caml_condition_broadcast(value cond)
 645 {
 646   HANDLE s = Condition_val(cond)->sem;
 647   uintnat c = Condition_val(cond)->count;
 648
 649   if (c > 0) {
 650     Condition_val(cond)->count = 0;
 651     /* Increment semaphore by c, waking up all waiters */
 652     ReleaseSemaphore(s, c, NULL);
 653   }
 654   return Val_unit;
 655 }
 656
 657 /* Error report */
 658
 659 static void caml_wthread_error(char * msg)
 660 {
 661   char errmsg[1024];
 662   sprintf(errmsg, "%s: error code %lx", msg, GetLastError());
 663   raise_sys_error(copy_string(errmsg));
 664 }