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