source: release/1.8/source/lisp-kernel/thread_manager.c @ 15449

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

Propagate r15437-r15439 to 1.8.

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