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

Last change on this file since 15333 was 15333, checked in by gb, 8 years ago

Terminate the application via fatal_oserr() if a Mach semaphore
can't be created.

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