source: release/1.7/source/lisp-kernel/thread_manager.c @ 15267

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

Try to fix Mach kernel thread lossage.

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