source: branches/shrink-tcr/lisp-kernel/thread_manager.c @ 14606

Last change on this file since 14606 was 14606, checked in by rme, 9 years ago

Checkpoint of work in progress.

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