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

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

In shutdown_thread_tcr(), when HAVE_TLS is defined and the tcr is
current_tcr, set current_tcr to NULL and zero out the tcr's contents,
just in case.

This enables destructors established with pthread_key_create to make
callbacks on a newly-initialized TCR and seems to fix ticket:1052 in
the trunk.

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