source: trunk/source/lisp-kernel/thread_manager.c @ 15437

Last change on this file since 15437 was 15437, checked in by gb, 7 years ago

Stop trying to get by on our good looks and charm (or at least
stop trying to assume that x8664 Darwin's malloc() will quickly
return a 32-bit pointer in allocate_tcr(). See ticket:1005.)
Instead, try to map a largish (1K) number of TCRs in free 32-bit
memory and manage them explicitly on x8664 Darwin.

Note that this isn't thread-safe in general: we do this by walking
our address space (via vm_region_64()) until we find a free 32-bit
block of memory and using mmap() (with the MAP_FIXED option). When
this happens at any time after application startup, it's possible
for some foreign thread to be mapping/unmapping regions while we're
doing this. (This is why OSes that provide mmap options that request
32-bit addresses do so in the kernel.) It's likely fairly hard in
practice to exceed the 1K initial TCR allocation and it's not clear
that this is any worse than the "wait until we get lucky with malloc()"
strategy has been, but it may be better to just do the TCR allocation
once on startup, avoid the (theoretical) thread-safety issues, and
treat the (possibly raised) value of TCR_CLUSTER_COUNT as a hard limit.

lisp-kernel/platform-darwinx8664: define DARWIN64, to make conditionalization
a little easier
lisp-kernel/memory.c: implement darwin_allocate_tcr() and darwin_free_tcr()
as outlined above
lisp-kernel/thread_manager.c: allocate_tcr() uses darwin_allocate_tcr() on
DARWIN64. Use darwin_free_tcr() instead of free() on DARWIN64. Make
shutdown_thread_tcr() dequeue the TCR and put it back in the free TCR
pool on DARWIN64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 60.5 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18
19#include "threads.h"
20
21
22typedef struct {
23  TCR *tcr;
24  natural vsize, tsize;
25  void *created;
26} thread_activation;
27
28#ifdef HAVE_TLS
29__thread char tcrbuf[sizeof(TCR)+16];
30__thread TCR *current_tcr;
31#endif
32
33/* This is set to true when running a 32-bit Lisp on 64-bit FreeBSD */
34Boolean rcontext_readonly = false;
35
36extern natural
37store_conditional(natural*, natural, natural);
38
39extern signed_natural
40atomic_swap(signed_natural*, signed_natural);
41
42#ifdef USE_FUTEX
43#define futex_wait(futex,val) syscall(SYS_futex,futex,FUTEX_WAIT,val)
44#define futex_wake(futex,n) syscall(SYS_futex,futex,FUTEX_WAKE,n)
45#define FUTEX_AVAIL (0)
46#define FUTEX_LOCKED (1)
47#define FUTEX_CONTENDED (2)
48#endif
49
50#ifdef WINDOWS
51extern pc spentry_start, spentry_end,subprims_start,subprims_end;
52extern pc restore_windows_context_start, restore_windows_context_end,
53  restore_windows_context_iret;
54
55
56extern void interrupt_handler(int, siginfo_t *, ExceptionInformation *);
57
58void CALLBACK
59nullAPC(ULONG_PTR arg) 
60{
61}
62 
63BOOL (*pCancelIoEx)(HANDLE, OVERLAPPED*) = NULL;
64BOOL (*pCancelSynchronousIo)(HANDLE) = NULL;
65
66
67
68extern void *windows_find_symbol(void*, char*);
69
70int
71raise_thread_interrupt(TCR *target)
72{
73  /* GCC doesn't align CONTEXT corrcectly */
74  char _contextbuf[sizeof(CONTEXT)+__alignof(CONTEXT)];
75  CONTEXT  *pcontext;
76  HANDLE hthread = (HANDLE)(TCR_AUX(target)->osid);
77  pc where;
78  area *ts = target->ts_area;
79  DWORD rc;
80  BOOL io_pending;
81
82  pcontext = (CONTEXT *)((((natural)&_contextbuf)+15)&~15);
83  rc = SuspendThread(hthread);
84  if (rc == -1) {
85    return -1;
86  }
87  /* What if the suspend count is > 1 at this point ?  I don't think
88     that that matters, but I'm not sure */
89  pcontext->ContextFlags = CONTEXT_ALL;
90  rc = GetThreadContext(hthread, pcontext);
91  if (rc == 0) {
92    return ESRCH;
93  }
94
95  where = (pc)(xpPC(pcontext));
96 
97  if ((target->valence != TCR_STATE_LISP) ||
98      (TCR_INTERRUPT_LEVEL(target) < 0) ||
99      (target->unwinding != 0) ||
100      (!((where < (pc)lisp_global(HEAP_END)) &&
101         (where >= (pc)lisp_global(HEAP_START))) &&
102       (!((where < (pc)(managed_static_area->active)) &&
103         (where >= (pc)(readonly_area->low)))) &&
104       !((where < spentry_end) && (where >= spentry_start)) &&
105       !((where < subprims_end) && (where >= subprims_start)) &&
106       !((where < (pc) 0x16000) &&
107         (where >= (pc) 0x15000)) &&
108       !((where < (pc) (ts->high)) &&
109         (where >= (pc) (ts->low))))) {
110
111    target->interrupt_pending = (1LL << (nbits_in_word - 1LL));
112
113#if 0
114    /* If the thread's in a blocking syscall, it'd be nice to
115       get it out of that state here. */
116    GetThreadIOPendingFlag(hthread,&io_pending);
117    if (io_pending) {
118      pending_io * pending = (pending_io *) (target->pending_io_info);
119      if (pending) {
120        if (pCancelIoEx) {
121          pCancelIoEx(pending->h, pending->o);
122        } else {
123          CancelIo(pending->h);
124        }
125      }
126    }
127#endif
128    if (pCancelSynchronousIo) {
129      pCancelSynchronousIo(hthread);
130    }
131    QueueUserAPC(nullAPC, hthread, 0);
132    ResumeThread(hthread);
133    return 0;
134  } else {
135    /* Thread is running lisp code with interupts enabled.  Set it
136       so that it calls out and then returns to the context,
137       handling any necessary pc-lusering. */
138    LispObj foreign_rsp = (((LispObj)(target->foreign_sp))-0x200)&~15;
139    CONTEXT *icontext = ((CONTEXT *) foreign_rsp) -1;
140    icontext = (CONTEXT *)(((LispObj)icontext)&~15);
141   
142    *icontext = *pcontext;
143
144#ifdef WIN_64   
145    xpGPR(pcontext,REG_RCX) = SIGNAL_FOR_PROCESS_INTERRUPT;
146    xpGPR(pcontext,REG_RDX) = 0;
147    xpGPR(pcontext,REG_R8) = (LispObj) icontext;
148    xpGPR(pcontext,REG_RSP) = (LispObj)(((LispObj *)icontext)-1);
149    *(((LispObj *)icontext)-1) = (LispObj)raise_thread_interrupt;
150#else
151    {
152      LispObj *p = (LispObj *)icontext;
153      p -= 4;
154      p[0] = SIGNAL_FOR_PROCESS_INTERRUPT;
155      p[1] = 0;
156      p[2] = (DWORD)icontext;
157      *(--p) = (LispObj)raise_thread_interrupt;;
158      xpGPR(pcontext,Isp) = (DWORD)p;
159    }
160#endif
161    pcontext->EFlags &= ~0x400;  /* clear direction flag */
162    xpPC(pcontext) = (LispObj)interrupt_handler;
163    SetThreadContext(hthread,pcontext);
164    ResumeThread(hthread);
165    return 0;
166  }
167}
168#else
169int
170raise_thread_interrupt(TCR *target)
171{
172  pthread_t thread = (pthread_t)TCR_AUX(target)->osid;
173#ifdef DARWIN_not_yet
174  if (use_mach_exception_handling) {
175    return mach_raise_thread_interrupt(target);
176  }
177#endif
178  if (thread != (pthread_t) 0) {
179    return pthread_kill(thread, SIGNAL_FOR_PROCESS_INTERRUPT);
180  }
181  return ESRCH;
182}
183#endif
184
185void
186set_thread_affinity(TCR *target, unsigned cpuno)
187{
188#ifdef LINUX
189#ifndef ANDROID                 /* too useful to be in Android ... */
190  pthread_t thread = (pthread_t)(target->osid);
191  cpu_set_t mask;
192 
193  CPU_ZERO(&mask);
194  CPU_SET(cpuno,&mask);
195  pthread_setaffinity_np(thread,sizeof(mask),&mask);
196#endif
197#endif
198}
199
200
201
202signed_natural
203atomic_incf_by(signed_natural *ptr, signed_natural by)
204{
205  signed_natural old, new;
206  do {
207    old = *ptr;
208    new = old+by;
209  } while (store_conditional((natural *)ptr, (natural) old, (natural) new) !=
210           (natural) old);
211  return new;
212}
213
214signed_natural
215atomic_incf(signed_natural *ptr)
216{
217  return atomic_incf_by(ptr, 1);
218}
219
220signed_natural
221atomic_decf(signed_natural *ptr)
222{
223  signed_natural old, new;
224  do {
225    old = *ptr;
226    new = old == 0 ? old : old-1;
227  } while (store_conditional((natural *)ptr, (natural) old, (natural) new) !=
228           (natural) old);
229  return old-1;
230}
231
232
233#ifndef USE_FUTEX
234int spin_lock_tries = 1;
235
236void
237get_spin_lock(signed_natural *p, TCR *tcr)
238{
239  int i, n = spin_lock_tries;
240 
241  while (1) {
242    for (i = 0; i < n; i++) {
243      if (atomic_swap(p,(signed_natural)tcr) == 0) {
244        return;
245      }
246    }
247#ifndef WINDOWS
248    sched_yield();
249#endif
250  }
251}
252#endif
253
254#ifndef USE_FUTEX
255int
256lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
257{
258
259  if (tcr == NULL) {
260    tcr = get_tcr(true);
261  }
262  if (m->owner == tcr) {
263    m->count++;
264    return 0;
265  }
266  while (1) {
267    LOCK_SPINLOCK(m->spinlock,tcr);
268    ++m->avail;
269    if (m->avail == 1) {
270      m->owner = tcr;
271      m->count = 1;
272      RELEASE_SPINLOCK(m->spinlock);
273      break;
274    }
275    RELEASE_SPINLOCK(m->spinlock);
276    SEM_WAIT_FOREVER(m->signal);
277  }
278  return 0;
279}
280
281#else /* USE_FUTEX */
282
283static void inline
284lock_futex(signed_natural *p)
285{
286 
287  while (1) {
288    if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) {
289      return;
290    }
291    while (1) {
292      if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) {
293        return;
294      }
295      futex_wait(p,FUTEX_CONTENDED);
296    }
297  }
298}
299
300static void inline
301unlock_futex(signed_natural *p)
302{
303  if (atomic_decf(p) != FUTEX_AVAIL) {
304    *p = FUTEX_AVAIL;
305    futex_wake(p,INT_MAX);
306  }
307}
308   
309int
310lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
311{
312  if (tcr == NULL) {
313    tcr = get_tcr(true);
314  }
315  if (m->owner == tcr) {
316    m->count++;
317    return 0;
318  }
319  lock_futex(&m->avail);
320  m->owner = tcr;
321  m->count = 1;
322  return 0;
323}
324#endif /* USE_FUTEX */
325
326
327#ifndef USE_FUTEX 
328int
329unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
330{
331  int ret = EPERM, pending;
332
333  if (tcr == NULL) {
334    tcr = get_tcr(true);
335  }
336
337  if (m->owner == tcr) {
338    --m->count;
339    if (m->count == 0) {
340      LOCK_SPINLOCK(m->spinlock,tcr);
341      m->owner = NULL;
342      pending = m->avail-1 + m->waiting;     /* Don't count us */
343      m->avail = 0;
344      --pending;
345      if (pending > 0) {
346        m->waiting = pending;
347      } else {
348        m->waiting = 0;
349      }
350      RELEASE_SPINLOCK(m->spinlock);
351      if (pending >= 0) {
352        SEM_RAISE(m->signal);
353      }
354    }
355    ret = 0;
356  }
357  return ret;
358}
359#else /* USE_FUTEX */
360int
361unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
362{
363  int ret = EPERM;
364
365   if (tcr == NULL) {
366    tcr = get_tcr(true);
367  }
368
369  if (m->owner == tcr) {
370    --m->count;
371    if (m->count == 0) {
372      m->owner = NULL;
373      unlock_futex(&m->avail);
374    }
375    ret = 0;
376  }
377  return ret;
378}
379#endif /* USE_FUTEX */
380
381void
382destroy_recursive_lock(RECURSIVE_LOCK m)
383{
384#ifndef USE_FUTEX
385  destroy_semaphore((void **)&m->signal);
386#endif
387  free((void *)(m->malloced_ptr));
388}
389
390/*
391  If we're already the owner (or if the lock is free), lock it
392  and increment the lock count; otherwise, return EBUSY without
393  waiting.
394*/
395
396#ifndef USE_FUTEX
397int
398recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free)
399{
400  TCR *owner = m->owner;
401
402  LOCK_SPINLOCK(m->spinlock,tcr);
403  if (owner == tcr) {
404    m->count++;
405    if (was_free) {
406      *was_free = 0;
407      RELEASE_SPINLOCK(m->spinlock);
408      return 0;
409    }
410  }
411  if (store_conditional((natural*)&(m->avail), 0, 1) == 0) {
412    m->owner = tcr;
413    m->count = 1;
414    if (was_free) {
415      *was_free = 1;
416    }
417    RELEASE_SPINLOCK(m->spinlock);
418    return 0;
419  }
420
421  RELEASE_SPINLOCK(m->spinlock);
422  return EBUSY;
423}
424#else
425int
426recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free)
427{
428  TCR *owner = m->owner;
429
430  if (owner == tcr) {
431    m->count++;
432    if (was_free) {
433      *was_free = 0;
434      return 0;
435    }
436  }
437  if (store_conditional((natural*)&(m->avail), 0, 1) == 0) {
438    m->owner = tcr;
439    m->count = 1;
440    if (was_free) {
441      *was_free = 1;
442    }
443    return 0;
444  }
445
446  return EBUSY;
447}
448#endif
449
450void
451sem_wait_forever(SEMAPHORE s)
452{
453  int status;
454
455  do {
456#ifdef USE_MACH_SEMAPHORES
457    status = SEM_WAIT(s);
458#endif
459#ifdef USE_POSIX_SEMAPHORES
460    status = SEM_WAIT(s);
461#endif
462#ifdef USE_WINDOWS_SEMAPHORES
463    status = (WaitForSingleObject(s,INFINITE) == WAIT_OBJECT_0) ? 0 : 1;
464#endif
465  } while (status != 0);
466}
467
468int
469wait_on_semaphore(void *s, int seconds, int millis)
470{
471#ifdef USE_POSIX_SEMAPHORES
472  int nanos = (millis % 1000) * 1000000;
473  int status;
474
475  struct timespec q;
476  clock_gettime(CLOCK_REALTIME,&q);
477   
478  q.tv_nsec += nanos;
479  if (q.tv_nsec >= 1000000000L) {
480    q.tv_nsec -= 1000000000L;
481    seconds += 1;
482  }
483  q.tv_sec += seconds;
484  status = SEM_TIMEDWAIT(s, &q);
485  if (status < 0) {
486    return errno;
487  }
488  return status;
489#endif
490#ifdef USE_MACH_SEMAPHORES
491  int nanos = (millis % 1000) * 1000000;
492  mach_timespec_t q = {seconds, nanos};
493  int status = SEM_TIMEDWAIT(s, q);
494
495 
496  switch (status) {
497  case 0: return 0;
498  case KERN_OPERATION_TIMED_OUT: return ETIMEDOUT;
499  case KERN_ABORTED: return EINTR;
500  default: return EINVAL;
501  }
502#endif
503#ifdef USE_WINDOWS_SEMAPHORES
504  switch (WaitForSingleObjectEx(s, seconds*1000L+(DWORD)millis,true)) {
505  case WAIT_OBJECT_0:
506    return 0;
507  case WAIT_TIMEOUT:
508    return /* ETIMEDOUT */ WAIT_TIMEOUT;
509  case WAIT_IO_COMPLETION:
510    return EINTR;
511  default:
512    break;
513  }
514  return EINVAL;
515
516#endif
517}
518
519
520int
521semaphore_maybe_timedwait(void *s, struct timespec *t)
522{
523  if (t) {
524    return wait_on_semaphore(s, t->tv_sec, t->tv_nsec/1000000L);
525  }
526  SEM_WAIT_FOREVER(s);
527  return 0;
528}
529
530void
531signal_semaphore(SEMAPHORE s)
532{
533  SEM_RAISE(s);
534}
535
536 
537#ifdef WINDOWS
538LispObj
539current_thread_osid()
540{
541  TCR *tcr = get_tcr(false);
542  LispObj current = 0;
543
544  if (tcr) {
545    current = TCR_AUX(tcr)->osid;
546  }
547  if (current == 0) {
548    DuplicateHandle(GetCurrentProcess(),
549                    GetCurrentThread(),
550                    GetCurrentProcess(),
551                    (LPHANDLE)(&current),
552                    0,
553                    FALSE,
554                    DUPLICATE_SAME_ACCESS);
555    if (tcr) {
556      TCR_AUX(tcr)->osid = current;
557    }
558  }
559  return current;
560}
561#else
562LispObj
563current_thread_osid()
564{
565  return (LispObj)ptr_to_lispobj(pthread_self());
566}
567#endif
568
569
570int thread_suspend_signal = 0, thread_kill_signal = 0;
571
572
573
574void
575linux_exception_init(TCR *tcr)
576{
577}
578
579
580TCR *
581get_interrupt_tcr(Boolean create)
582{
583  return get_tcr(create);
584}
585 
586void
587suspend_resume_handler(int signo, siginfo_t *info, ExceptionInformation *context)
588{
589  TCR *tcr = get_interrupt_tcr(false);
590 
591  if (tcr == NULL) {
592    /* Got a suspend signal sent to the pthread. */
593    extern natural initial_stack_size;
594    void register_thread_tcr(TCR *);
595   
596    tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
597    TCR_AUX(tcr)->suspend_count = 1;
598    tcr->vs_area->active -= node_size;
599    *(--tcr->save_vsp) = lisp_nil;
600    register_thread_tcr(tcr);
601  }
602  if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<<fixnumshift)) {
603    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
604  } else {
605    TCR_AUX(tcr)->suspend_context = context;
606    SEM_RAISE(TCR_AUX(tcr)->suspend);
607    SEM_WAIT_FOREVER(TCR_AUX(tcr)->resume);
608    TCR_AUX(tcr)->suspend_context = NULL;
609  }
610  SIGRETURN(context);
611}
612
613 
614
615/*
616  'base' should be set to the bottom (origin) of the stack, e.g., the
617  end from which it grows.
618*/
619 
620#ifdef WINDOWS
621void
622os_get_current_thread_stack_bounds(void **base, natural *size)
623{
624  natural natbase;
625  MEMORY_BASIC_INFORMATION info;
626  void *addr = (void *)current_stack_pointer();
627 
628  VirtualQuery(addr, &info, sizeof(info));
629  natbase = (natural)info.BaseAddress+info.RegionSize;
630  *size = natbase - (natural)(info.AllocationBase);
631  *base = (void *)natbase;
632}
633#else
634void
635os_get_current_thread_stack_bounds(void **base, natural *size)
636{
637  pthread_t p = pthread_self();
638#ifdef DARWIN
639  *base = pthread_get_stackaddr_np(p);
640  *size = pthread_get_stacksize_np(p);
641#endif
642#ifdef LINUX
643  pthread_attr_t attr;
644
645  pthread_getattr_np(p,&attr);
646  pthread_attr_getstack(&attr, base, size);
647  pthread_attr_destroy(&attr);
648  *(natural *)base += *size;
649#endif
650#ifdef FREEBSD
651  pthread_attr_t attr;
652  void * temp_base;
653  size_t temp_size;
654 
655
656  pthread_attr_init(&attr); 
657  pthread_attr_get_np(p, &attr);
658  pthread_attr_getstackaddr(&attr,&temp_base);
659  pthread_attr_getstacksize(&attr,&temp_size);
660  *base = (void *)((natural)temp_base + temp_size);
661  *size = temp_size;
662  pthread_attr_destroy(&attr);
663#endif
664#ifdef SOLARIS
665  stack_t st;
666 
667  thr_stksegment(&st);
668  *size = st.ss_size;
669  *base = st.ss_sp;
670 
671#endif
672}
673#endif
674
675void *
676new_semaphore(int count)
677{
678#ifdef USE_POSIX_SEMAPHORES
679  sem_t *s = malloc(sizeof(sem_t));
680  sem_init(s, 0, count);
681  return s;
682#endif
683#ifdef USE_MACH_SEMAPHORES
684  kern_return_t kret;
685  semaphore_t s = (semaphore_t)0;
686  kret = semaphore_create(mach_task_self(),&s, SYNC_POLICY_FIFO, count);
687  if (kret != KERN_SUCCESS) {
688    fatal_oserr("Can't create Mach semaphore.",(OSErr)kret);
689  }
690  return (void *)(natural)s;
691#endif
692#ifdef USE_WINDOWS_SEMAPHORES
693  return CreateSemaphore(NULL, count, 0x7fffL, NULL);
694#endif
695}
696
697RECURSIVE_LOCK
698new_recursive_lock()
699{
700  extern int cache_block_size;
701  void *p = calloc(1,sizeof(_recursive_lock)+cache_block_size-1);
702  RECURSIVE_LOCK m = NULL;
703#ifndef USE_FUTEX
704  void *signal = new_semaphore(0);
705#endif
706  if (p) {
707    m = (RECURSIVE_LOCK) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
708    m->malloced_ptr = p;
709  }
710
711#ifdef USE_FUTEX
712  if (m) {
713    return m;
714  }
715#else
716  if (m && signal) {
717    m->signal = signal;
718    return m;
719  }
720  if (m) {
721    free(p);
722  }
723  if (signal) {
724    destroy_semaphore(&signal);
725  }
726#endif
727  return NULL;
728}
729
730void
731destroy_semaphore(void **s)
732{
733  if (*s) {
734#ifdef USE_POSIX_SEMAPHORES
735    sem_destroy((sem_t *)*s);
736    free(*s);   
737#endif
738#ifdef USE_MACH_SEMAPHORES
739    semaphore_destroy(mach_task_self(),((semaphore_t)(natural) *s));
740#endif
741#ifdef USE_WINDOWS_SEMAPHORES
742    CloseHandle(*s);
743#endif
744    *s=NULL;
745  }
746}
747
748#ifdef WINDOWS
749void
750tsd_set(LispObj key, void *datum)
751{
752  TlsSetValue((DWORD)key, datum);
753}
754
755void *
756tsd_get(LispObj key)
757{
758  return TlsGetValue((DWORD)key);
759}
760#else
761void
762tsd_set(LispObj key, void *datum)
763{
764  pthread_setspecific((pthread_key_t)key, datum);
765}
766
767void *
768tsd_get(LispObj key)
769{
770  return pthread_getspecific((pthread_key_t)key);
771}
772#endif
773
774void
775dequeue_tcr(TCR *tcr)
776{
777  TCR *next, *prev;
778
779  next = TCR_AUX(tcr)->next;
780  prev = TCR_AUX(tcr)->prev;
781
782  TCR_AUX(prev)->next = next;
783  TCR_AUX(next)->prev = prev;
784  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = NULL;
785#ifdef X86
786  tcr->linear = NULL;
787#endif
788}
789 
790void
791enqueue_tcr(TCR *new)
792{
793  TCR *head, *tail;
794 
795  LOCK(lisp_global(TCR_AREA_LOCK),new);
796  head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR));
797  tail = TCR_AUX(head)->prev;
798  TCR_AUX(tail)->next = new;
799  TCR_AUX(head)->prev = new;
800  TCR_AUX(new)->prev = tail;
801  TCR_AUX(new)->next = head;
802  UNLOCK(lisp_global(TCR_AREA_LOCK),new);
803}
804
805#ifdef WIN_32
806TCR *
807allocate_tcr()
808{
809  void *p = calloc(1,sizeof(struct tcr_aux));
810  char *teb = (char *)NtCurrentTeb();
811  TCR *tcr = (TCR *)(teb + TCR_BIAS);
812
813  if (p == NULL)
814    allocation_failure(true, sizeof(struct tcr_aux));
815
816  if ((intptr_t)p & 03) {
817    fprintf(dbgout, "%p not aligned\n", p);
818    exit(1);
819  }
820  memset(tcr, 0, sizeof(TCR));
821  tcr->aux = p;
822  return tcr;
823}
824#else
825TCR *
826allocate_tcr()
827{
828  TCR *tcr, *chain = NULL, *next;
829#ifdef DARWIN
830  extern Boolean use_mach_exception_handling;
831#ifdef DARWIN64
832  extern TCR* darwin_allocate_tcr(void);
833  extern void darwin_free_tcr(TCR *);
834#endif
835  kern_return_t kret;
836  mach_port_t
837    thread_exception_port,
838    task_self = mach_task_self();
839#endif
840  for (;;) {
841#ifdef DARWIN64
842    tcr = darwin_allocate_tcr();
843    if (use_mach_exception_handling) {
844      thread_exception_port = (mach_port_t)((natural)tcr);
845      kret = mach_port_allocate_name(task_self,
846                                     MACH_PORT_RIGHT_RECEIVE,
847                                     thread_exception_port);
848    } else {
849      kret = KERN_SUCCESS;
850    }
851
852    if (kret != KERN_SUCCESS) {
853      tcr->next = chain;
854      chain = tcr;
855      continue;
856    }
857#else
858    tcr = calloc(1, sizeof(TCR));
859#endif
860    for (;chain;chain = next) {
861      next = chain->next;
862#ifdef DARWIN64
863      darwin_free_tcr(chain);
864#else
865      free(chain);
866#endif
867    }
868    return tcr;
869  }
870}
871#endif
872
873#ifdef X8664
874#ifdef LINUX
875#include <asm/prctl.h>
876#include <sys/prctl.h>
877#endif
878#ifdef FREEBSD
879#include <machine/sysarch.h>
880#endif
881
882void
883setup_tcr_extra_segment(TCR *tcr)
884{
885#ifdef FREEBSD
886  amd64_set_gsbase(tcr);
887#endif
888#ifdef LINUX
889  arch_prctl(ARCH_SET_GS, (natural)tcr);
890#endif
891#ifdef DARWIN
892  /*
893   * There's apparently no way to do this.  We used to use a horrible
894   * and slow kludge conditionalized on DARWIN_GS_HACK (which involved
895   * sharing gs between lisp and pthreads), hoping that Apple would
896   * eventually provide a way to set fsbase.  We got tired of waiting,
897   * and have now resigned ourselves to keeping the TCR in a GPR.
898   */
899  /* darwin_set_x8664_fs_reg(tcr); */
900#endif
901#ifdef SOLARIS
902  /* Chris Curtis found this and suggested the use of syscall here */
903  syscall(SYS_lwp_private,_LWP_SETPRIVATE, _LWP_GSBASE, tcr);
904#endif
905}
906
907#endif
908
909#ifdef X8632
910
911#ifdef DARWIN
912#include <architecture/i386/table.h>
913#include <architecture/i386/sel.h>
914#include <i386/user_ldt.h>
915
916void setup_tcr_extra_segment(TCR *tcr)
917{
918    uintptr_t addr = (uintptr_t)tcr;
919    unsigned int size = sizeof(*tcr);
920    ldt_entry_t desc;
921    sel_t sel;
922    int i;
923
924    desc.data.limit00 = (size - 1) & 0xffff;
925    desc.data.limit16 = ((size - 1) >> 16) & 0xf;
926    desc.data.base00 = addr & 0xffff;
927    desc.data.base16 = (addr >> 16) & 0xff;
928    desc.data.base24 = (addr >> 24) & 0xff;
929    desc.data.type = DESC_DATA_WRITE;
930    desc.data.dpl = USER_PRIV;
931    desc.data.present = 1;
932    desc.data.stksz = DESC_CODE_32B;
933    desc.data.granular = DESC_GRAN_BYTE;
934   
935    i = i386_set_ldt(LDT_AUTO_ALLOC, &desc, 1);
936
937    if (i < 0) {
938        perror("i386_set_ldt");
939    } else {
940        sel.index = i;
941        sel.rpl = USER_PRIV;
942        sel.ti = SEL_LDT;
943        tcr->ldt_selector = sel;
944    }
945}
946
947void free_tcr_extra_segment(TCR *tcr)
948{
949  /* load %fs with null segement selector */
950  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
951  if (i386_set_ldt(tcr->ldt_selector.index, NULL, 1) < 0)
952    perror("i386_set_ldt");
953  tcr->ldt_selector = NULL_SEL;
954}
955#endif
956
957#ifdef LINUX
958
959#include <asm/ldt.h>
960#include <sys/syscall.h>
961
962/* see desc_struct in kernel/include/asm-i386/processor.h */
963typedef struct {
964  uint32_t a;
965  uint32_t b;
966} linux_desc_struct;
967
968
969#define desc_avail(d) (((d)->a) == 0)
970
971linux_desc_struct linux_ldt_entries[LDT_ENTRIES];
972
973/* We have to ask the Linux kernel for a copy of the ldt table
974   and manage it ourselves.  It's not clear that this is
975   thread-safe in general, but we can at least ensure that
976   it's thread-safe wrt lisp threads. */
977
978pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
979
980int
981modify_ldt(int func, void *ptr, unsigned long bytecount)
982{
983  return syscall(__NR_modify_ldt, func, ptr, bytecount);
984}
985
986
987void
988setup_tcr_extra_segment(TCR *tcr)
989{
990  int i, n;
991  short sel;
992  struct user_desc u = {1, 0, 0, 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1};
993  linux_desc_struct *d = linux_ldt_entries;
994
995  pthread_mutex_lock(&ldt_lock);
996  n = modify_ldt(0,d,LDT_ENTRIES*LDT_ENTRY_SIZE)/LDT_ENTRY_SIZE;
997  for (i = 0; i < n; i++,d++) {
998    if (desc_avail(d)) {
999      break;
1000    }
1001  }
1002  if (i == LDT_ENTRIES) {
1003    pthread_mutex_unlock(&ldt_lock);
1004    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
1005    _exit(1);
1006  }
1007  u.entry_number = i;
1008  u.base_addr = (uint32_t)tcr;
1009  u.limit = sizeof(TCR);
1010  u.limit_in_pages = 0;
1011  if (modify_ldt(1,&u,sizeof(struct user_desc)) != 0) {
1012    pthread_mutex_unlock(&ldt_lock);
1013    fprintf(dbgout,"Can't assign LDT entry\n");
1014    _exit(1);
1015  }
1016  sel = (i << 3) | 7;
1017  tcr->ldt_selector = sel;
1018  pthread_mutex_unlock(&ldt_lock);
1019}
1020
1021void
1022free_tcr_extra_segment(TCR *tcr)
1023{
1024  struct user_desc u = {0, 0, 0, 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0};
1025  short sel = tcr->ldt_selector;
1026
1027  pthread_mutex_lock(&ldt_lock);
1028  /* load %fs with null segment selector */
1029  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1030  tcr->ldt_selector = 0;
1031  u.entry_number = (sel>>3);
1032  modify_ldt(1,&u,sizeof(struct user_desc));
1033  pthread_mutex_unlock(&ldt_lock);
1034 
1035}
1036
1037#endif
1038
1039#ifdef WINDOWS
1040bitvector ldt_entries_in_use = NULL;
1041HANDLE ldt_lock;
1042
1043typedef struct {
1044  DWORD offset;
1045  DWORD size;
1046  LDT_ENTRY entry;
1047} win32_ldt_info;
1048
1049
1050int WINAPI (*NtQueryInformationProcess)(HANDLE,DWORD,VOID*,DWORD,DWORD*);
1051int WINAPI (*NtSetInformationProcess)(HANDLE,DWORD,VOID*,DWORD);
1052
1053void
1054init_win32_ldt()
1055{
1056  HANDLE hNtdll;
1057  int status = 0xc0000002;
1058  win32_ldt_info info;
1059  DWORD nret;
1060 
1061
1062  ldt_entries_in_use=malloc(8192/8);
1063  zero_bits(ldt_entries_in_use,8192);
1064  ldt_lock = CreateMutex(NULL,0,NULL);
1065
1066  hNtdll = LoadLibrary("ntdll.dll");
1067  NtQueryInformationProcess = (void*)GetProcAddress(hNtdll, "NtQueryInformationProcess");
1068  NtSetInformationProcess = (void*)GetProcAddress(hNtdll, "NtSetInformationProcess");
1069  if (NtQueryInformationProcess != NULL) {
1070    info.offset = 0;
1071    info.size = sizeof(LDT_ENTRY);
1072    status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1073  }
1074
1075  if (status) {
1076    fprintf(dbgout, "This application can't run under this OS version\n");
1077    _exit(1);
1078  }
1079}
1080
1081void
1082setup_tcr_extra_segment(TCR *tcr)
1083{
1084}
1085
1086void 
1087free_tcr_extra_segment(TCR *tcr)
1088{
1089}
1090
1091#endif
1092#ifdef FREEBSD
1093#include <machine/segments.h>
1094#include <machine/sysarch.h>
1095
1096/* It'd be tempting to use i386_set_fsbase() here, but there doesn't
1097   seem to be any way to free the GDT entry it creates.  Actually,
1098   it's not clear that that really sets a GDT entry; let's see */
1099
1100#define FREEBSD_USE_SET_FSBASE 1
1101void
1102setup_tcr_extra_segment(TCR *tcr)
1103{
1104#if !FREEBSD_USE_SET_FSBASE
1105  struct segment_descriptor sd;
1106  uintptr_t addr = (uintptr_t)tcr;
1107  unsigned int size = sizeof(*tcr);
1108  int i;
1109
1110  sd.sd_lolimit = (size - 1) & 0xffff;
1111  sd.sd_hilimit = ((size - 1) >> 16) & 0xf;
1112  sd.sd_lobase = addr & ((1<<24)-1);
1113  sd.sd_hibase = (addr>>24)&0xff;
1114
1115
1116
1117  sd.sd_type = 18;
1118  sd.sd_dpl = SEL_UPL;
1119  sd.sd_p = 1;
1120  sd.sd_def32 = 1;
1121  sd.sd_gran = 0;
1122
1123  i = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor *)&sd, 1);
1124
1125  if (i < 0) {
1126    perror("i386_set_ldt");
1127    exit(1);
1128  } else {
1129    tcr->ldt_selector = LSEL(i,SEL_UPL);
1130  }
1131#else
1132  extern unsigned short get_fs_register(void);
1133
1134  if (i386_set_fsbase((void*)tcr)) {
1135    perror("i386_set_fsbase");
1136    exit(1);
1137  }
1138
1139
1140  /* Once we've called i386_set_fsbase, we can't write to %fs. */
1141  tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL);
1142#endif
1143}
1144
1145void 
1146free_tcr_extra_segment(TCR *tcr)
1147{
1148#if FREEBSD_USE_SET_FSBASE
1149  /* On a 32-bit kernel, this allocates a GDT entry.  It's not clear
1150     what it would mean to deallocate that entry. */
1151  /* If we're running on a 64-bit kernel, we can't write to %fs */
1152#else
1153  int idx = tcr->ldt_selector >> 3;
1154  /* load %fs with null segment selector */
1155  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1156  if (i386_set_ldt(idx, NULL, 1) < 0)
1157    perror("i386_set_ldt");
1158#endif
1159  tcr->ldt_selector = 0;
1160}
1161#endif
1162
1163#ifdef SOLARIS
1164#include <sys/sysi86.h>
1165
1166bitvector ldt_entries_in_use = NULL;
1167pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
1168
1169void
1170solaris_ldt_init()
1171{
1172  int fd;
1173  struct ssd s;
1174
1175  ldt_entries_in_use=malloc(8192/8);
1176  zero_bits(ldt_entries_in_use,8192);
1177 
1178  fd = open("/proc/self/ldt", O_RDONLY);
1179
1180  while(read(fd,&s,sizeof(s)) == sizeof(s)) {
1181    set_bit(ldt_entries_in_use,s.sel>>3);
1182  }
1183  close(fd);
1184}
1185   
1186
1187void
1188setup_tcr_extra_segment(TCR *tcr)
1189{
1190  struct ssd s;
1191  int i;
1192
1193  pthread_mutex_lock(&ldt_lock);
1194
1195  for (i = 0; i < 8192; i++) {
1196    if (!ref_bit(ldt_entries_in_use,i)) {
1197      s.sel = (i<<3)|7;
1198      s.bo = (unsigned int)tcr;
1199      s.ls = sizeof(TCR);
1200      s.acc1 = 0xf2;
1201      s.acc2 = 4;
1202
1203      if (sysi86(SI86DSCR, &s) >= 0) {
1204        set_bit(ldt_entries_in_use,i);
1205        tcr->ldt_selector = (i<<3)|7;
1206        pthread_mutex_unlock(&ldt_lock);
1207        return;
1208      }
1209      set_bit(ldt_entries_in_use,i);
1210    }
1211  }
1212  pthread_mutex_unlock(&ldt_lock);
1213  fprintf(dbgout, "All 8192 LDT descriptors in use\n");
1214  _exit(1);
1215
1216
1217 
1218}
1219
1220void 
1221free_tcr_extra_segment(TCR *tcr)
1222{
1223  struct ssd s;
1224  int i;
1225
1226  pthread_mutex_lock(&ldt_lock);
1227  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1228  s.sel = tcr->ldt_selector;
1229  i = s.sel>>3;
1230  tcr->ldt_selector = 0;
1231  s.bo = 0;
1232  s.ls = 0;
1233  s.acc1 = 0;
1234  s.acc2 = 0;
1235  sysi86(SI86DSCR, &s);
1236  clr_bit(ldt_entries_in_use,i);
1237  pthread_mutex_unlock(&ldt_lock);
1238}
1239
1240#endif
1241#endif
1242
1243#ifdef ARM
1244extern int arm_architecture_version;
1245
1246void
1247init_arm_tcr_sptab(TCR *tcr)
1248{
1249  extern LispObj *sptab;
1250  extern LispObj *sptab_end;
1251  LispObj *p, *q;
1252
1253  for (p=sptab,q = tcr->sptab;
1254       p<sptab_end;
1255       p++,q++) {
1256    *q = *p;
1257  }
1258}
1259#endif       
1260 
1261 
1262
1263
1264/*
1265  Caller must hold the area_lock.
1266*/
1267TCR *
1268new_tcr(natural vstack_size, natural tstack_size)
1269{
1270  extern area
1271    *allocate_vstack_holding_area_lock(natural),
1272    *allocate_tstack_holding_area_lock(natural);
1273  area *a;
1274  int i;
1275#ifndef WINDOWS
1276  sigset_t sigmask;
1277
1278  sigemptyset(&sigmask);
1279  pthread_sigmask(SIG_SETMASK,&sigmask, NULL);
1280#endif
1281
1282#ifdef HAVE_TLS
1283  TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15));
1284  current_tcr = tcr;
1285#else /* no TLS */
1286  TCR *tcr = allocate_tcr();
1287#endif
1288
1289#ifdef ARM
1290  init_arm_tcr_sptab(tcr);
1291  tcr->architecture_version = (arm_architecture_version-ARM_ARCHITECTURE_v7) << fixnumshift;
1292#endif
1293#ifdef X86
1294  setup_tcr_extra_segment(tcr);
1295  tcr->linear = tcr;
1296#ifdef X8632
1297  tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK;
1298#endif
1299#endif
1300
1301#if (WORD_SIZE == 64)
1302  tcr->single_float_convert.tag = subtag_single_float;
1303#endif
1304  TCR_AUX(tcr)->suspend = new_semaphore(0);
1305  TCR_AUX(tcr)->resume = new_semaphore(0);
1306  TCR_AUX(tcr)->reset_completion = new_semaphore(0);
1307  TCR_AUX(tcr)->activate = new_semaphore(0);
1308  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1309  a = allocate_vstack_holding_area_lock(vstack_size);
1310  tcr->vs_area = a;
1311  a->owner = tcr;
1312  tcr->save_vsp = (LispObj *) a->active; 
1313#ifndef ARM
1314  a = allocate_tstack_holding_area_lock(tstack_size);
1315#endif
1316  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1317#ifndef ARM
1318  tcr->ts_area = a;
1319  a->owner = tcr;
1320  tcr->save_tsp = (LispObj *) a->active;
1321#endif
1322#ifdef X86
1323  tcr->next_tsp = tcr->save_tsp;
1324#endif
1325
1326  tcr->valence = TCR_STATE_FOREIGN;
1327#ifdef PPC
1328  tcr->lisp_fpscr.words.l = 0xd0;
1329#endif
1330#ifdef X86
1331  tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | 
1332#if 1                           /* Mask underflow; too hard to
1333                                   deal with denorms if underflow is
1334                                   enabled */
1335    (1 << MXCSR_UM_BIT) | 
1336#endif
1337    (1 << MXCSR_PM_BIT);
1338#endif
1339#ifdef ARM
1340  tcr->lisp_fpscr = 
1341    (1 << FPSCR_IOE_BIT) | 
1342    (1 << FPSCR_DZE_BIT) |
1343    (1 << FPSCR_OFE_BIT);
1344#endif
1345  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
1346  tcr->tlb_limit = 2048<<fixnumshift;
1347  tcr->tlb_pointer = (LispObj *)malloc(tcr->tlb_limit);
1348  for (i = 0; i < 2048; i++) {
1349    tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker;
1350  }
1351  TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<<fixnum_shift);
1352#ifndef WINDOWS
1353  tcr->shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS;
1354#else
1355  TCR_AUX(tcr)->shutdown_count = 1;
1356#endif
1357  return tcr;
1358}
1359
1360void
1361shutdown_thread_tcr(void *arg)
1362{
1363#ifdef DARWIN64
1364  extern void darwin_free_tcr(TCR *);
1365#endif
1366  TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0);
1367
1368  area *vs, *ts, *cs;
1369#ifdef DARWIN
1370  mach_port_t kernel_thread;
1371#endif
1372 
1373  if (current == NULL) {
1374    current = tcr;
1375  }
1376
1377  if (--(TCR_AUX(tcr)->shutdown_count) == 0) {
1378    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
1379      LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1380        callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1381   
1382      tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1383      ((void (*)())ptr_from_lispobj(callback_ptr))(1);
1384      tsd_set(lisp_global(TCR_KEY), NULL);
1385    }
1386#ifdef DARWIN
1387    darwin_exception_cleanup(tcr);
1388    kernel_thread = (mach_port_t) (uint32_t)(natural)( TCR_AUX(tcr)->native_thread_id);
1389#endif
1390    LOCK(lisp_global(TCR_AREA_LOCK),current);
1391    vs = tcr->vs_area;
1392    tcr->vs_area = NULL;
1393#ifndef ARM
1394    ts = tcr->ts_area;
1395    tcr->ts_area = NULL;
1396#endif
1397    cs = TCR_AUX(tcr)->cs_area;
1398    TCR_AUX(tcr)->cs_area = NULL;
1399    if (vs) {
1400      condemn_area_holding_area_lock(vs);
1401    }
1402#ifndef ARM
1403    if (ts) {
1404      condemn_area_holding_area_lock(ts);
1405    }
1406#endif
1407    if (cs) {
1408      condemn_area_holding_area_lock(cs);
1409    }
1410    /* On some platforms - currently just linuxarm - we have to
1411       allocate a separate alternate signal stack (rather than just
1412       using a few pages of the thread's main stack.)  Disable and
1413       free that alternate stack here.
1414    */
1415#ifdef ARM
1416#if defined(LINUX)
1417    {
1418      stack_t new, current;
1419      new.ss_flags = SS_DISABLE;
1420      if (sigaltstack(&new, &current) == 0) {
1421        munmap(current.ss_sp, current.ss_size);
1422      }
1423    }
1424#endif
1425#endif
1426    destroy_semaphore(&TCR_AUX(tcr)->suspend);
1427    destroy_semaphore(&TCR_AUX(tcr)->resume);
1428    destroy_semaphore(&TCR_AUX(tcr)->reset_completion);
1429    destroy_semaphore(&TCR_AUX(tcr)->activate);
1430    tcr->tlb_limit = 0;
1431    free(tcr->tlb_pointer);
1432    tcr->tlb_pointer = NULL;
1433#ifdef WINDOWS
1434    if (TCR_AUX(tcr)->osid != 0) {
1435      CloseHandle((HANDLE)(TCR_AUX(tcr)->osid));
1436    }
1437#endif
1438    TCR_AUX(tcr)->osid = 0;
1439    tcr->interrupt_pending = 0;
1440    TCR_AUX(tcr)->termination_semaphore = NULL;
1441#if defined(HAVE_TLS) || defined(WIN_32) || defined(DARWIN64)
1442    dequeue_tcr(tcr);
1443#endif
1444#ifdef X8632
1445    free_tcr_extra_segment(tcr);
1446#endif
1447#ifdef WINDOWS
1448    CloseHandle((HANDLE)TCR_AUX(tcr)->io_datum);
1449    TCR_AUX(tcr)->io_datum = NULL;
1450    free(TCR_AUX(tcr)->native_thread_info);
1451    TCR_AUX(tcr)->native_thread_info = NULL;
1452#ifdef WIN_32
1453    free(tcr->aux);
1454    tcr->aux = NULL;
1455#endif
1456#endif
1457#ifdef DARWIN64
1458    darwin_free_tcr(tcr);
1459#endif
1460    UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1461#ifdef DARWIN
1462    {
1463      mach_port_urefs_t nrefs;
1464      ipc_space_t task = mach_task_self();
1465
1466      if (mach_port_get_refs(task,kernel_thread,MACH_PORT_RIGHT_SEND,&nrefs) == KERN_SUCCESS) {
1467        if (nrefs > 1) {
1468          mach_port_mod_refs(task,kernel_thread,MACH_PORT_RIGHT_SEND,-(nrefs-1));
1469        }
1470      }
1471    }
1472#endif
1473  } else {
1474    tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1475  }
1476}
1477
1478void
1479tcr_cleanup(void *arg)
1480{
1481  TCR *tcr = (TCR *)arg;
1482  area *a;
1483
1484  a = tcr->vs_area;
1485  if (a) {
1486    a->active = a->high;
1487  }
1488#ifndef ARM
1489  a = tcr->ts_area;
1490  if (a) {
1491    a->active = a->high;
1492  }
1493#endif
1494  a = TCR_AUX(tcr)->cs_area;
1495  if (a) {
1496    a->active = a->high;
1497  }
1498  tcr->valence = TCR_STATE_FOREIGN;
1499  TCR_AUX(tcr)->shutdown_count = 1;
1500  shutdown_thread_tcr(tcr);
1501  tsd_set(lisp_global(TCR_KEY), NULL);
1502}
1503
1504void *
1505current_native_thread_id()
1506{
1507  return ((void *) (natural)
1508#ifdef LINUX
1509#ifdef __NR_gettid
1510          syscall(__NR_gettid)
1511#else
1512          getpid()
1513#endif
1514#endif
1515#ifdef DARWIN
1516          pthread_mach_thread_np(pthread_self())
1517#endif
1518#ifdef FREEBSD
1519          pthread_self()
1520#endif
1521#ifdef SOLARIS
1522          pthread_self()
1523#endif
1524#ifdef WINDOWS
1525          GetCurrentThreadId()
1526#endif
1527          );
1528}
1529
1530
1531void
1532thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size)
1533{
1534  area *a, *register_cstack_holding_area_lock(BytePtr, natural);
1535
1536  TCR_AUX(tcr)->osid = current_thread_osid();
1537  TCR_AUX(tcr)->native_thread_id = current_native_thread_id();
1538  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1539  a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size);
1540  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1541  TCR_AUX(tcr)->cs_area = a;
1542  a->owner = tcr;
1543#ifdef ARM
1544  tcr->last_lisp_frame = (natural)(a->high);
1545#endif
1546  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
1547    TCR_AUX(tcr)->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1548  }
1549#ifdef LINUX
1550#ifdef PPC
1551#ifndef PPC64
1552  tcr->native_thread_info = current_r2;
1553#endif
1554#endif
1555#endif
1556  TCR_AUX(tcr)->errno_loc = (int *)(&errno);
1557  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1558#ifdef DARWIN
1559  extern Boolean use_mach_exception_handling;
1560  if (use_mach_exception_handling) {
1561    darwin_exception_init(tcr);
1562  }
1563#endif
1564#ifdef LINUX
1565  linux_exception_init(tcr);
1566#endif
1567#ifdef WINDOWS
1568  TCR_AUX(tcr)->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
1569  TCR_AUX(tcr)->native_thread_info = malloc(sizeof(CONTEXT));
1570#endif
1571  TCR_AUX(tcr)->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1572}
1573
1574/*
1575  Register the specified tcr as "belonging to" the current thread.
1576  Under Darwin, setup Mach exception handling for the thread.
1577  Install cleanup handlers for thread termination.
1578*/
1579void
1580register_thread_tcr(TCR *tcr)
1581{
1582  void *stack_base = NULL;
1583  natural stack_size = 0;
1584
1585  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1586  thread_init_tcr(tcr, stack_base, stack_size);
1587  enqueue_tcr(tcr);
1588}
1589
1590
1591 
1592 
1593
1594Ptr
1595create_stack(natural size)
1596{
1597  Ptr p;
1598  size=align_to_power_of_2(size, log2_page_size);
1599  p = (Ptr) MapMemoryForStack((size_t)size);
1600  if (p != (Ptr)(-1)) {
1601    *((size_t *)p) = size;
1602    return p;
1603  }
1604  allocation_failure(true, size);
1605  return NULL;
1606}
1607
1608void *
1609allocate_stack(natural size)
1610{
1611  return create_stack(size);
1612}
1613
1614void
1615free_stack(void *s)
1616{
1617  size_t size = *((size_t *)s);
1618  UnMapMemory(s, size);
1619}
1620
1621Boolean threads_initialized = false;
1622
1623#ifndef USE_FUTEX
1624#ifdef WINDOWS
1625void
1626count_cpus()
1627{
1628  SYSTEM_INFO si;
1629
1630  GetSystemInfo(&si);
1631  if (si.dwNumberOfProcessors > 1) {
1632    spin_lock_tries = 1024;
1633  }
1634}
1635#else
1636void
1637count_cpus()
1638{
1639  int n = sysconf(_SC_NPROCESSORS_CONF);
1640 
1641  if (n > 1) {
1642    spin_lock_tries = 1024;
1643  }
1644}
1645#endif
1646#endif
1647
1648void
1649init_threads(void * stack_base, TCR *tcr)
1650{
1651  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1652#ifdef WINDOWS
1653  lisp_global(TCR_KEY) = TlsAlloc();
1654  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1655  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
1656#else
1657  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1658  thread_signal_setup();
1659#endif
1660
1661#ifndef USE_FUTEX
1662  count_cpus();
1663#endif
1664  threads_initialized = true;
1665}
1666
1667
1668#ifdef WINDOWS
1669unsigned CALLBACK
1670#else
1671void *
1672#endif
1673lisp_thread_entry(void *param)
1674{
1675  thread_activation *activation = (thread_activation *)param;
1676  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1677  LispObj *start_vsp;
1678#ifndef WINDOWS
1679  sigset_t mask, old_mask;
1680
1681  sigemptyset(&mask);
1682  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1683#endif
1684
1685  register_thread_tcr(tcr);
1686
1687#ifndef WINDOWS
1688  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1689#endif
1690  tcr->vs_area->active -= node_size;
1691  *(--tcr->save_vsp) = lisp_nil;
1692  start_vsp = tcr->save_vsp;
1693  enable_fp_exceptions();
1694  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1695  activation->tcr = tcr;
1696  SEM_RAISE(activation->created);
1697  do {
1698    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1699    SEM_WAIT_FOREVER(TCR_AUX(tcr)->activate);
1700    /* Now go run some lisp code */
1701    start_lisp(TCR_TO_TSD(tcr),0);
1702    tcr->save_vsp = start_vsp;
1703  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1704#ifndef WINDOWS
1705  pthread_cleanup_pop(true);
1706#else
1707  tcr_cleanup(tcr);
1708#endif
1709#ifdef WINDOWS
1710  return 0;
1711#else
1712  return NULL;
1713#endif
1714}
1715
1716typedef 
1717short (*suspendf)();
1718
1719
1720void
1721suspend_current_cooperative_thread()
1722{
1723  static suspendf cooperative_suspend = NULL;
1724  void *xFindSymbol(void*,char*);
1725
1726  if (cooperative_suspend == NULL) {
1727    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
1728  }
1729  if (cooperative_suspend) {
1730    cooperative_suspend(1 /* kCurrentThreadID */,
1731                        1 /* kStoppedThreadState */,
1732                        0 /* kAnyThreadID */);
1733  }
1734}
1735
1736void *
1737cooperative_thread_startup(void *arg)
1738{
1739
1740  TCR *tcr = get_tcr(0);
1741  LispObj *start_vsp;
1742
1743  if (!tcr) {
1744    return NULL;
1745  }
1746#ifndef WINDOWS
1747  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1748#endif
1749  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1750  start_vsp = tcr->save_vsp;
1751  do {
1752    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1753    suspend_current_cooperative_thread();
1754     
1755    start_lisp(tcr, 0);
1756    tcr->save_vsp = start_vsp;
1757  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1758#ifndef WINDOWS
1759  pthread_cleanup_pop(true);
1760#else
1761  tcr_cleanup(tcr);
1762#endif
1763  return NULL;
1764}
1765
1766void *
1767xNewThread(natural control_stack_size,
1768           natural value_stack_size,
1769           natural temp_stack_size)
1770
1771{
1772  thread_activation activation;
1773
1774
1775  activation.tsize = temp_stack_size;
1776  activation.vsize = value_stack_size;
1777  activation.tcr = 0;
1778  activation.created = new_semaphore(0);
1779  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1780                           NULL, 
1781                           lisp_thread_entry,
1782                           (void *) &activation)) {
1783   
1784    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1785  }
1786  destroy_semaphore(&activation.created); 
1787
1788#ifdef USE_DTRACE
1789  if (CCL_CREATE_THREAD_ENABLED() && activation.tcr) {
1790    CCL_CREATE_THREAD(activation.tcr->osid);
1791  }
1792#endif
1793
1794  return TCR_TO_TSD(activation.tcr);
1795}
1796
1797Boolean
1798active_tcr_p(TCR *q)
1799{
1800  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1801 
1802  do {
1803    if (p == q) {
1804      return true;
1805    }
1806    p = TCR_AUX(p)->next;
1807  } while (p != head);
1808  return false;
1809}
1810
1811
1812OSErr
1813xDisposeThread(TCR *tcr)
1814{
1815  return 0;                     /* I don't think that this is ever called. */
1816}
1817
1818OSErr
1819xYieldToThread(TCR *target)
1820{
1821  Bug(NULL, "xYieldToThread ?");
1822  return 0;
1823}
1824 
1825OSErr
1826xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1827{
1828  Bug(NULL, "xThreadCurrentStackSpace ?");
1829  return 0;
1830}
1831
1832
1833#ifdef WINDOWS
1834Boolean
1835create_system_thread(size_t stack_size,
1836                     void* stackaddr,
1837                     unsigned CALLBACK (*start_routine)(void *),
1838                     void* param)
1839{
1840  HANDLE thread_handle;
1841  Boolean won = false;
1842
1843  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1844
1845  thread_handle = (HANDLE)_beginthreadex(NULL, 
1846                                         stack_size,
1847                                         start_routine,
1848                                         param,
1849                                         0, 
1850                                         NULL);
1851
1852  if (thread_handle == NULL) {
1853    wperror("CreateThread");
1854  } else {
1855    won = true;
1856    CloseHandle(thread_handle);
1857  }
1858  return won;
1859}
1860#else
1861Boolean
1862create_system_thread(size_t stack_size,  void *stackaddr,
1863                     void *(*start_routine)(void *), void *param)
1864{
1865  pthread_attr_t attr;
1866  pthread_t returned_thread;
1867  int err;
1868  TCR *current = get_tcr(true);
1869
1870  pthread_attr_init(&attr);
1871  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1872
1873  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1874    stack_size = PTHREAD_STACK_MIN;
1875  }
1876
1877  stack_size = ensure_stack_limit(stack_size);
1878  if (stackaddr != NULL) {
1879    /* Size must have been specified.  Sort of makes sense ... */
1880    pthread_attr_setstack(&attr, stackaddr, stack_size);
1881  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1882    pthread_attr_setstacksize(&attr,stack_size);
1883  }
1884
1885  /*
1886     I think that's just about enough ... create the thread.
1887     Well ... not quite enough.  In Leopard (at least), many
1888     pthread routines grab an internal spinlock when validating
1889     their arguments.  If we suspend a thread that owns this
1890     spinlock, we deadlock.  We can't in general keep that
1891     from happening: if arbitrary C code is suspended while
1892     it owns the spinlock, we still deadlock.  It seems that
1893     the best that we can do is to keep -this- code from
1894     getting suspended (by grabbing TCR_AREA_LOCK)
1895  */
1896  LOCK(lisp_global(TCR_AREA_LOCK),current);
1897  err = pthread_create(&returned_thread, &attr, start_routine, param);
1898  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1899  pthread_attr_destroy(&attr);
1900  return (err == 0);
1901}
1902#endif
1903
1904TCR *
1905get_tcr(Boolean create)
1906{
1907#ifdef HAVE_TLS
1908  TCR *current = current_tcr;
1909#elif defined(WIN_32)
1910  TCR *current = ((TCR *)((char *)NtCurrentTeb() + TCR_BIAS))->linear;
1911#else
1912  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1913  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1914#endif
1915
1916  if ((current == NULL) && create) {
1917    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1918      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1919    int i, nbindwords = 0;
1920    extern natural initial_stack_size;
1921   
1922    /* Make one. */
1923    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1924    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1925    register_thread_tcr(current);
1926#ifdef DEBUG_TCR_CREATION
1927#ifndef WINDOWS
1928    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
1929#endif
1930#endif
1931    current->vs_area->active -= node_size;
1932    *(--current->save_vsp) = lisp_nil;
1933#ifdef PPC
1934#define NSAVEREGS 8
1935#endif
1936#ifdef X8664
1937#define NSAVEREGS 4
1938#endif
1939#ifdef X8632
1940#define NSAVEREGS 0
1941#endif
1942#ifdef ARM
1943#define NSAVEREGS 0
1944#endif
1945    for (i = 0; i < NSAVEREGS; i++) {
1946      *(--current->save_vsp) = 0;
1947      current->vs_area->active -= node_size;
1948    }
1949    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1950    for (i = 0; i < nbindwords; i++) {
1951      *(--current->save_vsp) = 0;
1952      current->vs_area->active -= node_size;
1953    }
1954    TCR_AUX(current)->shutdown_count = 1;
1955    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1956
1957  }
1958 
1959  return current;
1960}
1961
1962#ifdef WINDOWS
1963void *
1964pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
1965{
1966  /* Thread has started to return from an exception. */
1967  if (where < restore_windows_context_iret) {
1968    /* In the process of restoring registers; context still in
1969       %rcx.  Just make our suspend_context be the context
1970       we're trying to restore, so that we'll resume from
1971       the suspend in the same context that we're trying to
1972       restore */
1973#ifdef WIN_64
1974    *pcontext = * (CONTEXT *)(pcontext->Rcx);
1975#else
1976    if (where == restore_windows_context_start) {
1977      *pcontext = * (CONTEXT *)((pcontext->Esp)+4);
1978    } else {
1979      *pcontext = * (CONTEXT *)(pcontext->Ecx);
1980    }
1981#endif
1982  } else {
1983    /* Most of the context has already been restored; fix %rcx
1984       if need be, then restore ss:rsp, cs:rip, and flags. */
1985#ifdef WIN_64
1986    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1987
1988    pcontext->Rip = iret_frame->Rip;
1989    pcontext->SegCs = (WORD) iret_frame->Cs;
1990    pcontext->EFlags = (DWORD) iret_frame->Rflags;
1991    pcontext->Rsp = iret_frame->Rsp;
1992    pcontext->SegSs = (WORD) iret_frame->Ss;
1993#else
1994    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
1995
1996    pcontext->Eip = iret_frame->Eip;
1997    pcontext->SegCs = (WORD) iret_frame->Cs;
1998    pcontext->EFlags = (DWORD) iret_frame->EFlags;
1999    pcontext->Esp += sizeof(ia32_iret_frame);
2000#endif
2001  }
2002  tcr->pending_exception_context = NULL;
2003  /* We basically never return from an exception unless we
2004     were executing lisp code when the exception returned.
2005     If that ever changes, we need to know what valence
2006     would have been restored here.*/
2007  tcr->valence = TCR_STATE_LISP;
2008}
2009
2010Boolean
2011suspend_tcr(TCR *tcr)
2012{
2013  int suspend_count = atomic_incf(&(TCR_AUX(tcr)->suspend_count));
2014  DWORD rc;
2015  if (suspend_count == 1) {
2016    CONTEXT  *pcontext = (CONTEXT *)TCR_AUX(tcr)->native_thread_info;
2017    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
2018    pc where;
2019    area *cs = TCR_AUX(tcr)->cs_area;
2020    LispObj foreign_rsp;
2021
2022    if (hthread == NULL) {
2023      return false;
2024    }
2025    rc = SuspendThread(hthread);
2026    if (rc == -1) {
2027      /* If the thread's simply dead, we should handle that here */
2028      return false;
2029    }
2030    pcontext->ContextFlags = CONTEXT_ALL;
2031    rc = GetThreadContext(hthread, pcontext);
2032    if (rc == 0) {
2033      return false;
2034    }
2035    where = (pc)(xpPC(pcontext));
2036
2037    if ((where >= restore_windows_context_start) &&
2038        (where < restore_windows_context_end) &&
2039        (tcr->valence != TCR_STATE_LISP)) {
2040#ifdef WIN_64
2041      tcr->valence = xpGPR(pcontext,REG_R8);
2042#else
2043      tcr->valence = ((LispObj *)(xpGPR(pcontext,Isp)))[3];
2044#endif
2045      pcontext = tcr->pending_exception_context;
2046      tcr->pending_exception_context = NULL; 
2047      where = (pc)(xpPC(pcontext));
2048    }
2049    if (tcr->valence == TCR_STATE_LISP) {
2050      if ((where >= restore_windows_context_start) &&
2051          (where < restore_windows_context_end)) {
2052        pc_luser_restore_windows_context(pcontext, tcr, where);
2053      } else {
2054        area *ts = tcr->ts_area;
2055        /* If we're in the lisp heap, or in x86-spentry??.o, or in
2056           x86-subprims??.o, or in the subprims jump table at #x15000,
2057           or on the tstack ... we're just executing lisp code.  Otherwise,
2058           we got an exception while executing lisp code, but haven't
2059           entered the handler yet (still in Windows exception glue
2060           or switching stacks or something.)  In the latter case, we
2061           basically want to get to he handler and have it notice
2062           the pending exception request, and suspend the thread at that
2063           point. */
2064        if (!((where < (pc)lisp_global(HEAP_END)) &&
2065              (where >= (pc)lisp_global(HEAP_START))) &&
2066            (!((where < (pc)(managed_static_area->active)) &&
2067              (where >= (pc)(readonly_area->low)))) &&
2068            !((where < spentry_end) && (where >= spentry_start)) &&
2069            !((where < subprims_end) && (where >= subprims_start)) &&
2070            !((where < (pc) 0x16000) &&
2071              (where >= (pc) 0x15000)) &&
2072            !((where < (pc) (ts->high)) &&
2073              (where >= (pc) (ts->low)))) {
2074          /* The thread has lisp valence, but is not executing code
2075             where we expect lisp code to be and is not exiting from
2076             an exception handler.  That pretty much means that it's
2077             on its way into an exception handler; we have to handshake
2078             until it enters an exception-wait state. */
2079          /* There are likely race conditions here */
2080          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2081          ResumeThread(hthread);
2082          SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2083          pcontext = NULL;
2084        }
2085      }
2086    }
2087    /* If we're really running lisp code, there's some reason to
2088       suspect that Windows is lying about that; the thread may have
2089       already committed to processing an exception and just not have
2090       reentered user mode.  If there's a way to determine that more
2091       reliably, I don't know what it is.  We can catch some cases of
2092       that by looking at whether the PC is at a UUO or other
2093       "intentional" illegal instruction and letting the thread enter
2094       exception handling, treating this case just like the case
2095       above. 
2096
2097       When people say that Windows sucks, they aren't always just
2098       talking about all of the other ways that it sucks.
2099    */
2100    if ((*where == INTN_OPCODE) ||
2101        ((*where == XUUO_OPCODE_0) && (where[1] == XUUO_OPCODE_1))) {
2102      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2103      ResumeThread(hthread);
2104      SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2105      pcontext = NULL;
2106    }
2107    TCR_AUX(tcr)->suspend_context = pcontext;
2108    return true;
2109  }
2110  return false;
2111}
2112#else
2113Boolean
2114suspend_tcr(TCR *tcr)
2115{
2116  int suspend_count = atomic_incf(&(tcr->suspend_count));
2117  pthread_t thread;
2118  if (suspend_count == 1) {
2119    thread = (pthread_t)(tcr->osid);
2120    if ((thread != (pthread_t) 0) &&
2121        (pthread_kill(thread, thread_suspend_signal) == 0)) {
2122      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2123    } else {
2124      /* A problem using pthread_kill.  On Darwin, this can happen
2125         if the thread has had its signal mask surgically removed
2126         by pthread_exit.  If the native (Mach) thread can be suspended,
2127         do that and return true; otherwise, flag the tcr as belonging
2128         to a dead thread by setting tcr->osid to 0.
2129      */
2130      tcr->osid = 0;
2131      return false;
2132    }
2133    return true;
2134  }
2135  return false;
2136}
2137#endif
2138
2139#ifdef WINDOWS
2140Boolean
2141tcr_suspend_ack(TCR *tcr)
2142{
2143  return true;
2144}
2145#else
2146Boolean
2147tcr_suspend_ack(TCR *tcr)
2148{
2149  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
2150    SEM_WAIT_FOREVER(tcr->suspend);
2151    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2152  }
2153  return true;
2154}
2155#endif
2156     
2157
2158Boolean
2159kill_tcr(TCR *tcr)
2160{
2161  TCR *current = get_tcr(true);
2162  Boolean result = false;
2163
2164  LOCK(lisp_global(TCR_AREA_LOCK),current);
2165  {
2166    LispObj osid = TCR_AUX(tcr)->osid;
2167   
2168    if (osid) {
2169      result = true;
2170#ifdef WINDOWS
2171      /* What we really want to do here is (something like)
2172         forcing the thread to run quit_handler().  For now,
2173         mark the TCR as dead and kill the Windows thread. */
2174      /* xxx TerminateThread() bad */
2175      TCR_AUX(tcr)->osid = 0;
2176      if (!TerminateThread((HANDLE)osid, 0)) {
2177        CloseHandle((HANDLE)osid);
2178        result = false;
2179      } else {
2180        CloseHandle((HANDLE)osid);
2181        shutdown_thread_tcr(tcr);
2182      }
2183#else
2184      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2185        result = false;
2186      }
2187#endif
2188    }
2189  }
2190  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2191  return result;
2192}
2193
2194Boolean
2195lisp_suspend_tcr(TCR *tcr)
2196{
2197  Boolean suspended;
2198  TCR *current = get_tcr(true);
2199 
2200  LOCK(lisp_global(TCR_AREA_LOCK),current);
2201  suspended = suspend_tcr(tcr);
2202  if (suspended) {
2203    while (!tcr_suspend_ack(tcr));
2204  }
2205  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2206  return suspended;
2207}
2208         
2209#ifdef WINDOWS
2210Boolean
2211resume_tcr(TCR *tcr)
2212{
2213  int suspend_count = atomic_decf(&(TCR_AUX(tcr)->suspend_count)), err;
2214  DWORD rc;
2215  if (suspend_count == 0) {
2216    CONTEXT *context = TCR_AUX(tcr)->suspend_context;
2217    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
2218
2219
2220    TCR_AUX(tcr)->suspend_context = NULL;
2221    if (context) {
2222      if (tcr->valence == TCR_STATE_LISP) {
2223        rc = SetThreadContext(hthread,context);
2224        if (! rc) {
2225          Bug(NULL,"SetThreadContext");
2226          return false;
2227        }
2228      }
2229      rc = ResumeThread(hthread);
2230      if (rc == -1) {
2231        Bug(NULL,"ResumeThread");
2232        return false;
2233      }
2234      return true;
2235    } else {
2236      SEM_RAISE(TCR_AUX(tcr)->resume);
2237      return true;
2238    }
2239  }
2240  return false;
2241}   
2242#else
2243Boolean
2244resume_tcr(TCR *tcr)
2245{
2246  int suspend_count = atomic_decf(&(tcr->suspend_count));
2247  if (suspend_count == 0) {
2248    void *s = (tcr->resume);
2249    if (s != NULL) {
2250      SEM_RAISE(s);
2251      return true;
2252    }
2253  }
2254  return false;
2255}
2256#endif
2257
2258   
2259
2260
2261Boolean
2262lisp_resume_tcr(TCR *tcr)
2263{
2264  Boolean resumed;
2265  TCR *current = get_tcr(true);
2266 
2267  LOCK(lisp_global(TCR_AREA_LOCK),current);
2268  resumed = resume_tcr(tcr);
2269  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2270  return resumed;
2271}
2272
2273
2274TCR *freed_tcrs = NULL;
2275
2276void
2277enqueue_freed_tcr (TCR *tcr)
2278{
2279#ifndef HAVE_TLS
2280  TCR_AUX(tcr)->next = freed_tcrs;
2281  freed_tcrs = tcr;
2282#endif
2283}
2284
2285/* It's not clear that we can safely condemn a dead tcr's areas, since
2286   we may not be able to call free() if a suspended thread owns a
2287   malloc lock. At least make the areas appear to be empty.
2288*/
2289   
2290
2291void
2292normalize_dead_tcr_areas(TCR *tcr)
2293{
2294  area *a;
2295
2296  a = tcr->vs_area;
2297  if (a) {
2298    a->active = a->high;
2299  }
2300
2301#ifndef ARM
2302  a = tcr->ts_area;
2303  if (a) {
2304    a->active = a->high;
2305  }
2306#endif
2307
2308  a = TCR_AUX(tcr)->cs_area;
2309  if (a) {
2310    a->active = a->high;
2311  }
2312}
2313   
2314void
2315free_freed_tcrs ()
2316{
2317#ifdef DARWIN64
2318  extern void darwin_free_tcr(TCR *);
2319#endif
2320  TCR *current, *next;
2321
2322  for (current = freed_tcrs; current; current = next) {
2323    next = TCR_AUX(current)->next;
2324#ifndef HAVE_TLS
2325#ifdef WIN_32
2326    /* We sort of have TLS in that the TEB is per-thread.  We free the
2327     * tcr aux vector elsewhere. */
2328#else
2329#ifdef DARWIN64
2330    darwin_free_tcr(current);
2331#else
2332    free(current);
2333#endif
2334#endif
2335#endif
2336  }
2337  freed_tcrs = NULL;
2338}
2339
2340void
2341suspend_other_threads(Boolean for_gc)
2342{
2343  TCR *current = get_tcr(true), *other, *next;
2344  int dead_tcr_count = 0;
2345  Boolean all_acked;
2346
2347  LOCK(lisp_global(TCR_AREA_LOCK), current);
2348  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2349    if ((TCR_AUX(other)->osid != 0)) {
2350      suspend_tcr(other);
2351      if (TCR_AUX(other)->osid == 0) {
2352        dead_tcr_count++;
2353      }
2354    } else {
2355      dead_tcr_count++;
2356    }
2357  }
2358
2359  do {
2360    all_acked = true;
2361    for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2362      if ((TCR_AUX(other)->osid != 0)) {
2363        if (!tcr_suspend_ack(other)) {
2364          all_acked = false;
2365        }
2366      }
2367    }
2368  } while(! all_acked);
2369
2370     
2371
2372  /* All other threads are suspended; can safely delete dead tcrs now */
2373  if (dead_tcr_count) {
2374    for (other = TCR_AUX(current)->next; other != current; other = next) {
2375      next = TCR_AUX(other)->next;
2376      if (TCR_AUX(other)->osid == 0)  {
2377        normalize_dead_tcr_areas(other);
2378        dequeue_tcr(other);
2379        enqueue_freed_tcr(other);
2380      }
2381    }
2382  }
2383}
2384
2385void
2386lisp_suspend_other_threads()
2387{
2388  suspend_other_threads(false);
2389}
2390
2391void
2392resume_other_threads(Boolean for_gc)
2393{
2394  TCR *current = get_tcr(true), *other;
2395
2396  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2397    if ((TCR_AUX(other)->osid != 0)) {
2398      resume_tcr(other);
2399    }
2400  }
2401  free_freed_tcrs();
2402  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2403}
2404
2405void
2406lisp_resume_other_threads()
2407{
2408  resume_other_threads(false);
2409}
2410
2411
2412
2413rwlock *
2414rwlock_new()
2415{
2416  extern int cache_block_size;
2417
2418  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2419  rwlock *rw = NULL;;
2420 
2421  if (p) {
2422    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2423    rw->malloced_ptr = p;
2424#ifndef USE_FUTEX
2425    rw->reader_signal = new_semaphore(0);
2426    rw->writer_signal = new_semaphore(0);
2427    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2428      if (rw->reader_signal) {
2429        destroy_semaphore(&(rw->reader_signal));
2430      } else {
2431        destroy_semaphore(&(rw->writer_signal));
2432      }
2433      free(rw);
2434      rw = NULL;
2435    }
2436#endif
2437  }
2438  return rw;
2439}
2440
2441     
2442/*
2443  Try to get read access to a multiple-readers/single-writer lock.  If
2444  we already have read access, return success (indicating that the
2445  lock is held another time.  If we already have write access to the
2446  lock ... that won't work; return EDEADLK.  Wait until no other
2447  thread has or is waiting for write access, then indicate that we
2448  hold read access once.
2449*/
2450#ifndef USE_FUTEX
2451int
2452rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2453{
2454  int err = 0;
2455 
2456  LOCK_SPINLOCK(rw->spin, tcr);
2457
2458  if (rw->writer == tcr) {
2459    RELEASE_SPINLOCK(rw->spin);
2460    return EDEADLK;
2461  }
2462
2463  while (rw->blocked_writers || (rw->state > 0)) {
2464    rw->blocked_readers++;
2465    RELEASE_SPINLOCK(rw->spin);
2466    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2467    LOCK_SPINLOCK(rw->spin,tcr);
2468    rw->blocked_readers--;
2469    if (err == EINTR) {
2470      err = 0;
2471    }
2472    if (err) {
2473      RELEASE_SPINLOCK(rw->spin);
2474      return err;
2475    }
2476  }
2477  rw->state--;
2478  RELEASE_SPINLOCK(rw->spin);
2479  return err;
2480}
2481#else
2482int
2483rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2484{
2485  natural waitval;
2486
2487  lock_futex(&rw->spin);
2488
2489  if (rw->writer == tcr) {
2490    unlock_futex(&rw->spin);
2491    return EDEADLOCK;
2492  }
2493  while (1) {
2494    if (rw->writer == NULL) {
2495      --rw->state;
2496      unlock_futex(&rw->spin);
2497      return 0;
2498    }
2499    rw->blocked_readers++;
2500    waitval = rw->reader_signal;
2501    unlock_futex(&rw->spin);
2502    futex_wait(&rw->reader_signal,waitval);
2503    lock_futex(&rw->spin);
2504    rw->blocked_readers--;
2505  }
2506  return 0;
2507}
2508#endif   
2509
2510
2511/*
2512  Try to obtain write access to the lock.
2513  It is an error if we already have read access, but it's hard to
2514  detect that.
2515  If we already have write access, increment the count that indicates
2516  that.
2517  Otherwise, wait until the lock is not held for reading or writing,
2518  then assert write access.
2519*/
2520
2521#ifndef USE_FUTEX
2522int
2523rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2524{
2525  int err = 0;
2526
2527  LOCK_SPINLOCK(rw->spin,tcr);
2528  if (rw->writer == tcr) {
2529    rw->state++;
2530    RELEASE_SPINLOCK(rw->spin);
2531    return 0;
2532  }
2533
2534  while (rw->state != 0) {
2535    rw->blocked_writers++;
2536    RELEASE_SPINLOCK(rw->spin);
2537    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2538    LOCK_SPINLOCK(rw->spin,tcr);
2539    rw->blocked_writers--;
2540    if (err == EINTR) {
2541      err = 0;
2542    }
2543    if (err) {
2544      RELEASE_SPINLOCK(rw->spin);
2545      return err;
2546    }
2547  }
2548  rw->state = 1;
2549  rw->writer = tcr;
2550  RELEASE_SPINLOCK(rw->spin);
2551  return err;
2552}
2553
2554#else
2555int
2556rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2557{
2558  int err = 0;
2559  natural waitval;
2560
2561  lock_futex(&rw->spin);
2562  if (rw->writer == tcr) {
2563    rw->state++;
2564    unlock_futex(&rw->spin);
2565    return 0;
2566  }
2567
2568  while (rw->state != 0) {
2569    rw->blocked_writers++;
2570    waitval = rw->writer_signal;
2571    unlock_futex(&rw->spin);
2572    futex_wait(&rw->writer_signal,waitval);
2573    lock_futex(&rw->spin);
2574    rw->blocked_writers--;
2575  }
2576  rw->state = 1;
2577  rw->writer = tcr;
2578  unlock_futex(&rw->spin);
2579  return err;
2580}
2581#endif
2582
2583/*
2584  Sort of the same as above, only return EBUSY if we'd have to wait.
2585*/
2586#ifndef USE_FUTEX
2587int
2588rwlock_try_wlock(rwlock *rw, TCR *tcr)
2589{
2590  int ret = EBUSY;
2591
2592  LOCK_SPINLOCK(rw->spin,tcr);
2593  if (rw->writer == tcr) {
2594    rw->state++;
2595    ret = 0;
2596  } else {
2597    if (rw->state == 0) {
2598      rw->writer = tcr;
2599      rw->state = 1;
2600      ret = 0;
2601    }
2602  }
2603  RELEASE_SPINLOCK(rw->spin);
2604  return ret;
2605}
2606#else
2607int
2608rwlock_try_wlock(rwlock *rw, TCR *tcr)
2609{
2610  int ret = EBUSY;
2611
2612  lock_futex(&rw->spin);
2613  if (rw->writer == tcr) {
2614    rw->state++;
2615    ret = 0;
2616  } else {
2617    if (rw->state == 0) {
2618      rw->writer = tcr;
2619      rw->state = 1;
2620      ret = 0;
2621    }
2622  }
2623  unlock_futex(&rw->spin);
2624  return ret;
2625}
2626#endif
2627
2628#ifndef USE_FUTEX
2629int
2630rwlock_try_rlock(rwlock *rw, TCR *tcr)
2631{
2632  int ret = EBUSY;
2633
2634  LOCK_SPINLOCK(rw->spin,tcr);
2635  if (rw->state <= 0) {
2636    --rw->state;
2637    ret = 0;
2638  }
2639  RELEASE_SPINLOCK(rw->spin);
2640  return ret;
2641}
2642#else
2643int
2644rwlock_try_rlock(rwlock *rw, TCR *tcr)
2645{
2646  int ret = EBUSY;
2647
2648  lock_futex(&rw->spin);
2649  if (rw->state <= 0) {
2650    --rw->state;
2651    ret = 0;
2652  }
2653  unlock_futex(&rw->spin);
2654  return ret;
2655}
2656#endif
2657
2658
2659
2660#ifndef USE_FUTEX
2661int
2662rwlock_unlock(rwlock *rw, TCR *tcr)
2663{
2664
2665  int err = 0;
2666  natural blocked_readers = 0;
2667
2668  LOCK_SPINLOCK(rw->spin,tcr);
2669  if (rw->state > 0) {
2670    if (rw->writer != tcr) {
2671      err = EINVAL;
2672    } else {
2673      --rw->state;
2674      if (rw->state == 0) {
2675        rw->writer = NULL;
2676      }
2677    }
2678  } else {
2679    if (rw->state < 0) {
2680      ++rw->state;
2681    } else {
2682      err = EINVAL;
2683    }
2684  }
2685  if (err) {
2686    RELEASE_SPINLOCK(rw->spin);
2687    return err;
2688  }
2689 
2690  if (rw->state == 0) {
2691    if (rw->blocked_writers) {
2692      SEM_RAISE(rw->writer_signal);
2693    } else {
2694      blocked_readers = rw->blocked_readers;
2695      if (blocked_readers) {
2696        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2697      }
2698    }
2699  }
2700  RELEASE_SPINLOCK(rw->spin);
2701  return 0;
2702}
2703#else
2704int
2705rwlock_unlock(rwlock *rw, TCR *tcr)
2706{
2707
2708  int err = 0;
2709
2710  lock_futex(&rw->spin);
2711  if (rw->state > 0) {
2712    if (rw->writer != tcr) {
2713      err = EINVAL;
2714    } else {
2715      --rw->state;
2716      if (rw->state == 0) {
2717        rw->writer = NULL;
2718      }
2719    }
2720  } else {
2721    if (rw->state < 0) {
2722      ++rw->state;
2723    } else {
2724      err = EINVAL;
2725    }
2726  }
2727  if (err) {
2728    unlock_futex(&rw->spin);
2729    return err;
2730  }
2731 
2732  if (rw->state == 0) {
2733    if (rw->blocked_writers) {
2734      ++rw->writer_signal;
2735      unlock_futex(&rw->spin);
2736      futex_wake(&rw->writer_signal,1);
2737      return 0;
2738    }
2739    if (rw->blocked_readers) {
2740      ++rw->reader_signal;
2741      unlock_futex(&rw->spin);
2742      futex_wake(&rw->reader_signal, INT_MAX);
2743      return 0;
2744    }
2745  }
2746  unlock_futex(&rw->spin);
2747  return 0;
2748}
2749#endif
2750
2751       
2752void
2753rwlock_destroy(rwlock *rw)
2754{
2755#ifndef USE_FUTEX
2756  destroy_semaphore((void **)&rw->reader_signal);
2757  destroy_semaphore((void **)&rw->writer_signal);
2758#endif
2759  free((void *)(rw->malloced_ptr));
2760}
2761
2762
2763
2764#ifdef DARWIN
2765/* For debugging. */
2766int
2767mach_port_send_refs(mach_port_t port)
2768{
2769  mach_port_urefs_t nrefs;
2770  ipc_space_t task = mach_task_self();
2771 
2772  if (mach_port_get_refs(task,port,MACH_PORT_RIGHT_SEND,&nrefs) == KERN_SUCCESS) {
2773    return nrefs;
2774  }
2775  return -1;
2776}
2777#endif
2778
Note: See TracBrowser for help on using the repository browser.