source: release/1.9/source/lisp-kernel/thread_manager.c @ 15706

Last change on this file since 15706 was 15706, checked in by gb, 6 years ago

Propagate recent trunk changes.

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