fix bug in SYMBOL-VALUE CAS expansion for constant arguments
[sbcl.git] / 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 <signal.h>
21 #include <stddef.h>
22 #include <errno.h>
23 #include <sys/types.h>
24 #ifndef LISP_FEATURE_WIN32
25 #include <sys/wait.h>
26 #endif
27
28 #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER
29 #include <mach/mach.h>
30 #include <mach/mach_error.h>
31 #include <mach/mach_types.h>
32 #endif
33
34 #include "runtime.h"
35 #include "validate.h"           /* for BINDING_STACK_SIZE etc */
36 #include "thread.h"
37 #include "arch.h"
38 #include "target-arch-os.h"
39 #include "os.h"
40 #include "globals.h"
41 #include "dynbind.h"
42 #include "genesis/cons.h"
43 #include "genesis/fdefn.h"
44 #include "interr.h"             /* for lose() */
45 #include "alloc.h"
46 #include "gc-internal.h"
47 #include "cpputil.h"
48 #include "pseudo-atomic.h"
49 #include "interrupt.h"
50 #include "lispregs.h"
51
52 #ifdef LISP_FEATURE_WIN32
53 /*
54  * Win32 doesn't have SIGSTKSZ, and we're not switching stacks anyway,
55  * so define it arbitrarily
56  */
57 #define SIGSTKSZ 1024
58 #endif
59
60 #if defined(LISP_FEATURE_DARWIN) && defined(LISP_FEATURE_SB_THREAD)
61 #define DELAY_THREAD_POST_MORTEM 5
62 #define LOCK_CREATE_THREAD
63 #endif
64
65 #ifdef LISP_FEATURE_FREEBSD
66 #define CREATE_CLEANUP_THREAD
67 #define LOCK_CREATE_THREAD
68 #endif
69
70 #ifdef LISP_FEATURE_SB_THREAD
71 struct thread_post_mortem {
72 #ifdef DELAY_THREAD_POST_MORTEM
73     struct thread_post_mortem *next;
74 #endif
75     os_thread_t os_thread;
76     pthread_attr_t *os_attr;
77     os_vm_address_t os_address;
78 };
79
80 #ifdef DELAY_THREAD_POST_MORTEM
81 static int pending_thread_post_mortem_count = 0;
82 pthread_mutex_t thread_post_mortem_lock = PTHREAD_MUTEX_INITIALIZER;
83 #endif
84 static struct thread_post_mortem * volatile pending_thread_post_mortem = 0;
85 #endif
86
87 int dynamic_values_bytes=TLS_SIZE*sizeof(lispobj);  /* same for all threads */
88 struct thread *all_threads;
89 extern struct interrupt_data * global_interrupt_data;
90
91 #ifdef LISP_FEATURE_SB_THREAD
92 pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER;
93 #ifdef LOCK_CREATE_THREAD
94 static pthread_mutex_t create_thread_lock = PTHREAD_MUTEX_INITIALIZER;
95 #endif
96 #ifdef LISP_FEATURE_GCC_TLS
97 __thread struct thread *current_thread;
98 #endif
99 pthread_key_t lisp_thread = 0;
100 #endif
101
102 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
103 extern lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs);
104 #endif
105
106 static void
107 link_thread(struct thread *th)
108 {
109     if (all_threads) all_threads->prev=th;
110     th->next=all_threads;
111     th->prev=0;
112     all_threads=th;
113 }
114
115 #ifdef LISP_FEATURE_SB_THREAD
116 static void
117 unlink_thread(struct thread *th)
118 {
119     if (th->prev)
120         th->prev->next = th->next;
121     else
122         all_threads = th->next;
123     if (th->next)
124         th->next->prev = th->prev;
125 }
126
127 /* Only access thread state with blockables blocked. */
128 lispobj
129 thread_state(struct thread *thread)
130 {
131     lispobj state;
132     sigset_t old;
133     block_blockable_signals(NULL, &old);
134     os_sem_wait(thread->state_sem, "thread_state");
135     state = thread->state;
136     os_sem_post(thread->state_sem, "thread_state");
137     thread_sigmask(SIG_SETMASK, &old, NULL);
138     return state;
139 }
140
141 void
142 set_thread_state(struct thread *thread, lispobj state)
143 {
144     int i, waitcount = 0;
145     sigset_t old;
146     block_blockable_signals(NULL, &old);
147     os_sem_wait(thread->state_sem, "set_thread_state");
148     if (thread->state != state) {
149         if ((STATE_STOPPED==state) ||
150             (STATE_DEAD==state)) {
151             waitcount = thread->state_not_running_waitcount;
152             thread->state_not_running_waitcount = 0;
153             for (i=0; i<waitcount; i++)
154                 os_sem_post(thread->state_not_running_sem, "set_thread_state (not running)");
155         }
156         if ((STATE_RUNNING==state) ||
157             (STATE_DEAD==state)) {
158             waitcount = thread->state_not_stopped_waitcount;
159             thread->state_not_stopped_waitcount = 0;
160             for (i=0; i<waitcount; i++)
161                 os_sem_post(thread->state_not_stopped_sem, "set_thread_state (not stopped)");
162         }
163         thread->state = state;
164     }
165     os_sem_post(thread->state_sem, "set_thread_state");
166     thread_sigmask(SIG_SETMASK, &old, NULL);
167 }
168
169 void
170 wait_for_thread_state_change(struct thread *thread, lispobj state)
171 {
172     sigset_t old;
173     os_sem_t *wait_sem;
174     block_blockable_signals(NULL, &old);
175   start:
176     os_sem_wait(thread->state_sem, "wait_for_thread_state_change");
177     if (thread->state == state) {
178         switch (state) {
179         case STATE_RUNNING:
180             wait_sem = thread->state_not_running_sem;
181             thread->state_not_running_waitcount++;
182             break;
183         case STATE_STOPPED:
184             wait_sem = thread->state_not_stopped_sem;
185             thread->state_not_stopped_waitcount++;
186             break;
187         default:
188             lose("Invalid state in wait_for_thread_state_change: "OBJ_FMTX"\n", state);
189         }
190     } else {
191         wait_sem = NULL;
192     }
193     os_sem_post(thread->state_sem, "wait_for_thread_state_change");
194     if (wait_sem) {
195         os_sem_wait(wait_sem, "wait_for_thread_state_change");
196         goto start;
197     }
198     thread_sigmask(SIG_SETMASK, &old, NULL);
199 }
200 #endif
201
202 static int
203 initial_thread_trampoline(struct thread *th)
204 {
205     lispobj function;
206 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
207     lispobj *args = NULL;
208 #endif
209 #ifdef LISP_FEATURE_SB_THREAD
210     pthread_setspecific(lisp_thread, (void *)1);
211 #endif
212 #if defined(THREADS_USING_GCSIGNAL) && defined(LISP_FEATURE_PPC)
213     /* SIG_STOP_FOR_GC defaults to blocked on PPC? */
214     unblock_gc_signals(0,0);
215 #endif
216     function = th->no_tls_value_marker;
217     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
218     if(arch_os_thread_init(th)==0) return 1;
219 #ifdef LISP_FEATURE_SB_SAFEPOINT
220     pthread_mutex_lock(thread_qrl(th));
221 #endif
222     link_thread(th);
223     th->os_thread=thread_self();
224 #ifndef LISP_FEATURE_WIN32
225     protect_control_stack_hard_guard_page(1, NULL);
226     protect_binding_stack_hard_guard_page(1, NULL);
227     protect_alien_stack_hard_guard_page(1, NULL);
228     protect_control_stack_guard_page(1, NULL);
229     protect_binding_stack_guard_page(1, NULL);
230     protect_alien_stack_guard_page(1, NULL);
231 #endif
232
233 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
234     return call_into_lisp_first_time(function,args,0);
235 #else
236     return funcall0(function);
237 #endif
238 }
239
240 #ifdef LISP_FEATURE_SB_THREAD
241 /* THREAD POST MORTEM CLEANUP
242  *
243  * Memory allocated for the thread stacks cannot be reclaimed while
244  * the thread is still alive, so we need a mechanism for post mortem
245  * cleanups. FIXME: We actually have three, for historical reasons as
246  * the saying goes. Do we really need three? Nikodemus guesses that
247  * not anymore, now that we properly call pthread_attr_destroy before
248  * freeing the stack. */
249
250 static struct thread_post_mortem *
251 plan_thread_post_mortem(struct thread *corpse)
252 {
253     if (corpse) {
254         struct thread_post_mortem *post_mortem = malloc(sizeof(struct thread_post_mortem));
255         gc_assert(post_mortem);
256         post_mortem->os_thread = corpse->os_thread;
257         post_mortem->os_attr = corpse->os_attr;
258         post_mortem->os_address = corpse->os_address;
259 #ifdef DELAY_THREAD_POST_MORTEM
260         post_mortem->next = NULL;
261 #endif
262         return post_mortem;
263     } else {
264         /* FIXME: When does this happen? */
265         return NULL;
266     }
267 }
268
269 static void
270 perform_thread_post_mortem(struct thread_post_mortem *post_mortem)
271 {
272 #ifdef CREATE_POST_MORTEM_THREAD
273     pthread_detach(pthread_self());
274 #endif
275     if (post_mortem) {
276         gc_assert(!pthread_join(post_mortem->os_thread, NULL));
277         gc_assert(!pthread_attr_destroy(post_mortem->os_attr));
278         free(post_mortem->os_attr);
279         os_invalidate(post_mortem->os_address, THREAD_STRUCT_SIZE);
280         free(post_mortem);
281     }
282 }
283
284 static void
285 schedule_thread_post_mortem(struct thread *corpse)
286 {
287     struct thread_post_mortem *post_mortem = NULL;
288     if (corpse) {
289         post_mortem = plan_thread_post_mortem(corpse);
290
291 #ifdef DELAY_THREAD_POST_MORTEM
292         pthread_mutex_lock(&thread_post_mortem_lock);
293         /* First stick the new post mortem to the end of the queue. */
294         if (pending_thread_post_mortem) {
295             struct thread_post_mortem *next = pending_thread_post_mortem;
296             while (next->next) {
297                 next = next->next;
298             }
299             next->next = post_mortem;
300         } else {
301             pending_thread_post_mortem = post_mortem;
302         }
303         /* Then, if there are enough things in the queue, clean up one
304          * from the head -- or increment the count, and null out the
305          * post_mortem we have. */
306         if (pending_thread_post_mortem_count > DELAY_THREAD_POST_MORTEM) {
307             post_mortem = pending_thread_post_mortem;
308             pending_thread_post_mortem = post_mortem->next;
309         } else {
310             pending_thread_post_mortem_count++;
311             post_mortem = NULL;
312         }
313         pthread_mutex_unlock(&thread_post_mortem_lock);
314         /* Finally run, the cleanup, if any. */
315         perform_thread_post_mortem(post_mortem);
316 #elif defined(CREATE_POST_MORTEM_THREAD)
317         gc_assert(!pthread_create(&thread, NULL, perform_thread_post_mortem, post_mortem));
318 #else
319         post_mortem = (struct thread_post_mortem *)
320             swap_lispobjs((lispobj *)(void *)&pending_thread_post_mortem,
321                           (lispobj)post_mortem);
322         perform_thread_post_mortem(post_mortem);
323 #endif
324     }
325 }
326
327 /* this is the first thing that runs in the child (which is why the
328  * silly calling convention).  Basically it calls the user's requested
329  * lisp function after doing arch_os_thread_init and whatever other
330  * bookkeeping needs to be done
331  */
332 int
333 new_thread_trampoline(struct thread *th)
334 {
335     lispobj function;
336     int result, lock_ret;
337
338     FSHOW((stderr,"/creating thread %lu\n", thread_self()));
339     check_deferrables_blocked_or_lose(0);
340 #ifndef LISP_FEATURE_SB_SAFEPOINT
341     check_gc_signals_unblocked_or_lose(0);
342 #endif
343     pthread_setspecific(lisp_thread, (void *)1);
344     function = th->no_tls_value_marker;
345     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
346     if(arch_os_thread_init(th)==0) {
347         /* FIXME: handle error */
348         lose("arch_os_thread_init failed\n");
349     }
350
351     th->os_thread=thread_self();
352     protect_control_stack_guard_page(1, NULL);
353     protect_binding_stack_guard_page(1, NULL);
354     protect_alien_stack_guard_page(1, NULL);
355     /* Since GC can only know about this thread from the all_threads
356      * list and we're just adding this thread to it, there is no
357      * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which
358      * it is not). */
359 #ifdef LISP_FEATURE_SB_SAFEPOINT
360     *th->csp_around_foreign_call = (lispobj)&function;
361     pthread_mutex_lock(thread_qrl(th));
362 #endif
363     lock_ret = pthread_mutex_lock(&all_threads_lock);
364     gc_assert(lock_ret == 0);
365     link_thread(th);
366     lock_ret = pthread_mutex_unlock(&all_threads_lock);
367     gc_assert(lock_ret == 0);
368
369     /* Kludge: Changed the order of some steps between the safepoint/
370      * non-safepoint versions of this code.  Can we unify this more?
371      */
372 #ifdef LISP_FEATURE_SB_SAFEPOINT
373     WITH_GC_AT_SAFEPOINTS_ONLY() {
374         result = funcall0(function);
375         block_blockable_signals(0, 0);
376         gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
377     }
378     lock_ret = pthread_mutex_lock(&all_threads_lock);
379     gc_assert(lock_ret == 0);
380     unlink_thread(th);
381     lock_ret = pthread_mutex_unlock(&all_threads_lock);
382     gc_assert(lock_ret == 0);
383     pthread_mutex_unlock(thread_qrl(th));
384     set_thread_state(th,STATE_DEAD);
385 #else
386     result = funcall0(function);
387
388     /* Block GC */
389     block_blockable_signals(0, 0);
390     set_thread_state(th, STATE_DEAD);
391
392     /* SIG_STOP_FOR_GC is blocked and GC might be waiting for this
393      * thread, but since we are already dead it won't wait long. */
394     lock_ret = pthread_mutex_lock(&all_threads_lock);
395     gc_assert(lock_ret == 0);
396
397     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
398     unlink_thread(th);
399     pthread_mutex_unlock(&all_threads_lock);
400     gc_assert(lock_ret == 0);
401 #endif
402
403     if(th->tls_cookie>=0) arch_os_thread_cleanup(th);
404     os_sem_destroy(th->state_sem);
405     os_sem_destroy(th->state_not_running_sem);
406     os_sem_destroy(th->state_not_stopped_sem);
407
408     os_invalidate((os_vm_address_t)th->interrupt_data,
409                   (sizeof (struct interrupt_data)));
410
411 #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER
412     mach_lisp_thread_destroy(th);
413 #endif
414
415     schedule_thread_post_mortem(th);
416     FSHOW((stderr,"/exiting thread %lu\n", thread_self()));
417     return result;
418 }
419
420 #endif /* LISP_FEATURE_SB_THREAD */
421
422 static void
423 free_thread_struct(struct thread *th)
424 {
425     if (th->interrupt_data)
426         os_invalidate((os_vm_address_t) th->interrupt_data,
427                       (sizeof (struct interrupt_data)));
428     os_invalidate((os_vm_address_t) th->os_address,
429                   THREAD_STRUCT_SIZE);
430 }
431
432 #ifdef LISP_FEATURE_SB_THREAD
433 /* FIXME: should be MAX_INTERRUPTS -1 ? */
434 const unsigned int tls_index_start =
435   MAX_INTERRUPTS + sizeof(struct thread)/sizeof(lispobj);
436 #endif
437
438 /* this is called from any other thread to create the new one, and
439  * initialize all parts of it that can be initialized from another
440  * thread
441  */
442
443 static struct thread *
444 create_thread_struct(lispobj initial_function) {
445     union per_thread_data *per_thread;
446     struct thread *th=0;        /*  subdue gcc */
447     void *spaces=0;
448     void *aligned_spaces=0;
449 #ifdef LISP_FEATURE_SB_THREAD
450     unsigned int i;
451 #endif
452
453     /* May as well allocate all the spaces at once: it saves us from
454      * having to decide what to do if only some of the allocations
455      * succeed. SPACES must be appropriately aligned, since the GC
456      * expects the control stack to start at a page boundary -- and
457      * the OS may have even more rigorous requirements. We can't rely
458      * on the alignment passed from os_validate, since that might
459      * assume the current (e.g. 4k) pagesize, while we calculate with
460      * the biggest (e.g. 64k) pagesize allowed by the ABI. */
461     spaces=os_validate(0, THREAD_STRUCT_SIZE);
462     if(!spaces)
463         return NULL;
464     /* Aligning up is safe as THREAD_STRUCT_SIZE has
465      * THREAD_ALIGNMENT_BYTES padding. */
466     aligned_spaces = (void *)((((unsigned long)(char *)spaces)
467                                + THREAD_ALIGNMENT_BYTES-1)
468                               &~(unsigned long)(THREAD_ALIGNMENT_BYTES-1));
469     void* csp_page=
470         (aligned_spaces+
471          thread_control_stack_size+
472          BINDING_STACK_SIZE+
473          ALIEN_STACK_SIZE);
474     per_thread=(union per_thread_data *)
475         (csp_page + THREAD_CSP_PAGE_SIZE);
476     struct nonpointer_thread_data *nonpointer_data
477         = (void *) &per_thread->dynamic_values[TLS_SIZE];
478
479 #ifdef LISP_FEATURE_SB_THREAD
480     for(i = 0; i < (dynamic_values_bytes / sizeof(lispobj)); i++)
481         per_thread->dynamic_values[i] = NO_TLS_VALUE_MARKER_WIDETAG;
482     if (all_threads == 0) {
483         if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) {
484             SetSymbolValue(FREE_TLS_INDEX,tls_index_start << WORD_SHIFT,0);
485             SetSymbolValue(TLS_INDEX_LOCK,make_fixnum(0),0);
486         }
487 #define STATIC_TLS_INIT(sym,field) \
488   ((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
489   (THREAD_SLOT_OFFSET_WORDS(field) << WORD_SHIFT)
490
491         STATIC_TLS_INIT(BINDING_STACK_START,binding_stack_start);
492 #ifdef BINDING_STACK_POINTER
493         STATIC_TLS_INIT(BINDING_STACK_POINTER,binding_stack_pointer);
494 #endif
495         STATIC_TLS_INIT(CONTROL_STACK_START,control_stack_start);
496         STATIC_TLS_INIT(CONTROL_STACK_END,control_stack_end);
497 #ifdef ALIEN_STACK
498         STATIC_TLS_INIT(ALIEN_STACK,alien_stack_pointer);
499 #endif
500 #if defined(LISP_FEATURE_X86) || defined (LISP_FEATURE_X86_64)
501         STATIC_TLS_INIT(PSEUDO_ATOMIC_BITS,pseudo_atomic_bits);
502 #endif
503 #undef STATIC_TLS_INIT
504     }
505 #endif
506
507     th=&per_thread->thread;
508     th->os_address = spaces;
509     th->control_stack_start = aligned_spaces;
510     th->binding_stack_start=
511         (lispobj*)((void*)th->control_stack_start+thread_control_stack_size);
512     th->control_stack_end = th->binding_stack_start;
513     th->control_stack_guard_page_protected = T;
514     th->alien_stack_start=
515         (lispobj*)((void*)th->binding_stack_start+BINDING_STACK_SIZE);
516     set_binding_stack_pointer(th,th->binding_stack_start);
517     th->this=th;
518     th->os_thread=0;
519
520 #ifdef LISP_FEATURE_SB_SAFEPOINT
521     th->pc_around_foreign_call = 0;
522     th->csp_around_foreign_call = csp_page;
523 #endif
524
525 #ifdef LISP_FEATURE_SB_THREAD
526     /* Contrary to the "allocate all the spaces at once" comment above,
527      * the os_attr is allocated separately.  We cannot put it into the
528      * nonpointer data, because it's used for post_mortem and freed
529      * separately */
530     th->os_attr=malloc(sizeof(pthread_attr_t));
531     th->nonpointer_data = nonpointer_data;
532     th->state_sem=&nonpointer_data->state_sem;
533     th->state_not_running_sem=&nonpointer_data->state_not_running_sem;
534     th->state_not_stopped_sem=&nonpointer_data->state_not_stopped_sem;
535     th->state_not_running_waitcount = 0;
536     th->state_not_stopped_waitcount = 0;
537     os_sem_init(th->state_sem, 1);
538     os_sem_init(th->state_not_running_sem, 0);
539     os_sem_init(th->state_not_stopped_sem, 0);
540 # ifdef LISP_FEATURE_SB_SAFEPOINT
541     pthread_mutex_init(thread_qrl(th), NULL);
542 # endif
543 #endif
544     th->state=STATE_RUNNING;
545 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
546     th->alien_stack_pointer=((void *)th->alien_stack_start
547                              + ALIEN_STACK_SIZE-N_WORD_BYTES);
548 #else
549     th->alien_stack_pointer=((void *)th->alien_stack_start);
550 #endif
551 #if defined(LISP_FEATURE_X86) || defined (LISP_FEATURE_X86_64) || defined(LISP_FEATURE_SB_THREAD)
552     th->pseudo_atomic_bits=0;
553 #endif
554 #ifdef LISP_FEATURE_GENCGC
555     gc_set_region_empty(&th->alloc_region);
556 #endif
557 #ifdef LISP_FEATURE_SB_THREAD
558     /* This parallels the same logic in globals.c for the
559      * single-threaded foreign_function_call_active, KLUDGE and
560      * all. */
561 #if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
562     th->foreign_function_call_active = 0;
563 #else
564     th->foreign_function_call_active = 1;
565 #endif
566 #endif
567
568 #ifndef LISP_FEATURE_SB_THREAD
569     /* the tls-points-into-struct-thread trick is only good for threaded
570      * sbcl, because unithread sbcl doesn't have tls.  So, we copy the
571      * appropriate values from struct thread here, and make sure that
572      * we use the appropriate SymbolValue macros to access any of the
573      * variable quantities from the C runtime.  It's not quite OAOOM,
574      * it just feels like it */
575     SetSymbolValue(BINDING_STACK_START,(lispobj)th->binding_stack_start,th);
576     SetSymbolValue(CONTROL_STACK_START,(lispobj)th->control_stack_start,th);
577     SetSymbolValue(CONTROL_STACK_END,(lispobj)th->control_stack_end,th);
578 #if defined(LISP_FEATURE_X86) || defined (LISP_FEATURE_X86_64)
579     SetSymbolValue(ALIEN_STACK,(lispobj)th->alien_stack_pointer,th);
580     SetSymbolValue(PSEUDO_ATOMIC_BITS,(lispobj)th->pseudo_atomic_bits,th);
581 #endif
582 #endif
583     bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th);
584     bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th);
585     bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,make_fixnum(0),th);
586     bind_variable(INTERRUPT_PENDING, NIL,th);
587     bind_variable(INTERRUPTS_ENABLED,T,th);
588     bind_variable(ALLOW_WITH_INTERRUPTS,T,th);
589     bind_variable(GC_PENDING,NIL,th);
590     bind_variable(ALLOC_SIGNAL,NIL,th);
591 #ifdef PINNED_OBJECTS
592     bind_variable(PINNED_OBJECTS,NIL,th);
593 #endif
594 #ifdef LISP_FEATURE_SB_THREAD
595     bind_variable(STOP_FOR_GC_PENDING,NIL,th);
596 #endif
597 #if defined(LISP_FEATURE_SB_SAFEPOINT)
598     bind_variable(GC_SAFE,NIL,th);
599     bind_variable(IN_SAFEPOINT,NIL,th);
600 #endif
601 #ifdef LISP_FEATURE_SB_THRUPTION
602     bind_variable(THRUPTION_PENDING,NIL,th);
603     bind_variable(RESTART_CLUSTERS,NIL,th);
604 #endif
605 #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
606     access_control_stack_pointer(th)=th->control_stack_start;
607 #endif
608
609     th->interrupt_data = (struct interrupt_data *)
610         os_validate(0,(sizeof (struct interrupt_data)));
611     if (!th->interrupt_data) {
612         free_thread_struct(th);
613         return 0;
614     }
615     th->interrupt_data->pending_handler = 0;
616     th->interrupt_data->gc_blocked_deferrables = 0;
617 #ifdef LISP_FEATURE_PPC
618     th->interrupt_data->allocation_trap_context = 0;
619 #endif
620     th->no_tls_value_marker=initial_function;
621
622     th->stepping = NIL;
623     return th;
624 }
625
626 void create_initial_thread(lispobj initial_function) {
627     struct thread *th=create_thread_struct(initial_function);
628 #ifdef LISP_FEATURE_SB_THREAD
629     pthread_key_create(&lisp_thread, 0);
630 #endif
631     if(th) {
632         initial_thread_trampoline(th); /* no return */
633     } else lose("can't create initial thread\n");
634 }
635
636 #ifdef LISP_FEATURE_SB_THREAD
637
638 #ifndef __USE_XOPEN2K
639 extern int pthread_attr_setstack (pthread_attr_t *__attr, void *__stackaddr,
640                                   size_t __stacksize);
641 #endif
642
643 boolean create_os_thread(struct thread *th,os_thread_t *kid_tid)
644 {
645     /* The new thread inherits the restrictive signal mask set here,
646      * and enables signals again when it is set up properly. */
647     sigset_t oldset;
648     boolean r=1;
649     int retcode = 0, initcode;
650
651     FSHOW_SIGNAL((stderr,"/create_os_thread: creating new thread\n"));
652
653     /* Blocking deferrable signals is enough, no need to block
654      * SIG_STOP_FOR_GC because the child process is not linked onto
655      * all_threads until it's ready. */
656     block_deferrable_signals(0, &oldset);
657
658 #ifdef LOCK_CREATE_THREAD
659     retcode = pthread_mutex_lock(&create_thread_lock);
660     gc_assert(retcode == 0);
661     FSHOW_SIGNAL((stderr,"/create_os_thread: got lock\n"));
662 #endif
663
664     if((initcode = pthread_attr_init(th->os_attr)) ||
665        /* call_into_lisp_first_time switches the stack for the initial
666         * thread. For the others, we use this. */
667        (pthread_attr_setstack(th->os_attr,th->control_stack_start,
668                               thread_control_stack_size)) ||
669        (retcode = pthread_create
670         (kid_tid,th->os_attr,(void *(*)(void *))new_thread_trampoline,th))) {
671         FSHOW_SIGNAL((stderr, "init = %d\n", initcode));
672         FSHOW_SIGNAL((stderr, "pthread_create returned %d, errno %d\n",
673                       retcode, errno));
674         if(retcode < 0) {
675             perror("create_os_thread");
676         }
677         r=0;
678     }
679
680 #ifdef LOCK_CREATE_THREAD
681     retcode = pthread_mutex_unlock(&create_thread_lock);
682     gc_assert(retcode == 0);
683     FSHOW_SIGNAL((stderr,"/create_os_thread: released lock\n"));
684 #endif
685     thread_sigmask(SIG_SETMASK,&oldset,0);
686     return r;
687 }
688
689 os_thread_t create_thread(lispobj initial_function) {
690     struct thread *th, *thread = arch_os_get_current_thread();
691     os_thread_t kid_tid = 0;
692
693     /* Must defend against async unwinds. */
694     if (SymbolValue(INTERRUPTS_ENABLED, thread) != NIL)
695         lose("create_thread is not safe when interrupts are enabled.\n");
696
697     /* Assuming that a fresh thread struct has no lisp objects in it,
698      * linking it to all_threads can be left to the thread itself
699      * without fear of gc lossage. initial_function violates this
700      * assumption and must stay pinned until the child starts up. */
701     th = create_thread_struct(initial_function);
702     if (th && !create_os_thread(th,&kid_tid)) {
703         free_thread_struct(th);
704         kid_tid = 0;
705     }
706     return kid_tid;
707 }
708
709 /* stopping the world is a two-stage process.  From this thread we signal
710  * all the others with SIG_STOP_FOR_GC.  The handler for this signal does
711  * the usual pseudo-atomic checks (we don't want to stop a thread while
712  * it's in the middle of allocation) then waits for another SIG_STOP_FOR_GC.
713  */
714 /*
715  * (With SB-SAFEPOINT, see the definitions in safepoint.c instead.)
716  */
717 #ifndef LISP_FEATURE_SB_SAFEPOINT
718
719 /* To avoid deadlocks when gc stops the world all clients of each
720  * mutex must enable or disable SIG_STOP_FOR_GC for the duration of
721  * holding the lock, but they must agree on which. */
722 void gc_stop_the_world()
723 {
724     struct thread *p,*th=arch_os_get_current_thread();
725     int status, lock_ret;
726 #ifdef LOCK_CREATE_THREAD
727     /* KLUDGE: Stopping the thread during pthread_create() causes deadlock
728      * on FreeBSD. */
729     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on create_thread_lock\n"));
730     lock_ret = pthread_mutex_lock(&create_thread_lock);
731     gc_assert(lock_ret == 0);
732     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got create_thread_lock\n"));
733 #endif
734     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock\n"));
735     /* keep threads from starting while the world is stopped. */
736     lock_ret = pthread_mutex_lock(&all_threads_lock);      \
737     gc_assert(lock_ret == 0);
738
739     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got lock\n"));
740     /* stop all other threads by sending them SIG_STOP_FOR_GC */
741     for(p=all_threads; p; p=p->next) {
742         gc_assert(p->os_thread != 0);
743         FSHOW_SIGNAL((stderr,"/gc_stop_the_world: thread=%lu, state=%x\n",
744                       p->os_thread, thread_state(p)));
745         if((p!=th) && ((thread_state(p)==STATE_RUNNING))) {
746             FSHOW_SIGNAL((stderr,"/gc_stop_the_world: suspending thread %lu\n",
747                           p->os_thread));
748             /* We already hold all_thread_lock, P can become DEAD but
749              * cannot exit, ergo it's safe to use pthread_kill. */
750             status=pthread_kill(p->os_thread,SIG_STOP_FOR_GC);
751             if (status==ESRCH) {
752                 /* This thread has exited. */
753                 gc_assert(thread_state(p)==STATE_DEAD);
754             } else if (status) {
755                 lose("cannot send suspend thread=%lu: %d, %s\n",
756                      p->os_thread,status,strerror(status));
757             }
758         }
759     }
760     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:signals sent\n"));
761     for(p=all_threads;p;p=p->next) {
762         if (p!=th) {
763             FSHOW_SIGNAL
764                 ((stderr,
765                   "/gc_stop_the_world: waiting for thread=%lu: state=%x\n",
766                   p->os_thread, thread_state(p)));
767             wait_for_thread_state_change(p, STATE_RUNNING);
768             if (p->state == STATE_RUNNING)
769                 lose("/gc_stop_the_world: unexpected state");
770         }
771     }
772     FSHOW_SIGNAL((stderr,"/gc_stop_the_world:end\n"));
773 }
774
775 void gc_start_the_world()
776 {
777     struct thread *p,*th=arch_os_get_current_thread();
778     int lock_ret;
779     /* if a resumed thread creates a new thread before we're done with
780      * this loop, the new thread will get consed on the front of
781      * all_threads, but it won't have been stopped so won't need
782      * restarting */
783     FSHOW_SIGNAL((stderr,"/gc_start_the_world:begin\n"));
784     for(p=all_threads;p;p=p->next) {
785         gc_assert(p->os_thread!=0);
786         if (p!=th) {
787             lispobj state = thread_state(p);
788             if (state != STATE_DEAD) {
789                 if(state != STATE_STOPPED) {
790                     lose("gc_start_the_world: wrong thread state is %d\n",
791                          fixnum_value(state));
792                 }
793                 FSHOW_SIGNAL((stderr, "/gc_start_the_world: resuming %lu\n",
794                               p->os_thread));
795                 set_thread_state(p, STATE_RUNNING);
796             }
797         }
798     }
799
800     lock_ret = pthread_mutex_unlock(&all_threads_lock);
801     gc_assert(lock_ret == 0);
802 #ifdef LOCK_CREATE_THREAD
803     lock_ret = pthread_mutex_unlock(&create_thread_lock);
804     gc_assert(lock_ret == 0);
805 #endif
806
807     FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n"));
808 }
809
810 #endif /* !LISP_FEATURE_SB_SAFEPOINT */
811 #endif /* !LISP_FEATURE_SB_THREAD */
812
813 int
814 thread_yield()
815 {
816 #ifdef LISP_FEATURE_SB_THREAD
817     return sched_yield();
818 #else
819     return 0;
820 #endif
821 }
822
823 int
824 wake_thread(os_thread_t os_thread)
825 {
826 #ifdef LISP_FEATURE_WIN32
827 # define SIGPIPE 1
828 #endif
829 #if !defined(LISP_FEATURE_SB_THRUPTION) || defined(LISP_FEATURE_WIN32)
830     return kill_safely(os_thread, SIGPIPE);
831 #else
832     return wake_thread_posix(os_thread);
833 #endif
834 }
835
836 /* If the thread id given does not belong to a running thread (it has
837  * exited or never even existed) pthread_kill _may_ fail with ESRCH,
838  * but it is also allowed to just segfault, see
839  * <http://udrepper.livejournal.com/16844.html>.
840  *
841  * Relying on thread ids can easily backfire since ids are recycled
842  * (NPTL recycles them extremely fast) so a signal can be sent to
843  * another process if the one it was sent to exited.
844  *
845  * For these reasons, we must make sure that the thread is still alive
846  * when the pthread_kill is called and return if the thread is
847  * exiting.
848  *
849  * Note (DFL, 2011-06-22): At the time of writing, this function is only
850  * used for INTERRUPT-THREAD, hence the wake_thread special-case for
851  * Windows is OK. */
852 int
853 kill_safely(os_thread_t os_thread, int signal)
854 {
855     FSHOW_SIGNAL((stderr,"/kill_safely: %lu, %d\n", os_thread, signal));
856     {
857 #ifdef LISP_FEATURE_SB_THREAD
858         sigset_t oldset;
859         struct thread *thread;
860         /* Frequent special case: resignalling to self.  The idea is
861          * that leave_region safepoint will acknowledge the signal, so
862          * there is no need to take locks, roll thread to safepoint
863          * etc. */
864         /* Kludge (on safepoint builds): At the moment, this isn't just
865          * an optimization; rather it masks the fact that
866          * gc_stop_the_world() grabs the all_threads mutex without
867          * releasing it, and since we're not using recursive pthread
868          * mutexes, the pthread_mutex_lock() around the all_threads loop
869          * would go wrong.  Why are we running interruptions while
870          * stopping the world though?  Test case is (:ASYNC-UNWIND
871          * :SPECIALS), especially with s/10/100/ in both loops. */
872         if (os_thread == pthread_self()) {
873             pthread_kill(os_thread, signal);
874             return 0;
875         }
876
877         /* pthread_kill is not async signal safe and we don't want to be
878          * interrupted while holding the lock. */
879         block_deferrable_signals(0, &oldset);
880         pthread_mutex_lock(&all_threads_lock);
881         for (thread = all_threads; thread; thread = thread->next) {
882             if (thread->os_thread == os_thread) {
883                 int status = pthread_kill(os_thread, signal);
884                 if (status)
885                     lose("kill_safely: pthread_kill failed with %d\n", status);
886                 break;
887             }
888         }
889         pthread_mutex_unlock(&all_threads_lock);
890         thread_sigmask(SIG_SETMASK,&oldset,0);
891         if (thread)
892             return 0;
893         else
894             return -1;
895 #else
896         int status;
897         if (os_thread != 0)
898             lose("kill_safely: who do you want to kill? %d?\n", os_thread);
899         /* Dubious (as in don't know why it works) workaround for the
900          * signal sometimes not being generated on darwin. */
901 #ifdef LISP_FEATURE_DARWIN
902         {
903             sigset_t oldset;
904             sigprocmask(SIG_BLOCK, &deferrable_sigset, &oldset);
905             status = raise(signal);
906             sigprocmask(SIG_SETMASK,&oldset,0);
907         }
908 #else
909         status = raise(signal);
910 #endif
911         if (status == 0) {
912             return 0;
913         } else {
914             lose("cannot raise signal %d, %d %s\n",
915                  signal, status, strerror(errno));
916         }
917 #endif
918     }
919 }