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

Last change on this file since 15202 was 15202, checked in by gb, 9 years ago

Defer all aspects of gcable-pointer termination until after other
threads have been resumed. This is necessary because some things
that we were doing earlier (sem_destroy, for instance) may try to
do memory operations that may require ownership of a lock owned
by some other thread.

There are some (hopefully minor) consequences of this change: the
GC has to retain an otherwise unreachable lisp XMACPTR object until
the next GC, and some foreign resources might by tied up slightly
longer than they had been in the old scheme.

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