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 extern struct interrupt_data * global_interrupt_data;
  96
  97 #ifdef LISP_FEATURE_SB_THREAD
  98 pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER;
  99 #ifdef LOCK_CREATE_THREAD
 100 static pthread_mutex_t create_thread_lock = PTHREAD_MUTEX_INITIALIZER;
 101 #endif
 102 #ifdef LISP_FEATURE_GCC_TLS
 103 __thread struct thread *current_thread;
 104 #endif
 105 pthread_key_t lisp_thread = 0;
 106 #endif
 107
 108 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 109 extern lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs)
 110 # ifdef LISP_FEATURE_X86_64
 111     __attribute__((sysv_abi))
 112 # endif
 113     ;
 114 #endif
 115
 116 static void
 117 link_thread(struct thread *th)
 118 {
 119     if (all_threads) all_threads->prev=th;
 120     th->next=all_threads;
 121     th->prev=0;
 122     all_threads=th;
 123 }
 124
 125 #ifdef LISP_FEATURE_SB_THREAD
 126 static void
 127 unlink_thread(struct thread *th)
 128 {
 129     if (th->prev)
 130         th->prev->next = th->next;
 131     else
 132         all_threads = th->next;
 133     if (th->next)
 134         th->next->prev = th->prev;
 135 }
 136
 137 #ifndef LISP_FEATURE_SB_SAFEPOINT
 138 /* Only access thread state with blockables blocked. */
 139 lispobj
 140 thread_state(struct thread *thread)
 141 {
 142     lispobj state;
 143     sigset_t old;
 144     block_blockable_signals(NULL, &old);
 145     os_sem_wait(thread->state_sem, "thread_state");
 146     state = thread->state;
 147     os_sem_post(thread->state_sem, "thread_state");
 148     thread_sigmask(SIG_SETMASK, &old, NULL);
 149     return state;
 150 }
 151
 152 void
 153 set_thread_state(struct thread *thread, lispobj state)
 154 {
 155     int i, waitcount = 0;
 156     sigset_t old;
 157     block_blockable_signals(NULL, &old);
 158     os_sem_wait(thread->state_sem, "set_thread_state");
 159     if (thread->state != state) {
 160         if ((STATE_STOPPED==state) ||
 161             (STATE_DEAD==state)) {
 162             waitcount = thread->state_not_running_waitcount;
 163             thread->state_not_running_waitcount = 0;
 164             for (i=0; i<waitcount; i++)
 165                 os_sem_post(thread->state_not_running_sem, "set_thread_state (not running)");
 166         }
 167         if ((STATE_RUNNING==state) ||
 168             (STATE_DEAD==state)) {
 169             waitcount = thread->state_not_stopped_waitcount;
 170             thread->state_not_stopped_waitcount = 0;
 171             for (i=0; i<waitcount; i++)
 172                 os_sem_post(thread->state_not_stopped_sem, "set_thread_state (not stopped)");
 173         }
 174         thread->state = state;
 175     }
 176     os_sem_post(thread->state_sem, "set_thread_state");
 177     thread_sigmask(SIG_SETMASK, &old, NULL);
 178 }
 179
 180 void
 181 wait_for_thread_state_change(struct thread *thread, lispobj state)
 182 {
 183     sigset_t old;
 184     os_sem_t *wait_sem;
 185     block_blockable_signals(NULL, &old);
 186   start:
 187     os_sem_wait(thread->state_sem, "wait_for_thread_state_change");
 188     if (thread->state == state) {
 189         switch (state) {
 190         case STATE_RUNNING:
 191             wait_sem = thread->state_not_running_sem;
 192             thread->state_not_running_waitcount++;
 193             break;
 194         case STATE_STOPPED:
 195             wait_sem = thread->state_not_stopped_sem;
 196             thread->state_not_stopped_waitcount++;
 197             break;
 198         default:
 199             lose("Invalid state in wait_for_thread_state_change: "OBJ_FMTX"\n", state);
 200         }
 201     } else {
 202         wait_sem = NULL;
 203     }
 204     os_sem_post(thread->state_sem, "wait_for_thread_state_change");
 205     if (wait_sem) {
 206         os_sem_wait(wait_sem, "wait_for_thread_state_change");
 207         goto start;
 208     }
 209     thread_sigmask(SIG_SETMASK, &old, NULL);
 210 }
 211 #endif /* sb-safepoint */
 212 #endif /* sb-thread */
 213
 214 static int
 215 initial_thread_trampoline(struct thread *th)
 216 {
 217     lispobj function;
 218 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 219     lispobj *args = NULL;
 220 #endif
 221 #ifdef LISP_FEATURE_SB_THREAD
 222     pthread_setspecific(lisp_thread, (void *)1);
 223 #endif
 224 #if defined(THREADS_USING_GCSIGNAL) && (defined(LISP_FEATURE_PPC) || defined(LISP_FEATURE_ARM64))
 225     /* SIG_STOP_FOR_GC defaults to blocked on PPC? */
 226     unblock_gc_signals(0,0);
 227 #endif
 228     function = th->no_tls_value_marker;
 229     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
 230     if(arch_os_thread_init(th)==0) return 1;
 231     link_thread(th);
 232     th->os_thread=thread_self();
 233 #ifndef LISP_FEATURE_WIN32
 234     protect_control_stack_hard_guard_page(1, NULL);
 235 #endif
 236     protect_binding_stack_hard_guard_page(1, NULL);
 237     protect_alien_stack_hard_guard_page(1, NULL);
 238 #ifndef LISP_FEATURE_WIN32
 239     protect_control_stack_guard_page(1, NULL);
 240 #endif
 241     protect_binding_stack_guard_page(1, NULL);
 242     protect_alien_stack_guard_page(1, NULL);
 243
 244 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
 245     return call_into_lisp_first_time(function,args,0);
 246 #else
 247     return funcall0(function);
 248 #endif
 249 }
 250
 251 #ifdef LISP_FEATURE_SB_THREAD
 252
 253 # if defined(IMMEDIATE_POST_MORTEM)
 254
 255 /*
 256  * If this feature is set, we are running on a stack managed by the OS,
 257  * and no fancy delays are required for anything.  Just do it.
 258  */
 259 static void
 260 schedule_thread_post_mortem(struct thread *corpse)
 261 {
 262     pthread_detach(pthread_self());
 263     gc_assert(!pthread_attr_destroy(corpse->os_attr));
 264 #if defined(LISP_FEATURE_WIN32)
 265     os_invalidate_free(corpse->os_address, THREAD_STRUCT_SIZE);
 266 #else
 267     os_invalidate(corpse->os_address, THREAD_STRUCT_SIZE);
 268 #endif
 269 }
 270
 271 # else
 272
 273 /* THREAD POST MORTEM CLEANUP
 274  *
 275  * Memory allocated for the thread stacks cannot be reclaimed while
 276  * the thread is still alive, so we need a mechanism for post mortem
 277  * cleanups. FIXME: We actually have three, for historical reasons as
 278  * the saying goes. Do we really need three? Nikodemus guesses that
 279  * not anymore, now that we properly call pthread_attr_destroy before
 280  * freeing the stack. */
 281
 282 static struct thread_post_mortem *
 283 plan_thread_post_mortem(struct thread *corpse)
 284 {
 285     if (corpse) {
 286         struct thread_post_mortem *post_mortem = malloc(sizeof(struct thread_post_mortem));
 287         gc_assert(post_mortem);
 288         post_mortem->os_thread = corpse->os_thread;
 289         post_mortem->os_attr = corpse->os_attr;
 290         post_mortem->os_address = corpse->os_address;
 291 #ifdef DELAY_THREAD_POST_MORTEM
 292         post_mortem->next = NULL;
 293 #endif
 294         return post_mortem;
 295     } else {
 296         /* FIXME: When does this happen? */
 297         return NULL;
 298     }
 299 }
 300
 301 static void
 302 perform_thread_post_mortem(struct thread_post_mortem *post_mortem)
 303 {
 304 #ifdef CREATE_POST_MORTEM_THREAD
 305     pthread_detach(pthread_self());
 306 #endif
 307     int result;
 308     if (post_mortem) {
 309         if ((result = pthread_join(post_mortem->os_thread, NULL))) {
 310             lose("Error calling pthread_join in perform_thread_post_mortem:\n%s",
 311                  strerror(result));
 312         }
 313         if ((result = pthread_attr_destroy(post_mortem->os_attr))) {
 314             lose("Error calling pthread_attr_destroy in perform_thread_post_mortem:\n%s",
 315                  strerror(result));
 316         }
 317         os_invalidate(post_mortem->os_address, THREAD_STRUCT_SIZE);
 318         free(post_mortem);
 319     }
 320 }
 321
 322 static void
 323 schedule_thread_post_mortem(struct thread *corpse)
 324 {
 325     struct thread_post_mortem *post_mortem = NULL;
 326     if (corpse) {
 327         post_mortem = plan_thread_post_mortem(corpse);
 328
 329 #ifdef DELAY_THREAD_POST_MORTEM
 330         pthread_mutex_lock(&thread_post_mortem_lock);
 331         /* First stick the new post mortem to the end of the queue. */
 332         if (pending_thread_post_mortem) {
 333             struct thread_post_mortem *next = pending_thread_post_mortem;
 334             while (next->next) {
 335                 next = next->next;
 336             }
 337             next->next = post_mortem;
 338         } else {
 339             pending_thread_post_mortem = post_mortem;
 340         }
 341         /* Then, if there are enough things in the queue, clean up one
 342          * from the head -- or increment the count, and null out the
 343          * post_mortem we have. */
 344         if (pending_thread_post_mortem_count > DELAY_THREAD_POST_MORTEM) {
 345             post_mortem = pending_thread_post_mortem;
 346             pending_thread_post_mortem = post_mortem->next;
 347         } else {
 348             pending_thread_post_mortem_count++;
 349             post_mortem = NULL;
 350         }
 351         pthread_mutex_unlock(&thread_post_mortem_lock);
 352         /* Finally run, the cleanup, if any. */
 353         perform_thread_post_mortem(post_mortem);
 354 #elif defined(CREATE_POST_MORTEM_THREAD)
 355         gc_assert(!pthread_create(&thread, NULL, perform_thread_post_mortem, post_mortem));
 356 #else
 357         post_mortem = (struct thread_post_mortem *)
 358             swap_lispobjs((lispobj *)(void *)&pending_thread_post_mortem,
 359                           (lispobj)post_mortem);
 360         perform_thread_post_mortem(post_mortem);
 361 #endif
 362     }
 363 }
 364
 365 # endif /* !IMMEDIATE_POST_MORTEM */
 366
 367 /* Note: scribble must be stack-allocated */
 368 static void
 369 init_new_thread(struct thread *th, init_thread_data *scribble, int guardp)
 370 {
 371     int lock_ret;
 372
 373     pthread_setspecific(lisp_thread, (void *)1);
 374     if(arch_os_thread_init(th)==0) {
 375         /* FIXME: handle error */
 376         lose("arch_os_thread_init failed\n");
 377     }
 378
 379     th->os_thread=thread_self();
 380     if (guardp)
 381         protect_control_stack_guard_page(1, NULL);
 382     protect_binding_stack_guard_page(1, NULL);
 383     protect_alien_stack_guard_page(1, NULL);
 384     /* Since GC can only know about this thread from the all_threads
 385      * list and we're just adding this thread to it, there is no
 386      * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which
 387      * it is not). */
 388 #ifdef LISP_FEATURE_SB_SAFEPOINT
 389     *th->csp_around_foreign_call = (lispobj)scribble;
 390 #endif
 391     lock_ret = pthread_mutex_lock(&all_threads_lock);
 392     gc_assert(lock_ret == 0);
 393     link_thread(th);
 394     lock_ret = pthread_mutex_unlock(&all_threads_lock);
 395     gc_assert(lock_ret == 0);
 396
 397     /* Kludge: Changed the order of some steps between the safepoint/
 398      * non-safepoint versions of this code.  Can we unify this more?
 399      */
 400 #ifdef LISP_FEATURE_SB_SAFEPOINT
 401     gc_state_lock();
 402     gc_state_wait(GC_NONE);
 403     gc_state_unlock();
 404     push_gcing_safety(&scribble->safety);
 405 #endif
 406 }
 407
 408 static void
 409 undo_init_new_thread(struct thread *th, init_thread_data *scribble)
 410 {
 411     int lock_ret;
 412
 413     /* Kludge: Changed the order of some steps between the safepoint/
 414      * non-safepoint versions of this code.  Can we unify this more?
 415      */
 416 #ifdef LISP_FEATURE_SB_SAFEPOINT
 417     block_blockable_signals(0, 0);
 418     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
 419 #if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
 420     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
 421 #endif
 422     pop_gcing_safety(&scribble->safety);
 423     lock_ret = pthread_mutex_lock(&all_threads_lock);
 424     gc_assert(lock_ret == 0);
 425     unlink_thread(th);
 426     lock_ret = pthread_mutex_unlock(&all_threads_lock);
 427     gc_assert(lock_ret == 0);
 428 #else
 429     /* Block GC */
 430     block_blockable_signals(0, 0);
 431     set_thread_state(th, STATE_DEAD);
 432
 433     /* SIG_STOP_FOR_GC is blocked and GC might be waiting for this
 434      * thread, but since we are already dead it won't wait long. */
 435     lock_ret = pthread_mutex_lock(&all_threads_lock);
 436     gc_assert(lock_ret == 0);
 437
 438     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
 439 #if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
 440     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
 441 #endif
 442     unlink_thread(th);
 443     pthread_mutex_unlock(&all_threads_lock);
 444     gc_assert(lock_ret == 0);
 445 #endif
 446
 447     arch_os_thread_cleanup(th);
 448
 449 #ifndef LISP_FEATURE_SB_SAFEPOINT
 450     os_sem_destroy(th->state_sem);
 451     os_sem_destroy(th->state_not_running_sem);
 452     os_sem_destroy(th->state_not_stopped_sem);
 453 #endif
 454
 455
 456 #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER
 457     mach_lisp_thread_destroy(th);
 458 #endif
 459
 460 #if defined(LISP_FEATURE_WIN32)
 461     int i;
 462     for (i = 0; i<
 463              (int) (sizeof(th->private_events.events)/
 464                     sizeof(th->private_events.events[0])); ++i) {
 465       CloseHandle(th->private_events.events[i]);
 466     }
 467     TlsSetValue(OUR_TLS_INDEX,NULL);
 468 #endif
 469
 470     /* Undo the association of the current pthread to its `struct thread',
 471      * such that we can call arch_os_get_current_thread() later in this
 472      * thread and cleanly get back NULL. */
 473 #ifdef LISP_FEATURE_GCC_TLS
 474     current_thread = NULL;
 475 #else
 476     pthread_setspecific(specials, NULL);
 477 #endif
 478 }
 479
 480 /* this is the first thing that runs in the child (which is why the
 481  * silly calling convention).  Basically it calls the user's requested
 482  * lisp function after doing arch_os_thread_init and whatever other
 483  * bookkeeping needs to be done
 484  */
 485 int
 486 new_thread_trampoline(struct thread *th)
 487 {
 488     int result;
 489     init_thread_data scribble;
 490
 491     FSHOW((stderr,"/creating thread %lu\n", thread_self()));
 492     check_deferrables_blocked_or_lose(0);
 493 #ifndef LISP_FEATURE_SB_SAFEPOINT
 494     check_gc_signals_unblocked_or_lose(0);
 495 #endif
 496
 497     lispobj function = th->no_tls_value_marker;
 498     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
 499     init_new_thread(th, &scribble, 1);
 500     result = funcall0(function);
 501     undo_init_new_thread(th, &scribble);
 502
 503     schedule_thread_post_mortem(th);
 504
 505     FSHOW((stderr,"/exiting thread %lu\n", thread_self()));
 506     return result;
 507 }
 508
 509 static struct thread *create_thread_struct(lispobj);
 510
 511 void
 512 attach_os_thread(init_thread_data *scribble)
 513 {
 514     os_thread_t os = pthread_self();
 515     odxprint(misc, "attach_os_thread: attaching to %p", os);
 516
 517     struct thread *th = create_thread_struct(NIL);
 518     block_deferrable_signals(0, &scribble->oldset);
 519     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
 520     /* We don't actually want a pthread_attr here, but rather than add
 521      * `if's to the post-mostem, let's just keep that code happy by
 522      * keeping it initialized: */
 523     pthread_attr_init(th->os_attr);
 524
 525 #ifndef LISP_FEATURE_WIN32
 526     /* On windows, arch_os_thread_init will take care of finding the
 527      * stack. */
 528     void *stack_addr;
 529     size_t stack_size;
 530 #ifdef LISP_FEATURE_OPENBSD
 531     stack_t stack;
 532     pthread_stackseg_np(os, &stack);
 533     stack_size = stack.ss_size;
 534     stack_addr = (void*)((size_t)stack.ss_sp - stack_size);
 535 #elif defined LISP_FEATURE_SUNOS
 536   stack_t stack;
 537   thr_stksegment(&stack);
 538   stack_size = stack.ss_size;
 539   stack_addr = (void*)((size_t)stack.ss_sp - stack_size);
 540 #elif defined(LISP_FEATURE_DARWIN)
 541     stack_addr = pthread_get_stackaddr_np(os);
 542     stack_size = pthread_get_stacksize_np(os);
 543 #else
 544     pthread_attr_t attr;
 545 #ifdef LISP_FEATURE_FREEBSD
 546     pthread_attr_get_np(os, &attr);
 547 #else
 548     int pthread_getattr_np(pthread_t, pthread_attr_t *);
 549     pthread_getattr_np(os, &attr);
 550 #endif
 551     pthread_attr_getstack(&attr, &stack_addr, &stack_size);
 552 #endif
 553
 554     th->control_stack_start = stack_addr;
 555     th->control_stack_end = (void *) (((uintptr_t) stack_addr) + stack_size);
 556 #endif
 557
 558     init_new_thread(th, scribble, 0);
 559
 560     /* We will be calling into Lisp soon, and the functions being called
 561      * recklessly ignore the comment in target-thread which says that we
 562      * must be careful to not cause GC while initializing a new thread.
 563      * Since we first need to create a fresh thread object, it's really
 564      * tempting to just perform such unsafe allocation though.  So let's
 565      * at least try to suppress GC before consing, and hope that it
 566      * works: */
 567     bind_variable(GC_INHIBIT, T, th);
 568
 569     uword_t stacksize
 570         = (uword_t) th->control_stack_end - (uword_t) th->control_stack_start;
 571     odxprint(misc, "attach_os_thread: attached %p as %p (0x%lx bytes stack)",
 572              os, th, (long) stacksize);
 573 }
 574
 575 void
 576 detach_os_thread(init_thread_data *scribble)
 577 {
 578     struct thread *th = arch_os_get_current_thread();
 579     odxprint(misc, "detach_os_thread: detaching");
 580
 581     undo_init_new_thread(th, scribble);
 582
 583     odxprint(misc, "deattach_os_thread: detached");
 584     pthread_setspecific(lisp_thread, (void *)0);
 585     thread_sigmask(SIG_SETMASK, &scribble->oldset, 0);
 586 }
 587
 588 void
 589 callback_wrapper_trampoline(
 590 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
 591     /* On the x86oid backends, the assembly wrapper happens to not pass
 592      * in ENTER_ALIEN_CALLBACK explicitly for safepoints.  However, the
 593      * platforms with precise GC are tricky enough already, and I want
 594      * to minimize the read-time conditionals.  For those platforms, I'm
 595      * only replacing funcall3 with callback_wrapper_trampoline while
 596      * keeping the arguments unchanged. --DFL */
 597     lispobj __attribute__((__unused__)) fun,
 598 #endif
 599     lispobj arg0, lispobj arg1, lispobj arg2)
 600 {
 601 #if defined(LISP_FEATURE_WIN32)
 602     pthread_np_notice_thread();
 603 #endif
 604     struct thread* th = arch_os_get_current_thread();
 605     if (!th) {                  /* callback invoked in non-lisp thread */
 606         init_thread_data scribble;
 607         attach_os_thread(&scribble);
 608         funcall3(StaticSymbolFunction(ENTER_FOREIGN_CALLBACK), arg0,arg1,arg2);
 609         detach_os_thread(&scribble);
 610         return;
 611     }
 612
 613 #ifdef LISP_FEATURE_WIN32
 614     /* arg2 is the pointer to a return value, which sits on the stack */
 615     th->carried_base_pointer = (os_context_register_t) *(((void**)arg2)-1);
 616 #endif
 617
 618 #ifdef LISP_FEATURE_SB_SAFEPOINT
 619     WITH_GC_AT_SAFEPOINTS_ONLY()
 620 #endif
 621     {
 622        funcall3(SymbolValue(ENTER_ALIEN_CALLBACK, 0), arg0, arg1, arg2);
 623
 624     }
 625 }
 626 #endif /* LISP_FEATURE_SB_THREAD */
 627
 628 static void
 629 free_thread_struct(struct thread *th)
 630 {
 631 #if defined(LISP_FEATURE_WIN32)
 632     os_invalidate_free((os_vm_address_t) th->os_address, THREAD_STRUCT_SIZE);
 633 #else
 634     os_invalidate((os_vm_address_t) th->os_address, THREAD_STRUCT_SIZE);
 635 #endif
 636 }
 637
 638 #ifdef LISP_FEATURE_SB_THREAD
 639 /* FIXME: should be MAX_INTERRUPTS -1 ? */
 640 const unsigned int tls_index_start =
 641   MAX_INTERRUPTS + sizeof(struct thread)/sizeof(lispobj);
 642 #endif
 643
 644 /* this is called from any other thread to create the new one, and
 645  * initialize all parts of it that can be initialized from another
 646  * thread
 647  */
 648
 649 static struct thread *
 650 create_thread_struct(lispobj initial_function) {
 651     union per_thread_data *per_thread;
 652     struct thread *th=0;        /*  subdue gcc */
 653     void *spaces=0;
 654     void *aligned_spaces=0;
 655 #if defined(LISP_FEATURE_SB_THREAD) || defined(LISP_FEATURE_WIN32)
 656     unsigned int i;
 657 #endif
 658
 659     /* May as well allocate all the spaces at once: it saves us from
 660      * having to decide what to do if only some of the allocations
 661      * succeed. SPACES must be appropriately aligned, since the GC
 662      * expects the control stack to start at a page boundary -- and
 663      * the OS may have even more rigorous requirements. We can't rely
 664      * on the alignment passed from os_validate, since that might
 665      * assume the current (e.g. 4k) pagesize, while we calculate with
 666      * the biggest (e.g. 64k) pagesize allowed by the ABI. */
 667     spaces=os_validate(0, THREAD_STRUCT_SIZE);
 668     if(!spaces)
 669         return NULL;
 670     /* Aligning up is safe as THREAD_STRUCT_SIZE has
 671      * THREAD_ALIGNMENT_BYTES padding. */
 672     aligned_spaces = (void *)((((uword_t)(char *)spaces)
 673                                + THREAD_ALIGNMENT_BYTES-1)
 674                               &~(uword_t)(THREAD_ALIGNMENT_BYTES-1));
 675     void* csp_page=
 676         (aligned_spaces+
 677          thread_control_stack_size+
 678          BINDING_STACK_SIZE+
 679          ALIEN_STACK_SIZE);
 680     per_thread=(union per_thread_data *)
 681         (csp_page + THREAD_CSP_PAGE_SIZE);
 682
 683 #ifdef LISP_FEATURE_SB_THREAD
 684     for(i = 0; i < (dynamic_values_bytes / sizeof(lispobj)); i++)
 685         per_thread->dynamic_values[i] = NO_TLS_VALUE_MARKER_WIDETAG;
 686 #endif
 687
 688     th=&per_thread->thread;
 689     th->os_address = spaces;
 690     th->control_stack_start = aligned_spaces;
 691     th->binding_stack_start=
 692         (lispobj*)((void*)th->control_stack_start+thread_control_stack_size);
 693     th->control_stack_end = th->binding_stack_start;
 694     th->control_stack_guard_page_protected = T;
 695     th->alien_stack_start=
 696         (lispobj*)((void*)th->binding_stack_start+BINDING_STACK_SIZE);
 697     set_binding_stack_pointer(th,th->binding_stack_start);
 698     th->this=th;
 699     th->os_thread=0;
 700
 701 #ifdef LISP_FEATURE_SB_SAFEPOINT
 702 # ifdef LISP_FEATURE_WIN32
 703     th->carried_base_pointer = 0;
 704 # endif
 705 # ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
 706     th->pc_around_foreign_call = 0;
 707 # endif
 708     th->csp_around_foreign_call = csp_page;
 709 #endif
 710
 711 #ifdef LISP_FEATURE_SB_THREAD
 712
 713     struct nonpointer_thread_data *nonpointer_data
 714       = (void *) &per_thread->dynamic_values[TLS_SIZE];
 715     th->os_attr = &nonpointer_data->os_attr;
 716     th->interrupt_data = &nonpointer_data->interrupt_data;
 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 }