src/runtime/thread.c

   1 /*
   2  * This software is part of the SBCL system. See the README file for
   3  * more information.
   4  *
   5  * This software is derived from the CMU CL system, which was
   6  * written at Carnegie Mellon University and released into the
   7  * public domain. The software is in the public domain and is
   8  * provided with absolutely no warranty. See the COPYING and CREDITS
   9  * files for more information.
  10  */
  11
  12 #include "sbcl.h"
  13
  14 #include <stdlib.h>
  15 #include <stdio.h>
  16 #include <string.h>
  17 #ifndef LISP_FEATURE_WIN32
  18 #include <sched.h>
  19 #endif
  20 #include <stddef.h>
  21 #include <errno.h>
  22 #include <sys/types.h>
  23 #ifndef LISP_FEATURE_WIN32
  24 #include <sys/wait.h>
  25 #endif
  26
  27 #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER
  28 #include <mach/mach.h>
  29 #include <mach/mach_error.h>
  30 #include <mach/mach_types.h>
  31 #endif
  32
  33 #include "runtime.h"
  34 #include "validate.h"           /* for BINDING_STACK_SIZE etc */
  35 #include "thread.h"
  36 #include "arch.h"
  37 #include "target-arch-os.h"
  38 #include "os.h"
  39 #include "globals.h"
  40 #include "dynbind.h"
  41 #include "genesis/cons.h"
  42 #include "genesis/fdefn.h"
  43 #include "interr.h"             /* for lose() */
  44 #include "alloc.h"
  45 #include "gc-internal.h"
  46 #include "cpputil.h"
  47 #include "pseudo-atomic.h"
  48 #include "interrupt.h"
  49 #include "lispregs.h"
  50
  51 #ifdef LISP_FEATURE_SB_THREAD
  52
  53 #ifdef LISP_FEATURE_OPENBSD
  54 #include <pthread_np.h>
  55 #endif
  56
  57 #ifdef LISP_FEATURE_SUNOS
  58 #include <thread.h>
  59 #endif
  60
  61 #ifdef LISP_FEATURE_WIN32
  62 # define IMMEDIATE_POST_MORTEM
  63 #endif
  64
  65 #ifdef LISP_FEATURE_DARWIN
  66 #define DELAY_THREAD_POST_MORTEM 5
  67 #define LOCK_CREATE_THREAD
  68 #endif
  69
  70 #endif
  71
  72 #if defined(LISP_FEATURE_FREEBSD) || defined(LISP_FEATURE_DRAGONFLY)
  73 #define LOCK_CREATE_THREAD
  74 #endif
  75
  76 #ifdef LISP_FEATURE_SB_THREAD
  77 struct thread_post_mortem {
  78 #ifdef DELAY_THREAD_POST_MORTEM
  79     struct thread_post_mortem *next;
  80 #endif
  81     os_thread_t os_thread;
  82     pthread_attr_t *os_attr;
  83     os_vm_address_t os_address;
  84 };
  85
  86 #ifdef DELAY_THREAD_POST_MORTEM
  87 static int pending_thread_post_mortem_count = 0;
  88 pthread_mutex_t thread_post_mortem_lock = PTHREAD_MUTEX_INITIALIZER;
  89 #endif
  90 static struct thread_post_mortem * volatile pending_thread_post_mortem = 0;
  91 #endif
  92
  93 int dynamic_values_bytes=TLS_SIZE*sizeof(lispobj);  /* same for all threads */
  94 struct thread *all_threads;
  95
  96 #ifdef LISP_FEATURE_SB_THREAD
  97 pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER;
  98 #ifdef LOCK_CREATE_THREAD
  99 static pthread_mutex_t create_thread_lock = PTHREAD_MUTEX_INITIALIZER;
 100 #endif
 101 #ifdef LISP_FEATURE_GCC_TLS
 102 __thread struct thread *current_thread;
 103 #endif
 104 pthread_key_t lisp_thread = 0;
 105 #endif
 106
 107 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 108 extern lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs)
 109 # ifdef LISP_FEATURE_X86_64
 110     __attribute__((sysv_abi))
 111 # endif
 112     ;
 113 #endif
 114
 115 static void
 116 link_thread(struct thread *th)
 117 {
 118     if (all_threads) all_threads->prev=th;
 119     th->next=all_threads;
 120     th->prev=0;
 121     all_threads=th;
 122 }
 123
 124 #ifdef LISP_FEATURE_SB_THREAD
 125 static void
 126 unlink_thread(struct thread *th)
 127 {
 128     if (th->prev)
 129         th->prev->next = th->next;
 130     else
 131         all_threads = th->next;
 132     if (th->next)
 133         th->next->prev = th->prev;
 134 }
 135
 136 #ifndef LISP_FEATURE_SB_SAFEPOINT
 137 /* Only access thread state with blockables blocked. */
 138 lispobj
 139 thread_state(struct thread *thread)
 140 {
 141     lispobj state;
 142     sigset_t old;
 143     block_blockable_signals(NULL, &old);
 144     os_sem_wait(thread->state_sem, "thread_state");
 145     state = thread->state;
 146     os_sem_post(thread->state_sem, "thread_state");
 147     thread_sigmask(SIG_SETMASK, &old, NULL);
 148     return state;
 149 }
 150
 151 void
 152 set_thread_state(struct thread *thread, lispobj state)
 153 {
 154     int i, waitcount = 0;
 155     sigset_t old;
 156     block_blockable_signals(NULL, &old);
 157     os_sem_wait(thread->state_sem, "set_thread_state");
 158     if (thread->state != state) {
 159         if ((STATE_STOPPED==state) ||
 160             (STATE_DEAD==state)) {
 161             waitcount = thread->state_not_running_waitcount;
 162             thread->state_not_running_waitcount = 0;
 163             for (i=0; i<waitcount; i++)
 164                 os_sem_post(thread->state_not_running_sem, "set_thread_state (not running)");
 165         }
 166         if ((STATE_RUNNING==state) ||
 167             (STATE_DEAD==state)) {
 168             waitcount = thread->state_not_stopped_waitcount;
 169             thread->state_not_stopped_waitcount = 0;
 170             for (i=0; i<waitcount; i++)
 171                 os_sem_post(thread->state_not_stopped_sem, "set_thread_state (not stopped)");
 172         }
 173         thread->state = state;
 174     }
 175     os_sem_post(thread->state_sem, "set_thread_state");
 176     thread_sigmask(SIG_SETMASK, &old, NULL);
 177 }
 178
 179 void
 180 wait_for_thread_state_change(struct thread *thread, lispobj state)
 181 {
 182     sigset_t old;
 183     os_sem_t *wait_sem;
 184     block_blockable_signals(NULL, &old);
 185   start:
 186     os_sem_wait(thread->state_sem, "wait_for_thread_state_change");
 187     if (thread->state == state) {
 188         switch (state) {
 189         case STATE_RUNNING:
 190             wait_sem = thread->state_not_running_sem;
 191             thread->state_not_running_waitcount++;
 192             break;
 193         case STATE_STOPPED:
 194             wait_sem = thread->state_not_stopped_sem;
 195             thread->state_not_stopped_waitcount++;
 196             break;
 197         default:
 198             lose("Invalid state in wait_for_thread_state_change: "OBJ_FMTX"\n", state);
 199         }
 200     } else {
 201         wait_sem = NULL;
 202     }
 203     os_sem_post(thread->state_sem, "wait_for_thread_state_change");
 204     if (wait_sem) {
 205         os_sem_wait(wait_sem, "wait_for_thread_state_change");
 206         goto start;
 207     }
 208     thread_sigmask(SIG_SETMASK, &old, NULL);
 209 }
 210 #endif /* sb-safepoint */
 211 #endif /* sb-thread */
 212
 213 static int
 214 initial_thread_trampoline(struct thread *th)
 215 {
 216     lispobj function;
 217 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 218     lispobj *args = NULL;
 219 #endif
 220 #ifdef LISP_FEATURE_SB_THREAD
 221     pthread_setspecific(lisp_thread, (void *)1);
 222 #endif
 223 #if defined(THREADS_USING_GCSIGNAL) && (defined(LISP_FEATURE_PPC) || defined(LISP_FEATURE_ARM64))
 224     /* SIG_STOP_FOR_GC defaults to blocked on PPC? */
 225     unblock_gc_signals(0,0);
 226 #endif
 227     function = th->no_tls_value_marker;
 228     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
 229     if(arch_os_thread_init(th)==0) return 1;
 230     link_thread(th);
 231     th->os_thread=thread_self();
 232 #ifndef LISP_FEATURE_WIN32
 233     protect_control_stack_hard_guard_page(1, NULL);
 234 #endif
 235     protect_binding_stack_hard_guard_page(1, NULL);
 236     protect_alien_stack_hard_guard_page(1, NULL);
 237 #ifndef LISP_FEATURE_WIN32
 238     protect_control_stack_guard_page(1, NULL);
 239 #endif
 240     protect_binding_stack_guard_page(1, NULL);
 241     protect_alien_stack_guard_page(1, NULL);
 242
 243 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 244     return call_into_lisp_first_time(function,args,0);
 245 #else
 246     return funcall0(function);
 247 #endif
 248 }
 249
 250 #ifdef LISP_FEATURE_SB_THREAD
 251
 252 # if defined(IMMEDIATE_POST_MORTEM)
 253
 254 /*
 255  * If this feature is set, we are running on a stack managed by the OS,
 256  * and no fancy delays are required for anything.  Just do it.
 257  */
 258 static void
 259 schedule_thread_post_mortem(struct thread *corpse)
 260 {
 261     pthread_detach(pthread_self());
 262     gc_assert(!pthread_attr_destroy(corpse->os_attr));
 263 #if defined(LISP_FEATURE_WIN32)
 264     os_invalidate_free(corpse->os_address, THREAD_STRUCT_SIZE);
 265 #else
 266     os_invalidate(corpse->os_address, THREAD_STRUCT_SIZE);
 267 #endif
 268 }
 269
 270 # else
 271
 272 /* THREAD POST MORTEM CLEANUP
 273  *
 274  * Memory allocated for the thread stacks cannot be reclaimed while
 275  * the thread is still alive, so we need a mechanism for post mortem
 276  * cleanups. FIXME: We actually have three, for historical reasons as
 277  * the saying goes. Do we really need three? Nikodemus guesses that
 278  * not anymore, now that we properly call pthread_attr_destroy before
 279  * freeing the stack. */
 280
 281 static struct thread_post_mortem *
 282 plan_thread_post_mortem(struct thread *corpse)
 283 {
 284     if (corpse) {
 285         struct thread_post_mortem *post_mortem = malloc(sizeof(struct thread_post_mortem));
 286         gc_assert(post_mortem);
 287         post_mortem->os_thread = corpse->os_thread;
 288         post_mortem->os_attr = corpse->os_attr;
 289         post_mortem->os_address = corpse->os_address;
 290 #ifdef DELAY_THREAD_POST_MORTEM
 291         post_mortem->next = NULL;
 292 #endif
 293         return post_mortem;
 294     } else {
 295         /* FIXME: When does this happen? */
 296         return NULL;
 297     }
 298 }
 299
 300 static void
 301 perform_thread_post_mortem(struct thread_post_mortem *post_mortem)
 302 {
 303 #ifdef CREATE_POST_MORTEM_THREAD
 304     pthread_detach(pthread_self());
 305 #endif
 306     int result;
 307     if (post_mortem) {
 308         if ((result = pthread_join(post_mortem->os_thread, NULL))) {
 309             lose("Error calling pthread_join in perform_thread_post_mortem:\n%s",
 310                  strerror(result));
 311         }
 312         if ((result = pthread_attr_destroy(post_mortem->os_attr))) {
 313             lose("Error calling pthread_attr_destroy in perform_thread_post_mortem:\n%s",
 314                  strerror(result));
 315         }
 316         os_invalidate(post_mortem->os_address, THREAD_STRUCT_SIZE);
 317         free(post_mortem);
 318     }
 319 }
 320
 321 static void
 322 schedule_thread_post_mortem(struct thread *corpse)
 323 {
 324     struct thread_post_mortem *post_mortem = NULL;
 325     if (corpse) {
 326         post_mortem = plan_thread_post_mortem(corpse);
 327
 328 #ifdef DELAY_THREAD_POST_MORTEM
 329         pthread_mutex_lock(&thread_post_mortem_lock);
 330         /* First stick the new post mortem to the end of the queue. */
 331         if (pending_thread_post_mortem) {
 332             struct thread_post_mortem *next = pending_thread_post_mortem;
 333             while (next->next) {
 334                 next = next->next;
 335             }
 336             next->next = post_mortem;
 337         } else {
 338             pending_thread_post_mortem = post_mortem;
 339         }
 340         /* Then, if there are enough things in the queue, clean up one
 341          * from the head -- or increment the count, and null out the
 342          * post_mortem we have. */
 343         if (pending_thread_post_mortem_count > DELAY_THREAD_POST_MORTEM) {
 344             post_mortem = pending_thread_post_mortem;
 345             pending_thread_post_mortem = post_mortem->next;
 346         } else {
 347             pending_thread_post_mortem_count++;
 348             post_mortem = NULL;
 349         }
 350         pthread_mutex_unlock(&thread_post_mortem_lock);
 351         /* Finally run, the cleanup, if any. */
 352         perform_thread_post_mortem(post_mortem);
 353 #elif defined(CREATE_POST_MORTEM_THREAD)
 354         gc_assert(!pthread_create(&thread, NULL, perform_thread_post_mortem, post_mortem));
 355 #else
 356         post_mortem = (struct thread_post_mortem *)
 357             swap_lispobjs((lispobj *)(void *)&pending_thread_post_mortem,
 358                           (lispobj)post_mortem);
 359         perform_thread_post_mortem(post_mortem);
 360 #endif
 361     }
 362 }
 363
 364 # endif /* !IMMEDIATE_POST_MORTEM */
 365
 366 /* Note: scribble must be stack-allocated */
 367 static void
 368 init_new_thread(struct thread *th, init_thread_data *scribble, int guardp)
 369 {
 370     int lock_ret;
 371
 372     pthread_setspecific(lisp_thread, (void *)1);
 373     if(arch_os_thread_init(th)==0) {
 374         /* FIXME: handle error */
 375         lose("arch_os_thread_init failed\n");
 376     }
 377
 378     th->os_thread=thread_self();
 379     if (guardp)
 380         protect_control_stack_guard_page(1, NULL);
 381     protect_binding_stack_guard_page(1, NULL);
 382     protect_alien_stack_guard_page(1, NULL);
 383     /* Since GC can only know about this thread from the all_threads
 384      * list and we're just adding this thread to it, there is no
 385      * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which
 386      * it is not). */
 387 #ifdef LISP_FEATURE_SB_SAFEPOINT
 388     *th->csp_around_foreign_call = (lispobj)scribble;
 389 #endif
 390     lock_ret = pthread_mutex_lock(&all_threads_lock);
 391     gc_assert(lock_ret == 0);
 392     link_thread(th);
 393     lock_ret = pthread_mutex_unlock(&all_threads_lock);
 394     gc_assert(lock_ret == 0);
 395
 396     /* Kludge: Changed the order of some steps between the safepoint/
 397      * non-safepoint versions of this code.  Can we unify this more?
 398      */
 399 #ifdef LISP_FEATURE_SB_SAFEPOINT
 400     gc_state_lock();
 401     gc_state_wait(GC_NONE);
 402     gc_state_unlock();
 403     push_gcing_safety(&scribble->safety);
 404 #endif
 405 }
 406
 407 static void
 408 undo_init_new_thread(struct thread *th, init_thread_data *scribble)
 409 {
 410     int lock_ret;
 411
 412     /* Kludge: Changed the order of some steps between the safepoint/
 413      * non-safepoint versions of this code.  Can we unify this more?
 414      */
 415 #ifdef LISP_FEATURE_SB_SAFEPOINT
 416     block_blockable_signals(0, 0);
 417     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
 418 #if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
 419     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
 420 #endif
 421     pop_gcing_safety(&scribble->safety);
 422     lock_ret = pthread_mutex_lock(&all_threads_lock);
 423     gc_assert(lock_ret == 0);
 424     unlink_thread(th);
 425     lock_ret = pthread_mutex_unlock(&all_threads_lock);
 426     gc_assert(lock_ret == 0);
 427 #else
 428     /* Block GC */
 429     block_blockable_signals(0, 0);
 430     set_thread_state(th, STATE_DEAD);
 431
 432     /* SIG_STOP_FOR_GC is blocked and GC might be waiting for this
 433      * thread, but since we are already dead it won't wait long. */
 434     lock_ret = pthread_mutex_lock(&all_threads_lock);
 435     gc_assert(lock_ret == 0);
 436
 437     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
 438 #if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
 439     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
 440 #endif
 441     unlink_thread(th);
 442     pthread_mutex_unlock(&all_threads_lock);
 443     gc_assert(lock_ret == 0);
 444 #endif
 445
 446     arch_os_thread_cleanup(th);
 447
 448 #ifndef LISP_FEATURE_SB_SAFEPOINT
 449     os_sem_destroy(th->state_sem);
 450     os_sem_destroy(th->state_not_running_sem);
 451     os_sem_destroy(th->state_not_stopped_sem);
 452 #endif
 453
 454
 455 #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER
 456     mach_lisp_thread_destroy(th);
 457 #endif
 458
 459 #if defined(LISP_FEATURE_WIN32)
 460     int i;
 461     for (i = 0; i<
 462              (int) (sizeof(th->private_events.events)/
 463                     sizeof(th->private_events.events[0])); ++i) {
 464       CloseHandle(th->private_events.events[i]);
 465     }
 466     TlsSetValue(OUR_TLS_INDEX,NULL);
 467 #endif
 468
 469     /* Undo the association of the current pthread to its `struct thread',
 470      * such that we can call arch_os_get_current_thread() later in this
 471      * thread and cleanly get back NULL. */
 472 #ifdef LISP_FEATURE_GCC_TLS
 473     current_thread = NULL;
 474 #else
 475     pthread_setspecific(specials, NULL);
 476 #endif
 477 }
 478
 479 /* this is the first thing that runs in the child (which is why the
 480  * silly calling convention).  Basically it calls the user's requested
 481  * lisp function after doing arch_os_thread_init and whatever other
 482  * bookkeeping needs to be done
 483  */
 484 int
 485 new_thread_trampoline(struct thread *th)
 486 {
 487     int result;
 488     init_thread_data scribble;
 489
 490     FSHOW((stderr,"/creating thread %lu\n", thread_self()));
 491     check_deferrables_blocked_or_lose(0);
 492 #ifndef LISP_FEATURE_SB_SAFEPOINT
 493     check_gc_signals_unblocked_or_lose(0);
 494 #endif
 495
 496     lispobj function = th->no_tls_value_marker;
 497     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
 498     init_new_thread(th, &scribble, 1);
 499     result = funcall0(function);
 500     undo_init_new_thread(th, &scribble);
 501
 502     schedule_thread_post_mortem(th);
 503
 504     FSHOW((stderr,"/exiting thread %lu\n", thread_self()));
 505     return result;
 506 }
 507
 508 static struct thread *create_thread_struct(lispobj);
 509
 510 void
 511 attach_os_thread(init_thread_data *scribble)
 512 {
 513     os_thread_t os = pthread_self();
 514     odxprint(misc, "attach_os_thread: attaching to %p", os);
 515
 516     struct thread *th = create_thread_struct(NIL);
 517     block_deferrable_signals(0, &scribble->oldset);
 518     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
 519     /* We don't actually want a pthread_attr here, but rather than add
 520      * `if's to the post-mostem, let's just keep that code happy by
 521      * keeping it initialized: */
 522     pthread_attr_init(th->os_attr);
 523
 524 #ifndef LISP_FEATURE_WIN32
 525     /* On windows, arch_os_thread_init will take care of finding the
 526      * stack. */
 527     void *stack_addr;
 528     size_t stack_size;
 529 #ifdef LISP_FEATURE_OPENBSD
 530     stack_t stack;
 531     pthread_stackseg_np(os, &stack);
 532     stack_size = stack.ss_size;
 533     stack_addr = (void*)((size_t)stack.ss_sp - stack_size);
 534 #elif defined LISP_FEATURE_SUNOS
 535   stack_t stack;
 536   thr_stksegment(&stack);
 537   stack_size = stack.ss_size;
 538   stack_addr = (void*)((size_t)stack.ss_sp - stack_size);
 539 #elif defined(LISP_FEATURE_DARWIN)
 540     stack_addr = pthread_get_stackaddr_np(os);
 541     stack_size = pthread_get_stacksize_np(os);
 542 #else
 543     pthread_attr_t attr;
 544 #ifdef LISP_FEATURE_FREEBSD
 545     pthread_attr_get_np(os, &attr);
 546 #else
 547     int pthread_getattr_np(pthread_t, pthread_attr_t *);
 548     pthread_getattr_np(os, &attr);
 549 #endif
 550     pthread_attr_getstack(&attr, &stack_addr, &stack_size);
 551 #endif
 552
 553     th->control_stack_start = stack_addr;
 554     th->control_stack_end = (void *) (((uintptr_t) stack_addr) + stack_size);
 555 #endif
 556
 557     init_new_thread(th, scribble, 0);
 558
 559     /* We will be calling into Lisp soon, and the functions being called
 560      * recklessly ignore the comment in target-thread which says that we
 561      * must be careful to not cause GC while initializing a new thread.
 562      * Since we first need to create a fresh thread object, it's really
 563      * tempting to just perform such unsafe allocation though.  So let's
 564      * at least try to suppress GC before consing, and hope that it
 565      * works: */
 566     bind_variable(GC_INHIBIT, T, th);
 567
 568     uword_t stacksize
 569         = (uword_t) th->control_stack_end - (uword_t) th->control_stack_start;
 570     odxprint(misc, "attach_os_thread: attached %p as %p (0x%lx bytes stack)",
 571              os, th, (long) stacksize);
 572 }
 573
 574 void
 575 detach_os_thread(init_thread_data *scribble)
 576 {
 577     struct thread *th = arch_os_get_current_thread();
 578     odxprint(misc, "detach_os_thread: detaching");
 579
 580     undo_init_new_thread(th, scribble);
 581
 582     odxprint(misc, "deattach_os_thread: detached");
 583     pthread_setspecific(lisp_thread, (void *)0);
 584     thread_sigmask(SIG_SETMASK, &scribble->oldset, 0);
 585 }
 586
 587 void
 588 callback_wrapper_trampoline(
 589 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 590     /* On the x86oid backends, the assembly wrapper happens to not pass
 591      * in ENTER_ALIEN_CALLBACK explicitly for safepoints.  However, the
 592      * platforms with precise GC are tricky enough already, and I want
 593      * to minimize the read-time conditionals.  For those platforms, I'm
 594      * only replacing funcall3 with callback_wrapper_trampoline while
 595      * keeping the arguments unchanged. --DFL */
 596     lispobj __attribute__((__unused__)) fun,
 597 #endif
 598     lispobj arg0, lispobj arg1, lispobj arg2)
 599 {
 600 #if defined(LISP_FEATURE_WIN32)
 601     pthread_np_notice_thread();
 602 #endif
 603     struct thread* th = arch_os_get_current_thread();
 604     if (!th) {                  /* callback invoked in non-lisp thread */
 605         init_thread_data scribble;
 606         attach_os_thread(&scribble);
 607         funcall3(StaticSymbolFunction(ENTER_FOREIGN_CALLBACK), arg0,arg1,arg2);
 608         detach_os_thread(&scribble);
 609         return;
 610     }
 611
 612 #ifdef LISP_FEATURE_WIN32
 613     /* arg2 is the pointer to a return value, which sits on the stack */
 614     th->carried_base_pointer = (os_context_register_t) *(((void**)arg2)-1);
 615 #endif
 616
 617 #ifdef LISP_FEATURE_SB_SAFEPOINT
 618     WITH_GC_AT_SAFEPOINTS_ONLY()
 619 #endif
 620     {
 621        funcall3(SymbolValue(ENTER_ALIEN_CALLBACK, 0), arg0, arg1, arg2);
 622
 623     }
 624 }
 625 #endif /* LISP_FEATURE_SB_THREAD */
 626
 627 static void
 628 free_thread_struct(struct thread *th)
 629 {
 630 #if defined(LISP_FEATURE_WIN32)
 631     os_invalidate_free((os_vm_address_t) th->os_address, THREAD_STRUCT_SIZE);
 632 #else
 633     os_invalidate((os_vm_address_t) th->os_address, THREAD_STRUCT_SIZE);
 634 #endif
 635 }
 636
 637 #ifdef LISP_FEATURE_SB_THREAD
 638 /* FIXME: should be MAX_INTERRUPTS -1 ? */
 639 const unsigned int tls_index_start =
 640   MAX_INTERRUPTS + sizeof(struct thread)/sizeof(lispobj);
 641 #endif
 642
 643 /* this is called from any other thread to create the new one, and
 644  * initialize all parts of it that can be initialized from another
 645  * thread
 646  */
 647
 648 static struct thread *
 649 create_thread_struct(lispobj initial_function) {
 650     union per_thread_data *per_thread;
 651     struct thread *th=0;        /*  subdue gcc */
 652     void *spaces=0;
 653     void *aligned_spaces=0;
 654 #if defined(LISP_FEATURE_SB_THREAD) || defined(LISP_FEATURE_WIN32)
 655     unsigned int i;
 656 #endif
 657
 658     /* May as well allocate all the spaces at once: it saves us from
 659      * having to decide what to do if only some of the allocations
 660      * succeed. SPACES must be appropriately aligned, since the GC
 661      * expects the control stack to start at a page boundary -- and
 662      * the OS may have even more rigorous requirements. We can't rely
 663      * on the alignment passed from os_validate, since that might
 664      * assume the current (e.g. 4k) pagesize, while we calculate with
 665      * the biggest (e.g. 64k) pagesize allowed by the ABI. */
 666     spaces=os_validate(0, THREAD_STRUCT_SIZE);
 667     if(!spaces)
 668         return NULL;
 669     /* Aligning up is safe as THREAD_STRUCT_SIZE has
 670      * THREAD_ALIGNMENT_BYTES padding. */
 671     aligned_spaces = (void *)((((uword_t)(char *)spaces)
 672                                + THREAD_ALIGNMENT_BYTES-1)
 673                               &~(uword_t)(THREAD_ALIGNMENT_BYTES-1));
 674     void* csp_page=
 675         (aligned_spaces+
 676          thread_control_stack_size+
 677          BINDING_STACK_SIZE+
 678          ALIEN_STACK_SIZE);
 679     per_thread=(union per_thread_data *)
 680         (csp_page + THREAD_CSP_PAGE_SIZE);
 681
 682 #ifdef LISP_FEATURE_SB_THREAD
 683     for(i = 0; i < (dynamic_values_bytes / sizeof(lispobj)); i++)
 684         per_thread->dynamic_values[i] = NO_TLS_VALUE_MARKER_WIDETAG;
 685 #endif
 686
 687     th=&per_thread->thread;
 688     th->os_address = spaces;
 689     th->control_stack_start = aligned_spaces;
 690     th->binding_stack_start=
 691         (lispobj*)((void*)th->control_stack_start+thread_control_stack_size);
 692     th->control_stack_end = th->binding_stack_start;
 693     th->control_stack_guard_page_protected = T;
 694     th->alien_stack_start=
 695         (lispobj*)((void*)th->binding_stack_start+BINDING_STACK_SIZE);
 696     set_binding_stack_pointer(th,th->binding_stack_start);
 697     th->this=th;
 698     th->os_thread=0;
 699
 700 #ifdef LISP_FEATURE_SB_SAFEPOINT
 701 # ifdef LISP_FEATURE_WIN32
 702     th->carried_base_pointer = 0;
 703 # endif
 704 # ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
 705     th->pc_around_foreign_call = 0;
 706 # endif
 707     th->csp_around_foreign_call = csp_page;
 708 #endif
 709
 710     struct nonpointer_thread_data *nonpointer_data
 711       = (void *) &per_thread->dynamic_values[TLS_SIZE];
 712
 713     th->interrupt_data = &nonpointer_data->interrupt_data;
 714
 715 #ifdef LISP_FEATURE_SB_THREAD
 716     th->os_attr = &nonpointer_data->os_attr;
 717 # ifndef LISP_FEATURE_SB_SAFEPOINT
 718     th->state_sem = &nonpointer_data->state_sem;
 719     th->state_not_running_sem = &nonpointer_data->state_not_running_sem;
 720     th->state_not_stopped_sem = &nonpointer_data->state_not_stopped_sem;
 721     os_sem_init(th->state_sem, 1);
 722     os_sem_init(th->state_not_running_sem, 0);
 723     os_sem_init(th->state_not_stopped_sem, 0);
 724     th->state_not_running_waitcount = 0;
 725     th->state_not_stopped_waitcount = 0;
 726 # endif
 727
 728 #endif
 729     th->state=STATE_RUNNING;
 730 #ifdef ALIEN_STACK_GROWS_DOWNWARD
 731     th->alien_stack_pointer=((void *)th->alien_stack_start
 732                              + ALIEN_STACK_SIZE-N_WORD_BYTES);
 733 #else
 734     th->alien_stack_pointer=((void *)th->alien_stack_start);
 735 #endif
 736
 737 #ifdef LISP_FEATURE_SB_THREAD
 738     th->pseudo_atomic_bits=0;
 739 #elif defined LISP_FEATURE_GENCGC
 740     clear_pseudo_atomic_atomic(th);
 741     clear_pseudo_atomic_interrupted(th);
 742 #endif
 743
 744 #ifdef LISP_FEATURE_GENCGC
 745     gc_set_region_empty(&th->alloc_region);
 746 # if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
 747     gc_set_region_empty(&th->sprof_alloc_region);
 748 # endif
 749 #endif
 750 #ifdef LISP_FEATURE_SB_THREAD
 751     /* This parallels the same logic in globals.c for the
 752      * single-threaded foreign_function_call_active, KLUDGE and
 753      * all. */
 754 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 755     th->foreign_function_call_active = 0;
 756 #else
 757     th->foreign_function_call_active = 1;
 758 #endif
 759 #endif
 760
 761 #ifndef LISP_FEATURE_SB_THREAD
 762     /* the tls-points-into-struct-thread trick is only good for threaded
 763      * sbcl, because unithread sbcl doesn't have tls.  So, we copy the
 764      * appropriate values from struct thread here, and make sure that
 765      * we use the appropriate SymbolValue macros to access any of the
 766      * variable quantities from the C runtime.  It's not quite OAOOM,
 767      * it just feels like it */
 768     SetSymbolValue(BINDING_STACK_START,(lispobj)th->binding_stack_start,th);
 769     SetSymbolValue(CONTROL_STACK_START,(lispobj)th->control_stack_start,th);
 770     SetSymbolValue(CONTROL_STACK_END,(lispobj)th->control_stack_end,th);
 771 #if defined(LISP_FEATURE_X86) || defined (LISP_FEATURE_X86_64)
 772     SetSymbolValue(ALIEN_STACK_POINTER,(lispobj)th->alien_stack_pointer,th);
 773 #endif
 774 #endif
 775     bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th);
 776     bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th);
 777     bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,make_fixnum(0),th);
 778     bind_variable(INTERRUPT_PENDING, NIL,th);
 779     bind_variable(INTERRUPTS_ENABLED,T,th);
 780     bind_variable(ALLOW_WITH_INTERRUPTS,T,th);
 781     bind_variable(GC_PENDING,NIL,th);
 782     bind_variable(ALLOC_SIGNAL,NIL,th);
 783 #ifdef PINNED_OBJECTS
 784     bind_variable(PINNED_OBJECTS,NIL,th);
 785 #endif
 786 #ifdef LISP_FEATURE_SB_THREAD
 787     bind_variable(STOP_FOR_GC_PENDING,NIL,th);
 788 #endif
 789 #if defined(LISP_FEATURE_SB_SAFEPOINT)
 790     bind_variable(GC_SAFE,NIL,th);
 791     bind_variable(IN_SAFEPOINT,NIL,th);
 792 #endif
 793 #ifdef LISP_FEATURE_SB_THRUPTION
 794     bind_variable(THRUPTION_PENDING,NIL,th);
 795     bind_variable(RESTART_CLUSTERS,NIL,th);
 796 #endif
 797 #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
 798     access_control_stack_pointer(th)=th->control_stack_start;
 799 #endif
 800
 801     th->interrupt_data->pending_handler = 0;
 802     th->interrupt_data->gc_blocked_deferrables = 0;
 803 #ifdef GENCGC_IS_PRECISE
 804     th->interrupt_data->allocation_trap_context = 0;
 805 #endif
 806     th->no_tls_value_marker=initial_function;
 807
 808 #if defined(LISP_FEATURE_WIN32)
 809     for (i = 0; i<sizeof(th->private_events.events)/
 810            sizeof(th->private_events.events[0]); ++i) {
 811       th->private_events.events[i] = CreateEvent(NULL,FALSE,FALSE,NULL);
 812     }
 813     th->synchronous_io_handle_and_flag = 0;
 814 #endif
 815     th->stepping = 0;
 816     return th;
 817 }
 818
 819 void create_initial_thread(lispobj initial_function) {
 820     struct thread *th=create_thread_struct(initial_function);
 821 #ifdef LISP_FEATURE_SB_THREAD
 822     pthread_key_create(&lisp_thread, 0);
 823 #endif
 824     if(th) {
 825         initial_thread_trampoline(th); /* no return */
 826     } else lose("can't create initial thread\n");
 827 }
 828
 829 #ifdef LISP_FEATURE_SB_THREAD
 830
 831 #ifndef __USE_XOPEN2K
 832 extern int pthread_attr_setstack (pthread_attr_t *__attr, void *__stackaddr,
 833                                   size_t __stacksize);
 834 #endif
 835
 836 boolean create_os_thread(struct thread *th,os_thread_t *kid_tid)
 837 {
 838     /* The new thread inherits the restrictive signal mask set here,
 839      * and enables signals again when it is set up properly. */
 840     sigset_t oldset;
 841     boolean r=1;
 842     int retcode = 0, initcode;
 843
 844     FSHOW_SIGNAL((stderr,"/create_os_thread: creating new thread\n"));
 845
 846     /* Blocking deferrable signals is enough, no need to block
 847      * SIG_STOP_FOR_GC because the child process is not linked onto
 848      * all_threads until it's ready. */
 849     block_deferrable_signals(0, &oldset);
 850
 851 #ifdef LOCK_CREATE_THREAD
 852     retcode = pthread_mutex_lock(&create_thread_lock);
 853     gc_assert(retcode == 0);
 854     FSHOW_SIGNAL((stderr,"/create_os_thread: got lock\n"));
 855 #endif
 856
 857     if((initcode = pthread_attr_init(th->os_attr)) ||
 858        /* call_into_lisp_first_time switches the stack for the initial
 859         * thread. For the others, we use this. */
 860 #if defined(LISP_FEATURE_WIN32)
 861        (pthread_attr_setstacksize(th->os_attr, thread_control_stack_size)) ||
 862 #else
 863 # if defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK)
 864        (pthread_attr_setstack(th->os_attr,th->control_stack_start,
 865                               thread_control_stack_size)) ||
 866 # else
 867        (pthread_attr_setstack(th->os_attr,th->alien_stack_start,
 868                               ALIEN_STACK_SIZE)) ||
 869 # endif
 870 #endif
 871        (retcode = pthread_create
 872         (kid_tid,th->os_attr,(void *(*)(void *))new_thread_trampoline,th))) {
 873         FSHOW_SIGNAL((stderr, "init = %d\n", initcode));
 874         FSHOW_SIGNAL((stderr, "pthread_create returned %d, errno %d\n",
 875                       retcode, errno));
 876         if(retcode < 0) {
 877             perror("create_os_thread");
 878         }
 879         r=0;
 880     }
 881
 882 #ifdef LOCK_CREATE_THREAD
 883     retcode = pthread_mutex_unlock(&create_thread_lock);
 884     gc_assert(retcode == 0);
 885     FSHOW_SIGNAL((stderr,"/create_os_thread: released lock\n"));
 886 #endif
 887     thread_sigmask(SIG_SETMASK,&oldset,0);
 888     return r;
 889 }
 890
 891 os_thread_t create_thread(lispobj initial_function) {
 892     struct thread *th, *thread = arch_os_get_current_thread();
 893     os_thread_t kid_tid = 0;
 894
 895     /* Must defend against async unwinds. */
 896     if (SymbolValue(INTERRUPTS_ENABLED, thread) != NIL)
 897         lose("create_thread is not safe when interrupts are enabled.\n");
 898
 899     /* Assuming that a fresh thread struct has no lisp objects in it,
 900      * linking it to all_threads can be left to the thread itself
 901      * without fear of gc lossage. initial_function violates this
 902      * assumption and must stay pinned until the child starts up. */
 903     th = create_thread_struct(initial_function);
 904     if (th && !create_os_thread(th,&kid_tid)) {
 905         free_thread_struct(th);
 906         kid_tid = 0;
 907     }
 908     return kid_tid;
 909 }
 910
 911 /* stopping the world is a two-stage process.  From this thread we signal
 912  * all the others with SIG_STOP_FOR_GC.  The handler for this signal does
 913  * the usual pseudo-atomic checks (we don't want to stop a thread while
 914  * it's in the middle of allocation) then waits for another SIG_STOP_FOR_GC.
 915  */
 916 /*
 917  * (With SB-SAFEPOINT, see the definitions in safepoint.c instead.)
 918  */
 919 #ifndef LISP_FEATURE_SB_SAFEPOINT
 920
 921 /* To avoid deadlocks when gc stops the world all clients of each
 922  * mutex must enable or disable SIG_STOP_FOR_GC for the duration of
 923  * holding the lock, but they must agree on which. */
 924 void gc_stop_the_world()
 925 {
 926     struct thread *p,*th=arch_os_get_current_thread();
 927     int status, lock_ret;
 928 #ifdef LOCK_CREATE_THREAD
 929     /* KLUDGE: Stopping the thread during pthread_create() causes deadlock
 930      * on FreeBSD. */
 931     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on create_thread_lock\n"));
 932     lock_ret = pthread_mutex_lock(&create_thread_lock);
 933     gc_assert(lock_ret == 0);
 934     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got create_thread_lock\n"));
 935 #endif
 936     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock\n"));
 937     /* keep threads from starting while the world is stopped. */
 938     lock_ret = pthread_mutex_lock(&all_threads_lock);      \
 939     gc_assert(lock_ret == 0);
 940
 941     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got lock\n"));
 942     /* stop all other threads by sending them SIG_STOP_FOR_GC */
 943     for(p=all_threads; p; p=p->next) {
 944         gc_assert(p->os_thread != 0);
 945         FSHOW_SIGNAL((stderr,"/gc_stop_the_world: thread=%lu, state=%x\n",
 946                       p->os_thread, thread_state(p)));
 947         if((p!=th) && ((thread_state(p)==STATE_RUNNING))) {
 948             FSHOW_SIGNAL((stderr,"/gc_stop_the_world: suspending thread %lu\n",
 949                           p->os_thread));
 950             /* We already hold all_thread_lock, P can become DEAD but
 951              * cannot exit, ergo it's safe to use pthread_kill. */
 952             status=pthread_kill(p->os_thread,SIG_STOP_FOR_GC);
 953             if (status==ESRCH) {
 954                 /* This thread has exited. */
 955                 gc_assert(thread_state(p)==STATE_DEAD);
 956             } else if (status) {
 957                 lose("cannot send suspend thread=%lu: %d, %s\n",
 958                      p->os_thread,status,strerror(status));
 959             }
 960         }
 961     }
 962     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:signals sent\n"));
 963     for(p=all_threads;p;p=p->next) {
 964         if (p!=th) {
 965             FSHOW_SIGNAL
 966                 ((stderr,
 967                   "/gc_stop_the_world: waiting for thread=%lu: state=%x\n",
 968                   p->os_thread, thread_state(p)));
 969             wait_for_thread_state_change(p, STATE_RUNNING);
 970             if (p->state == STATE_RUNNING)
 971                 lose("/gc_stop_the_world: unexpected state");
 972         }
 973     }
 974     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:end\n"));
 975 }
 976
 977 void gc_start_the_world()
 978 {
 979     struct thread *p,*th=arch_os_get_current_thread();
 980     int lock_ret;
 981     /* if a resumed thread creates a new thread before we're done with
 982      * this loop, the new thread will get consed on the front of
 983      * all_threads, but it won't have been stopped so won't need
 984      * restarting */
 985     FSHOW_SIGNAL((stderr,"/gc_start_the_world:begin\n"));
 986     for(p=all_threads;p;p=p->next) {
 987         gc_assert(p->os_thread!=0);
 988         if (p!=th) {
 989             lispobj state = thread_state(p);
 990             if (state != STATE_DEAD) {
 991                 if(state != STATE_STOPPED) {
 992                     lose("gc_start_the_world: wrong thread state is %d\n",
 993                          fixnum_value(state));
 994                 }
 995                 FSHOW_SIGNAL((stderr, "/gc_start_the_world: resuming %lu\n",
 996                               p->os_thread));
 997                 set_thread_state(p, STATE_RUNNING);
 998             }
 999         }
1000     }
1001
1002     lock_ret = pthread_mutex_unlock(&all_threads_lock);
1003     gc_assert(lock_ret == 0);
1004 #ifdef LOCK_CREATE_THREAD
1005     lock_ret = pthread_mutex_unlock(&create_thread_lock);
1006     gc_assert(lock_ret == 0);
1007 #endif
1008
1009     FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n"));
1010 }
1011
1012 #endif /* !LISP_FEATURE_SB_SAFEPOINT */
1013 #endif /* !LISP_FEATURE_SB_THREAD */
1014
1015 int
1016 thread_yield()
1017 {
1018 #ifdef LISP_FEATURE_SB_THREAD
1019     return sched_yield();
1020 #else
1021     return 0;
1022 #endif
1023 }
1024
1025 int
1026 wake_thread(os_thread_t os_thread)
1027 {
1028 #if defined(LISP_FEATURE_WIN32)
1029     return kill_safely(os_thread, 1);
1030 #elif !defined(LISP_FEATURE_SB_THRUPTION)
1031     return kill_safely(os_thread, SIGPIPE);
1032 #else
1033     return wake_thread_posix(os_thread);
1034 #endif
1035 }
1036
1037 /* If the thread id given does not belong to a running thread (it has
1038  * exited or never even existed) pthread_kill _may_ fail with ESRCH,
1039  * but it is also allowed to just segfault, see
1040  * <http://udrepper.livejournal.com/16844.html>.
1041  *
1042  * Relying on thread ids can easily backfire since ids are recycled
1043  * (NPTL recycles them extremely fast) so a signal can be sent to
1044  * another process if the one it was sent to exited.
1045  *
1046  * For these reasons, we must make sure that the thread is still alive
1047  * when the pthread_kill is called and return if the thread is
1048  * exiting.
1049  *
1050  * Note (DFL, 2011-06-22): At the time of writing, this function is only
1051  * used for INTERRUPT-THREAD, hence the wake_thread special-case for
1052  * Windows is OK. */
1053 int
1054 kill_safely(os_thread_t os_thread, int signal)
1055 {
1056     FSHOW_SIGNAL((stderr,"/kill_safely: %lu, %d\n", os_thread, signal));
1057     {
1058 #ifdef LISP_FEATURE_SB_THREAD
1059         sigset_t oldset;
1060         struct thread *thread;
1061         /* Frequent special case: resignalling to self.  The idea is
1062          * that leave_region safepoint will acknowledge the signal, so
1063          * there is no need to take locks, roll thread to safepoint
1064          * etc. */
1065         /* Kludge (on safepoint builds): At the moment, this isn't just
1066          * an optimization; rather it masks the fact that
1067          * gc_stop_the_world() grabs the all_threads mutex without
1068          * releasing it, and since we're not using recursive pthread
1069          * mutexes, the pthread_mutex_lock() around the all_threads loop
1070          * would go wrong.  Why are we running interruptions while
1071          * stopping the world though?  Test case is (:ASYNC-UNWIND
1072          * :SPECIALS), especially with s/10/100/ in both loops. */
1073         if (os_thread == pthread_self()) {
1074             pthread_kill(os_thread, signal);
1075 #ifdef LISP_FEATURE_WIN32
1076             check_pending_thruptions(NULL);
1077 #endif
1078             return 0;
1079         }
1080
1081         /* pthread_kill is not async signal safe and we don't want to be
1082          * interrupted while holding the lock. */
1083         block_deferrable_signals(0, &oldset);
1084         pthread_mutex_lock(&all_threads_lock);
1085         for (thread = all_threads; thread; thread = thread->next) {
1086             if (thread->os_thread == os_thread) {
1087                 int status = pthread_kill(os_thread, signal);
1088                 if (status)
1089                     lose("kill_safely: pthread_kill failed with %d\n", status);
1090 #if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THRUPTION)
1091                 wake_thread_win32(thread);
1092 #endif
1093                 break;
1094             }
1095         }
1096         pthread_mutex_unlock(&all_threads_lock);
1097         thread_sigmask(SIG_SETMASK,&oldset,0);
1098         if (thread)
1099             return 0;
1100         else
1101             return -1;
1102 #elif defined(LISP_FEATURE_WIN32)
1103         return 0;
1104 #else
1105         int status;
1106         if (os_thread != 0)
1107             lose("kill_safely: who do you want to kill? %d?\n", os_thread);
1108         /* Dubious (as in don't know why it works) workaround for the
1109          * signal sometimes not being generated on darwin. */
1110 #ifdef LISP_FEATURE_DARWIN
1111         {
1112             sigset_t oldset;
1113             sigprocmask(SIG_BLOCK, &deferrable_sigset, &oldset);
1114             status = raise(signal);
1115             sigprocmask(SIG_SETMASK,&oldset,0);
1116         }
1117 #else
1118         status = raise(signal);
1119 #endif
1120         if (status == 0) {
1121             return 0;
1122         } else {
1123             lose("cannot raise signal %d, %d %s\n",
1124                  signal, status, strerror(errno));
1125         }
1126 #endif
1127     }
1128 }