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

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                             Objective Caml                          */
   4 /*                                                                     */
   5 /*         Xavier Leroy and Damien Doligez, 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: posix.c 9201 2009-03-28 17:35:59Z xleroy $ */
  15
  16 /* Thread interface for POSIX 1003.1c threads */
  17
  18 #include <errno.h>
  19 #include <string.h>
  20 #include <stdio.h>
  21 #include <stdlib.h>
  22 #include <pthread.h>
  23 #ifdef __sun
  24 #define _POSIX_PTHREAD_SEMANTICS
  25 #endif
  26 #include <signal.h>
  27 #include <sys/time.h>
  28 #ifdef __linux__
  29 #include <unistd.h>
  30 #endif
  31 #include "alloc.h"
  32 #include "backtrace.h"
  33 #include "callback.h"
  34 #include "custom.h"
  35 #include "fail.h"
  36 #include "io.h"
  37 #include "memory.h"
  38 #include "misc.h"
  39 #include "mlvalues.h"
  40 #include "printexc.h"
  41 #include "roots.h"
  42 #include "signals.h"
  43 #ifdef NATIVE_CODE
  44 #include "stack.h"
  45 #else
  46 #include "stacks.h"
  47 #endif
  48 #include "sys.h"
  49
  50 /* Initial size of stack when a thread is created (4 Ko) */
  51 #define Thread_stack_size (Stack_size / 4)
  52
  53 /* Max computation time before rescheduling, in microseconds (50ms) */
  54 #define Thread_timeout 50000
  55
  56 /* The ML value describing a thread (heap-allocated) */
  57
  58 struct caml_thread_descr {
  59   value ident;                  /* Unique integer ID */
  60   value start_closure;          /* The closure to start this thread */
  61   value terminated;             /* Mutex held while the thread is running */
  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 Terminated(v) (((struct caml_thread_descr *)(v))->terminated)
  67
  68 /* The infos on threads (allocated via malloc()) */
  69
  70 struct caml_thread_struct {
  71   pthread_t pthread;            /* The Posix thread id */
  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   struct longjmp_buffer * exit_buf; /* For thread exit */
  82 #else
  83   value * stack_low;            /* The execution stack for this thread */
  84   value * stack_high;
  85   value * stack_threshold;
  86   value * sp;                   /* Saved value of extern_sp for this thread */
  87   value * trapsp;               /* Saved value of trapsp for this thread */
  88   struct caml__roots_block * local_roots; /* Saved value of local_roots */
  89   struct longjmp_buffer * external_raise; /* Saved external_raise */
  90 #endif
  91   int backtrace_pos;            /* Saved backtrace_pos */
  92   code_t * backtrace_buffer;    /* Saved backtrace_buffer */
  93   value backtrace_last_exn;     /* Saved backtrace_last_exn (root) */
  94 };
  95
  96 typedef struct caml_thread_struct * caml_thread_t;
  97
  98 /* The descriptor for the currently executing thread */
  99 static caml_thread_t curr_thread = NULL;
 100
 101 /* Track whether one thread is running Caml code.  There can be
 102    at most one such thread at any time. */
 103 static volatile int caml_runtime_busy = 1;
 104
 105 /* Number of threads waiting to run Caml code. */
 106 static volatile int caml_runtime_waiters = 0;
 107
 108 /* Mutex that protects the two variables above. */
 109 static pthread_mutex_t caml_runtime_mutex = PTHREAD_MUTEX_INITIALIZER;
 110
 111 /* Condition signaled when caml_runtime_busy becomes 0 */
 112 static pthread_cond_t caml_runtime_is_free = PTHREAD_COND_INITIALIZER;
 113
 114 /* Whether the ``tick'' thread is already running */
 115 static int caml_tick_thread_running = 0;
 116
 117 /* The key used for storing the thread descriptor in the specific data
 118    of the corresponding Posix thread. */
 119 static pthread_key_t thread_descriptor_key;
 120
 121 /* The key used for unlocking I/O channels on exceptions */
 122 static pthread_key_t last_channel_locked_key;
 123
 124 /* Identifier for next thread creation */
 125 static intnat thread_next_ident = 0;
 126
 127 /* Forward declarations */
 128 value caml_threadstatus_new (void);
 129 void caml_threadstatus_terminate (value);
 130 int caml_threadstatus_wait (value);
 131 static void caml_pthread_check (int, char *);
 132
 133 /* Imports for the native-code compiler */
 134 extern struct longjmp_buffer caml_termination_jmpbuf;
 135 extern void (*caml_termination_hook)(void *);
 136
 137 /* Hook for scanning the stacks of the other threads */
 138
 139 static void (*prev_scan_roots_hook) (scanning_action);
 140
 141 static void caml_thread_scan_roots(scanning_action action)
 142 {
 143   caml_thread_t th;
 144
 145   th = curr_thread;
 146   do {
 147     (*action)(th->descr, &th->descr);
 148     (*action)(th->backtrace_last_exn, &th->backtrace_last_exn);
 149     /* Don't rescan the stack of the current thread, it was done already */
 150     if (th != curr_thread) {
 151 #ifdef NATIVE_CODE
 152       if (th->bottom_of_stack != NULL)
 153         do_local_roots(action, th->bottom_of_stack, th->last_retaddr,
 154                        th->gc_regs, th->local_roots);
 155 #else
 156       do_local_roots(action, th->sp, th->stack_high, th->local_roots);
 157 #endif
 158     }
 159     th = th->next;
 160   } while (th != curr_thread);
 161   /* Hook */
 162   if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
 163 }
 164
 165 /* Hooks for enter_blocking_section and leave_blocking_section */
 166
 167 static void caml_thread_enter_blocking_section(void)
 168 {
 169   /* Save the stack-related global variables in the thread descriptor
 170      of the current thread */
 171 #ifdef NATIVE_CODE
 172   curr_thread->bottom_of_stack = caml_bottom_of_stack;
 173   curr_thread->last_retaddr = caml_last_return_address;
 174   curr_thread->gc_regs = caml_gc_regs;
 175   curr_thread->exception_pointer = caml_exception_pointer;
 176   curr_thread->local_roots = local_roots;
 177 #else
 178   curr_thread->stack_low = stack_low;
 179   curr_thread->stack_high = stack_high;
 180   curr_thread->stack_threshold = stack_threshold;
 181   curr_thread->sp = extern_sp;
 182   curr_thread->trapsp = trapsp;
 183   curr_thread->local_roots = local_roots;
 184   curr_thread->external_raise = external_raise;
 185 #endif
 186   curr_thread->backtrace_pos = backtrace_pos;
 187   curr_thread->backtrace_buffer = backtrace_buffer;
 188   curr_thread->backtrace_last_exn = backtrace_last_exn;
 189   /* Tell other threads that the runtime is free */
 190   pthread_mutex_lock(&caml_runtime_mutex);
 191   caml_runtime_busy = 0;
 192   pthread_mutex_unlock(&caml_runtime_mutex);
 193   pthread_cond_signal(&caml_runtime_is_free);
 194 }
 195
 196 static void caml_thread_leave_blocking_section(void)
 197 {
 198   /* Wait until the runtime is free */
 199   pthread_mutex_lock(&caml_runtime_mutex);
 200   while (caml_runtime_busy) {
 201     caml_runtime_waiters++;
 202     pthread_cond_wait(&caml_runtime_is_free, &caml_runtime_mutex);
 203     caml_runtime_waiters--;
 204   }
 205   caml_runtime_busy = 1;
 206   pthread_mutex_unlock(&caml_runtime_mutex);
 207   /* Update curr_thread to point to the thread descriptor corresponding
 208      to the thread currently executing */
 209   curr_thread = pthread_getspecific(thread_descriptor_key);
 210   /* Restore the stack-related global variables */
 211 #ifdef NATIVE_CODE
 212   caml_bottom_of_stack= curr_thread->bottom_of_stack;
 213   caml_last_return_address = curr_thread->last_retaddr;
 214   caml_gc_regs = curr_thread->gc_regs;
 215   caml_exception_pointer = curr_thread->exception_pointer;
 216   local_roots = curr_thread->local_roots;
 217 #else
 218   stack_low = curr_thread->stack_low;
 219   stack_high = curr_thread->stack_high;
 220   stack_threshold = curr_thread->stack_threshold;
 221   extern_sp = curr_thread->sp;
 222   trapsp = curr_thread->trapsp;
 223   local_roots = curr_thread->local_roots;
 224   external_raise = curr_thread->external_raise;
 225 #endif
 226   backtrace_pos = curr_thread->backtrace_pos;
 227   backtrace_buffer = curr_thread->backtrace_buffer;
 228   backtrace_last_exn = curr_thread->backtrace_last_exn;
 229 }
 230
 231 static int caml_thread_try_leave_blocking_section(void)
 232 {
 233   /* Disable immediate processing of signals (PR#3659).
 234      try_leave_blocking_section always fails, forcing the signal to be
 235      recorded and processed at the next leave_blocking_section or
 236      polling. */
 237   return 0;
 238 }
 239
 240 /* Hooks for I/O locking */
 241
 242 static void caml_io_mutex_free(struct channel *chan)
 243 {
 244   pthread_mutex_t * mutex = chan->mutex;
 245   if (mutex != NULL) {
 246     pthread_mutex_destroy(mutex);
 247     stat_free((char *) mutex);
 248   }
 249 }
 250
 251 static void caml_io_mutex_lock(struct channel *chan)
 252 {
 253   if (chan->mutex == NULL) {
 254     pthread_mutex_t * mutex =
 255       (pthread_mutex_t *) stat_alloc(sizeof(pthread_mutex_t));
 256     pthread_mutex_init(mutex, NULL);
 257     chan->mutex = (void *) mutex;
 258   }
 259   /* PR#4351: first try to acquire mutex without releasing the master lock */
 260   if (pthread_mutex_trylock(chan->mutex) == 0) {
 261     pthread_setspecific(last_channel_locked_key, (void *) chan);
 262     return;
 263   }
 264   /* If unsuccessful, block on mutex */
 265   enter_blocking_section();
 266   pthread_mutex_lock(chan->mutex);
 267   /* Problem: if a signal occurs at this point,
 268      and the signal handler raises an exception, we will not
 269      unlock the mutex.  The alternative (doing the setspecific
 270      before locking the mutex is also incorrect, since we could
 271      then unlock a mutex that is unlocked or locked by someone else. */
 272   pthread_setspecific(last_channel_locked_key, (void *) chan);
 273   leave_blocking_section();
 274 }
 275
 276 static void caml_io_mutex_unlock(struct channel *chan)
 277 {
 278   pthread_mutex_unlock(chan->mutex);
 279   pthread_setspecific(last_channel_locked_key, NULL);
 280 }
 281
 282 static void caml_io_mutex_unlock_exn(void)
 283 {
 284   struct channel * chan = pthread_getspecific(last_channel_locked_key);
 285   if (chan != NULL) caml_io_mutex_unlock(chan);
 286 }
 287
 288 /* The "tick" thread fakes a SIGVTALRM signal at regular intervals. */
 289
 290 static void * caml_thread_tick(void * arg)
 291 {
 292   struct timeval timeout;
 293   sigset_t mask;
 294 #ifdef __linux__
 295   int tickcount = 0;
 296 #endif
 297
 298   /* Block all signals so that we don't try to execute
 299      a Caml signal handler */
 300   sigfillset(&mask);
 301   pthread_sigmask(SIG_BLOCK, &mask, NULL);
 302   while(1) {
 303     /* select() seems to be the most efficient way to suspend the
 304        thread for sub-second intervals */
 305     timeout.tv_sec = 0;
 306     timeout.tv_usec = Thread_timeout;
 307     select(0, NULL, NULL, NULL, &timeout);
 308     /* This signal should never cause a callback, so don't go through
 309        handle_signal(), tweak the global variable directly. */
 310     caml_pending_signals[SIGVTALRM] = 1;
 311     caml_signals_are_pending = 1;
 312 #ifdef NATIVE_CODE
 313     young_limit = young_end;
 314 #else
 315     something_to_do = 1;
 316 #endif
 317 #ifdef __linux__
 318     /* Hack around LinuxThreads' non-standard signal handling:
 319        if program is killed on a signal, e.g. SIGINT, the current
 320        thread will not die on this signal (because of the signal blocking
 321        above).  Hence, periodically check that the thread manager (our
 322        parent process) still exists. */
 323     tickcount++;
 324     if (tickcount >= 2000000 / Thread_timeout) { /* every 2 secs approx */
 325       tickcount = 0;
 326       if (getppid() == 1) pthread_exit(NULL);
 327     }
 328 #endif
 329   }
 330   return NULL;                  /* prevents compiler warning */
 331 }
 332
 333 /* Reinitialize the thread machinery after a fork() (PR#4577) */
 334
 335 static void caml_thread_reinitialize(void)
 336 {
 337   caml_thread_t thr, next;
 338   struct channel * chan;
 339
 340   /* Remove all other threads (now nonexistent)
 341      from the doubly-linked list of threads */
 342   thr = curr_thread->next;
 343   while (thr != curr_thread) {
 344     next = thr->next;
 345     stat_free(thr);
 346     thr = next;
 347   }
 348   curr_thread->next = curr_thread;
 349   curr_thread->prev = curr_thread;
 350   /* Reinitialize the master lock machinery,
 351      just in case the fork happened while other threads were doing
 352      leave_blocking_section */
 353   pthread_mutex_init(&caml_runtime_mutex, NULL);
 354   pthread_cond_init(&caml_runtime_is_free, NULL);
 355   caml_runtime_waiters = 0;     /* no other thread is waiting for the RTS */
 356   caml_runtime_busy = 1;        /* normally useless */
 357   /* Tick thread is not currently running in child process, will be
 358      re-created at next Thread.create */
 359   caml_tick_thread_running = 0;
 360   /* Reinitialize all IO mutexes */
 361   for (chan = caml_all_opened_channels;
 362        chan != NULL;
 363        chan = chan->next) {
 364     if (chan->mutex != NULL) pthread_mutex_init(chan->mutex, NULL);
 365   }
 366 }
 367
 368 /* Initialize the thread machinery */
 369
 370 value caml_thread_initialize(value unit)   /* ML */
 371 {
 372   value mu = Val_unit;
 373   value descr;
 374
 375   /* Protect against repeated initialization (PR#1325) */
 376   if (curr_thread != NULL) return Val_unit;
 377   Begin_root (mu);
 378     /* Initialize the keys */
 379     pthread_key_create(&thread_descriptor_key, NULL);
 380     pthread_key_create(&last_channel_locked_key, NULL);
 381     /* Create and initialize the termination semaphore */
 382     mu = caml_threadstatus_new();
 383     /* Create a descriptor for the current thread */
 384     descr = alloc_small(3, 0);
 385     Ident(descr) = Val_long(thread_next_ident);
 386     Start_closure(descr) = Val_unit;
 387     Terminated(descr) = mu;
 388     thread_next_ident++;
 389     /* Create an info block for the current thread */
 390     curr_thread =
 391       (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
 392     curr_thread->pthread = pthread_self();
 393     curr_thread->descr = descr;
 394     curr_thread->next = curr_thread;
 395     curr_thread->prev = curr_thread;
 396     curr_thread->backtrace_last_exn = Val_unit;
 397 #ifdef NATIVE_CODE
 398     curr_thread->exit_buf = &caml_termination_jmpbuf;
 399 #endif
 400     /* The stack-related fields will be filled in at the next
 401        enter_blocking_section */
 402     /* Associate the thread descriptor with the thread */
 403     pthread_setspecific(thread_descriptor_key, (void *) curr_thread);
 404     /* Set up the hooks */
 405     prev_scan_roots_hook = scan_roots_hook;
 406     scan_roots_hook = caml_thread_scan_roots;
 407     enter_blocking_section_hook = caml_thread_enter_blocking_section;
 408     leave_blocking_section_hook = caml_thread_leave_blocking_section;
 409     try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
 410 #ifdef NATIVE_CODE
 411     caml_termination_hook = pthread_exit;
 412 #endif
 413     caml_channel_mutex_free = caml_io_mutex_free;
 414     caml_channel_mutex_lock = caml_io_mutex_lock;
 415     caml_channel_mutex_unlock = caml_io_mutex_unlock;
 416     caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn;
 417     /* Set up fork() to reinitialize the thread machinery in the child
 418        (PR#4577) */
 419     pthread_atfork(NULL, NULL, caml_thread_reinitialize);
 420   End_roots();
 421   return Val_unit;
 422 }
 423
 424 /* Thread cleanup at termination */
 425
 426 static void caml_thread_stop(void)
 427 {
 428   caml_thread_t th = curr_thread;
 429
 430   /* Signal that the thread has terminated */
 431   caml_threadstatus_terminate(Terminated(th->descr));
 432   /* Remove th from the doubly-linked list of threads */
 433   th->next->prev = th->prev;
 434   th->prev->next = th->next;
 435   /* Release the runtime system */
 436   pthread_mutex_lock(&caml_runtime_mutex);
 437   caml_runtime_busy = 0;
 438   pthread_mutex_unlock(&caml_runtime_mutex);
 439   pthread_cond_signal(&caml_runtime_is_free);
 440 #ifndef NATIVE_CODE
 441   /* Free the memory resources */
 442   stat_free(th->stack_low);
 443 #endif
 444   if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
 445   /* Free the thread descriptor */
 446   stat_free(th);
 447 }
 448
 449 /* Create a thread */
 450
 451 static void * caml_thread_start(void * arg)
 452 {
 453   caml_thread_t th = (caml_thread_t) arg;
 454   value clos;
 455 #ifdef NATIVE_CODE
 456   struct longjmp_buffer termination_buf;
 457 #endif
 458
 459   /* Associate the thread descriptor with the thread */
 460   pthread_setspecific(thread_descriptor_key, (void *) th);
 461   /* Acquire the global mutex and set up the stack variables */
 462   leave_blocking_section();
 463 #ifdef NATIVE_CODE
 464   /* Setup termination handler (for caml_thread_exit) */
 465   if (sigsetjmp(termination_buf.buf, 0) == 0) {
 466     th->exit_buf = &termination_buf;
 467 #endif
 468     /* Callback the closure */
 469     clos = Start_closure(th->descr);
 470     modify(&(Start_closure(th->descr)), Val_unit);
 471     callback_exn(clos, Val_unit);
 472     caml_thread_stop();
 473 #ifdef NATIVE_CODE
 474   }
 475 #endif
 476   /* The thread now stops running */
 477   return NULL;
 478 }
 479
 480 value caml_thread_new(value clos)          /* ML */
 481 {
 482   pthread_attr_t attr;
 483   caml_thread_t th;
 484   pthread_t tick_pthread;
 485   value mu = Val_unit;
 486   value descr;
 487   int err;
 488
 489   Begin_roots2 (clos, mu)
 490     /* Create and initialize the termination semaphore */
 491     mu = caml_threadstatus_new();
 492     /* Create a descriptor for the new thread */
 493     descr = alloc_small(3, 0);
 494     Ident(descr) = Val_long(thread_next_ident);
 495     Start_closure(descr) = clos;
 496     Terminated(descr) = mu;
 497     thread_next_ident++;
 498     /* Create an info block for the current thread */
 499     th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
 500     th->descr = descr;
 501 #ifdef NATIVE_CODE
 502     th->bottom_of_stack = NULL;
 503     th->exception_pointer = NULL;
 504     th->local_roots = NULL;
 505 #else
 506     /* Allocate the stacks */
 507     th->stack_low = (value *) stat_alloc(Thread_stack_size);
 508     th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
 509     th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
 510     th->sp = th->stack_high;
 511     th->trapsp = th->stack_high;
 512     th->local_roots = NULL;
 513     th->external_raise = NULL;
 514 #endif
 515     th->backtrace_pos = 0;
 516     th->backtrace_buffer = NULL;
 517     th->backtrace_last_exn = Val_unit;
 518     /* Add thread info block to the list of threads */
 519     th->next = curr_thread->next;
 520     th->prev = curr_thread;
 521     curr_thread->next->prev = th;
 522     curr_thread->next = th;
 523     /* Create the new thread */
 524     pthread_attr_init(&attr);
 525     pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
 526     err = pthread_create(&th->pthread, &attr, caml_thread_start, (void *) th);
 527     if (err != 0) {
 528       /* Creation failed, remove thread info block from list of threads */
 529       th->next->prev = curr_thread;
 530       curr_thread->next = th->next;
 531 #ifndef NATIVE_CODE
 532       stat_free(th->stack_low);
 533 #endif
 534       stat_free(th);
 535       caml_pthread_check(err, "Thread.create");
 536     }
 537   End_roots();
 538   /* Create the tick thread if not already done.
 539      Because of PR#4666, we start the tick thread late, only when we create
 540      the first additional thread in the current process*/
 541   if (! caml_tick_thread_running) {
 542     caml_tick_thread_running = 1;
 543     pthread_attr_init(&attr);
 544     pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
 545     err = pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL);
 546     caml_pthread_check(err, "Thread.create");
 547   }
 548   return descr;
 549 }
 550
 551 /* Return the current thread */
 552
 553 value caml_thread_self(value unit)         /* ML */
 554 {
 555   if (curr_thread == NULL) invalid_argument("Thread.self: not initialized");
 556   return curr_thread->descr;
 557 }
 558
 559 /* Return the identifier of a thread */
 560
 561 value caml_thread_id(value th)          /* ML */
 562 {
 563   return Ident(th);
 564 }
 565
 566 /* Print uncaught exception and backtrace */
 567
 568 value caml_thread_uncaught_exception(value exn)  /* ML */
 569 {
 570   char * msg = format_caml_exception(exn);
 571   fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
 572           Int_val(Ident(curr_thread->descr)), msg);
 573   free(msg);
 574   if (caml_backtrace_active) print_exception_backtrace();
 575   fflush(stderr);
 576   return Val_unit;
 577 }
 578
 579 /* Terminate current thread */
 580
 581 value caml_thread_exit(value unit)   /* ML */
 582 {
 583 #ifdef NATIVE_CODE
 584   /* We cannot call pthread_exit here because on some systems this
 585      raises a C++ exception, and ocamlopt-generated stack frames
 586      cannot be unwound.  Instead, we longjmp to the thread creation
 587      point (in caml_thread_start) or to the point in caml_main
 588      where caml_termination_hook will be called. */
 589   struct longjmp_buffer * exit_buf;
 590   if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized");
 591   exit_buf = curr_thread->exit_buf;
 592   caml_thread_stop();
 593   siglongjmp(exit_buf->buf, 1);
 594 #else
 595   /* No such problem in bytecode */
 596   if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized");
 597   caml_thread_stop();
 598   pthread_exit(NULL);
 599 #endif
 600   return Val_unit;  /* not reached */
 601 }
 602
 603 /* Allow re-scheduling */
 604
 605 value caml_thread_yield(value unit)        /* ML */
 606 {
 607   if (caml_runtime_waiters == 0) return Val_unit;
 608   enter_blocking_section();
 609 #ifndef __linux__
 610   /* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */
 611   sched_yield();
 612 #endif
 613   leave_blocking_section();
 614   return Val_unit;
 615 }
 616
 617 /* Suspend the current thread until another thread terminates */
 618
 619 value caml_thread_join(value th)          /* ML */
 620 {
 621   int retcode = caml_threadstatus_wait(Terminated(th));
 622   caml_pthread_check(retcode, "Thread.join");
 623   return Val_unit;
 624 }
 625
 626 /* Mutex operations */
 627
 628 #define Mutex_val(v) (* ((pthread_mutex_t **) Data_custom_val(v)))
 629 #define Max_mutex_number 1000
 630
 631 static void caml_mutex_finalize(value wrapper)
 632 {
 633   pthread_mutex_t * mut = Mutex_val(wrapper);
 634   pthread_mutex_destroy(mut);
 635   stat_free(mut);
 636 }
 637
 638 static int caml_mutex_condition_compare(value wrapper1, value wrapper2)
 639 {
 640   pthread_mutex_t * mut1 = Mutex_val(wrapper1);
 641   pthread_mutex_t * mut2 = Mutex_val(wrapper2);
 642   return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1;
 643 }
 644
 645 static struct custom_operations caml_mutex_ops = {
 646   "_mutex",
 647   caml_mutex_finalize,
 648   caml_mutex_condition_compare,
 649   custom_hash_default,
 650   custom_serialize_default,
 651   custom_deserialize_default
 652 };
 653
 654 value caml_mutex_new(value unit)        /* ML */
 655 {
 656   pthread_mutex_t * mut;
 657   value wrapper;
 658   mut = stat_alloc(sizeof(pthread_mutex_t));
 659   caml_pthread_check(pthread_mutex_init(mut, NULL), "Mutex.create");
 660   wrapper = alloc_custom(&caml_mutex_ops, sizeof(pthread_mutex_t *),
 661                          1, Max_mutex_number);
 662   Mutex_val(wrapper) = mut;
 663   return wrapper;
 664 }
 665
 666 value caml_mutex_lock(value wrapper)     /* ML */
 667 {
 668   int retcode;
 669   pthread_mutex_t * mut = Mutex_val(wrapper);
 670   /* PR#4351: first try to acquire mutex without releasing the master lock */
 671   retcode = pthread_mutex_trylock(mut);
 672   if (retcode == 0) return Val_unit;
 673   /* If unsuccessful, block on mutex */
 674   Begin_root(wrapper)           /* prevent the deallocation of mutex */
 675     enter_blocking_section();
 676     retcode = pthread_mutex_lock(mut);
 677     leave_blocking_section();
 678   End_roots();
 679   caml_pthread_check(retcode, "Mutex.lock");
 680   return Val_unit;
 681 }
 682
 683 value caml_mutex_unlock(value wrapper)           /* ML */
 684 {
 685   int retcode;
 686   pthread_mutex_t * mut = Mutex_val(wrapper);
 687   /* PR#4351: no need to release and reacquire master lock */
 688   retcode = pthread_mutex_unlock(mut);
 689   caml_pthread_check(retcode, "Mutex.unlock");
 690   return Val_unit;
 691 }
 692
 693 value caml_mutex_try_lock(value wrapper)           /* ML */
 694 {
 695   int retcode;
 696   pthread_mutex_t * mut = Mutex_val(wrapper);
 697   retcode = pthread_mutex_trylock(mut);
 698   if (retcode == EBUSY) return Val_false;
 699   caml_pthread_check(retcode, "Mutex.try_lock");
 700   return Val_true;
 701 }
 702
 703 /* Conditions operations */
 704
 705 #define Condition_val(v) (* ((pthread_cond_t **) Data_custom_val(v)))
 706 #define Max_condition_number 1000
 707
 708 static void caml_condition_finalize(value wrapper)
 709 {
 710   pthread_cond_t * cond = Condition_val(wrapper);
 711   pthread_cond_destroy(cond);
 712   stat_free(cond);
 713 }
 714
 715 static struct custom_operations caml_condition_ops = {
 716   "_condition",
 717   caml_condition_finalize,
 718   caml_mutex_condition_compare,
 719   custom_hash_default,
 720   custom_serialize_default,
 721   custom_deserialize_default
 722 };
 723
 724 value caml_condition_new(value unit)        /* ML */
 725 {
 726   pthread_cond_t * cond;
 727   value wrapper;
 728   cond = stat_alloc(sizeof(pthread_cond_t));
 729   caml_pthread_check(pthread_cond_init(cond, NULL), "Condition.create");
 730   wrapper = alloc_custom(&caml_condition_ops, sizeof(pthread_cond_t *),
 731                          1, Max_condition_number);
 732   Condition_val(wrapper) = cond;
 733   return wrapper;
 734 }
 735
 736 value caml_condition_wait(value wcond, value wmut)           /* ML */
 737 {
 738   int retcode;
 739   pthread_cond_t * cond = Condition_val(wcond);
 740   pthread_mutex_t * mut = Mutex_val(wmut);
 741   Begin_roots2(wcond, wmut)     /* prevent deallocation of cond and mutex */
 742     enter_blocking_section();
 743     retcode = pthread_cond_wait(cond, mut);
 744     leave_blocking_section();
 745   End_roots();
 746   caml_pthread_check(retcode, "Condition.wait");
 747   return Val_unit;
 748 }
 749
 750 value caml_condition_signal(value wrapper)           /* ML */
 751 {
 752   int retcode;
 753   pthread_cond_t * cond = Condition_val(wrapper);
 754   retcode = pthread_cond_signal(cond);
 755   caml_pthread_check(retcode, "Condition.signal");
 756   return Val_unit;
 757 }
 758
 759 value caml_condition_broadcast(value wrapper)           /* ML */
 760 {
 761   int retcode;
 762   pthread_cond_t * cond = Condition_val(wrapper);
 763   retcode = pthread_cond_broadcast(cond);
 764   caml_pthread_check(retcode, "Condition.broadcast");
 765   return Val_unit;
 766 }
 767
 768 /* Thread status blocks */
 769
 770 struct caml_threadstatus {
 771   pthread_mutex_t lock;          /* mutex for mutual exclusion */
 772   enum { ALIVE, TERMINATED } status;   /* status of thread */
 773   pthread_cond_t terminated;    /* signaled when thread terminates */
 774 };
 775
 776 #define Threadstatus_val(v) \
 777   (* ((struct caml_threadstatus **) Data_custom_val(v)))
 778 #define Max_threadstatus_number 500
 779
 780 static void caml_threadstatus_finalize(value wrapper)
 781 {
 782   struct caml_threadstatus * ts = Threadstatus_val(wrapper);
 783   pthread_mutex_destroy(&ts->lock);
 784   pthread_cond_destroy(&ts->terminated);
 785   stat_free(ts);
 786 }
 787
 788 static struct custom_operations caml_threadstatus_ops = {
 789   "_threadstatus",
 790   caml_threadstatus_finalize,
 791   caml_mutex_condition_compare,
 792   custom_hash_default,
 793   custom_serialize_default,
 794   custom_deserialize_default
 795 };
 796
 797 value caml_threadstatus_new (void)
 798 {
 799   struct caml_threadstatus * ts;
 800   value wrapper;
 801   ts = stat_alloc(sizeof(struct caml_threadstatus));
 802   caml_pthread_check(pthread_mutex_init(&ts->lock, NULL), "Thread.create");
 803   caml_pthread_check(pthread_cond_init(&ts->terminated, NULL),
 804                      "Thread.create");
 805   ts->status = ALIVE;
 806   wrapper = alloc_custom(&caml_threadstatus_ops,
 807                          sizeof(struct caml_threadstatus *),
 808                          1, Max_threadstatus_number);
 809   Threadstatus_val(wrapper) = ts;
 810   return wrapper;
 811 }
 812
 813 void caml_threadstatus_terminate (value wrapper)
 814 {
 815   struct caml_threadstatus * ts = Threadstatus_val(wrapper);
 816   pthread_mutex_lock(&ts->lock);
 817   ts->status = TERMINATED;
 818   pthread_mutex_unlock(&ts->lock);
 819   pthread_cond_broadcast(&ts->terminated);
 820 }
 821
 822 int caml_threadstatus_wait (value wrapper)
 823 {
 824   struct caml_threadstatus * ts = Threadstatus_val(wrapper);
 825   int retcode;
 826
 827   Begin_roots1(wrapper)         /* prevent deallocation of ts */
 828     enter_blocking_section();
 829     retcode = pthread_mutex_lock(&ts->lock);
 830     if (retcode != 0) goto error;
 831     while (ts->status != TERMINATED) {
 832       retcode = pthread_cond_wait(&ts->terminated, &ts->lock);
 833       if (retcode != 0) goto error;
 834     }
 835     retcode = pthread_mutex_unlock(&ts->lock);
 836  error:
 837     leave_blocking_section();
 838   End_roots();
 839   return retcode;
 840 }
 841
 842 /* Signal mask */
 843
 844 static void decode_sigset(value vset, sigset_t * set)
 845 {
 846   sigemptyset(set);
 847   while (vset != Val_int(0)) {
 848     int sig = caml_convert_signal_number(Int_val(Field(vset, 0)));
 849     sigaddset(set, sig);
 850     vset = Field(vset, 1);
 851   }
 852 }
 853
 854 #ifndef NSIG
 855 #define NSIG 64
 856 #endif
 857
 858 static value encode_sigset(sigset_t * set)
 859 {
 860   value res = Val_int(0);
 861   int i;
 862
 863   Begin_root(res)
 864     for (i = 1; i < NSIG; i++)
 865       if (sigismember(set, i) > 0) {
 866         value newcons = alloc_small(2, 0);
 867         Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i));
 868         Field(newcons, 1) = res;
 869         res = newcons;
 870       }
 871   End_roots();
 872   return res;
 873 }
 874
 875 static int sigmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK };
 876
 877 value caml_thread_sigmask(value cmd, value sigs) /* ML */
 878 {
 879   int how;
 880   sigset_t set, oldset;
 881   int retcode;
 882
 883   how = sigmask_cmd[Int_val(cmd)];
 884   decode_sigset(sigs, &set);
 885   enter_blocking_section();
 886   retcode = pthread_sigmask(how, &set, &oldset);
 887   leave_blocking_section();
 888   caml_pthread_check(retcode, "Thread.sigmask");
 889   return encode_sigset(&oldset);
 890 }
 891
 892 /* Synchronous signal wait */
 893
 894 value caml_wait_signal(value sigs) /* ML */
 895 {
 896 #ifdef HAS_SIGWAIT
 897   sigset_t set;
 898   int retcode, signo;
 899
 900   decode_sigset(sigs, &set);
 901   enter_blocking_section();
 902   retcode = sigwait(&set, &signo);
 903   leave_blocking_section();
 904   caml_pthread_check(retcode, "Thread.wait_signal");
 905   return Val_int(signo);
 906 #else
 907   invalid_argument("Thread.wait_signal not implemented");
 908   return Val_int(0);            /* not reached */
 909 #endif
 910 }
 911
 912 /* Error report */
 913
 914 static void caml_pthread_check(int retcode, char *msg)
 915 {
 916   char * err;
 917   int errlen, msglen;
 918   value str;
 919
 920   if (retcode == 0) return;
 921   err = strerror(retcode);
 922   msglen = strlen(msg);
 923   errlen = strlen(err);
 924   str = alloc_string(msglen + 2 + errlen);
 925   memmove (&Byte(str, 0), msg, msglen);
 926   memmove (&Byte(str, msglen), ": ", 2);
 927   memmove (&Byte(str, msglen + 2), err, errlen);
 928   raise_sys_error(str);
 929 }
 930