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

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

merge more recent changes from trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 59.3 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 
785#ifdef DARWIN
786/* Sending signals to "workqueue threads" (created via libdispatch)
787   via pthread_kill() isn't supported, unless the thread calls an
788   undocumented internal function.
789
790   Someone got paid to design this.
791*/
792static Boolean looked_up_setkill = false;
793typedef int(*setkillfn)(int);
794static setkillfn setkill = NULL;
795
796void
797try_enable_kill()
798{
799  if (!looked_up_setkill) {
800    setkill = dlsym(RTLD_DEFAULT,"__pthread_workqueue_setkill");
801    looked_up_setkill = true;
802  }
803  if (setkill) {
804    setkill(1);
805  }
806}
807#endif
808
809void
810enqueue_tcr(TCR *new)
811{
812  TCR *head, *tail;
813 
814  LOCK(lisp_global(TCR_AREA_LOCK),new);
815#ifdef DARWIN
816  if (new->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
817    try_enable_kill();
818  }
819#endif
820  head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR));
821  tail = TCR_AUX(head)->prev;
822  TCR_AUX(tail)->next = new;
823  TCR_AUX(head)->prev = new;
824  TCR_AUX(new)->prev = tail;
825  TCR_AUX(new)->next = head;
826  UNLOCK(lisp_global(TCR_AREA_LOCK),new);
827}
828
829#ifdef WIN_32
830TCR *
831allocate_tcr()
832{
833  void *p = calloc(1,sizeof(struct tcr_aux));
834  char *teb = (char *)NtCurrentTeb();
835  TCR *tcr = (TCR *)(teb + TCR_BIAS);
836
837  if (p == NULL)
838    allocation_failure(true, sizeof(struct tcr_aux));
839
840  if ((intptr_t)p & 03) {
841    fprintf(dbgout, "%p not aligned\n", p);
842    exit(1);
843  }
844  memset(tcr, 0, sizeof(TCR));
845  tcr->aux = p;
846  return tcr;
847}
848#else
849TCR *
850allocate_tcr()
851{
852  TCR *tcr,  *next;
853#ifdef DARWIN
854  extern TCR* darwin_allocate_tcr(void);
855  extern void darwin_free_tcr(TCR *);
856#endif
857  for (;;) {
858#ifdef DARWIN
859    tcr = darwin_allocate_tcr();
860#else
861    tcr = calloc(1, sizeof(TCR));
862#endif
863    return tcr;
864  }
865}
866#endif
867
868#ifdef X8664
869#ifdef LINUX
870#include <asm/prctl.h>
871#include <sys/prctl.h>
872#endif
873#ifdef FREEBSD
874#include <machine/sysarch.h>
875#endif
876
877void
878setup_tcr_extra_segment(TCR *tcr)
879{
880#ifdef FREEBSD
881  amd64_set_gsbase(tcr);
882#endif
883#ifdef LINUX
884  arch_prctl(ARCH_SET_GS, (natural)tcr);
885#endif
886#ifdef DARWIN
887  /*
888   * There's apparently no way to do this.  We used to use a horrible
889   * and slow kludge conditionalized on DARWIN_GS_HACK (which involved
890   * sharing gs between lisp and pthreads), hoping that Apple would
891   * eventually provide a way to set fsbase.  We got tired of waiting,
892   * and have now resigned ourselves to keeping the TCR in a GPR.
893   */
894  /* darwin_set_x8664_fs_reg(tcr); */
895#endif
896#ifdef SOLARIS
897  /* Chris Curtis found this and suggested the use of syscall here */
898  syscall(SYS_lwp_private,_LWP_SETPRIVATE, _LWP_GSBASE, tcr);
899#endif
900}
901
902#endif
903
904#ifdef X8632
905
906#ifdef DARWIN
907#include <architecture/i386/table.h>
908#include <architecture/i386/sel.h>
909#include <i386/user_ldt.h>
910
911void setup_tcr_extra_segment(TCR *tcr)
912{
913    uintptr_t addr = (uintptr_t)tcr;
914    unsigned int size = sizeof(*tcr);
915    ldt_entry_t desc;
916    sel_t sel;
917    int i;
918
919    desc.data.limit00 = (size - 1) & 0xffff;
920    desc.data.limit16 = ((size - 1) >> 16) & 0xf;
921    desc.data.base00 = addr & 0xffff;
922    desc.data.base16 = (addr >> 16) & 0xff;
923    desc.data.base24 = (addr >> 24) & 0xff;
924    desc.data.type = DESC_DATA_WRITE;
925    desc.data.dpl = USER_PRIV;
926    desc.data.present = 1;
927    desc.data.stksz = DESC_CODE_32B;
928    desc.data.granular = DESC_GRAN_BYTE;
929   
930    i = i386_set_ldt(LDT_AUTO_ALLOC, &desc, 1);
931
932    if (i < 0) {
933        perror("i386_set_ldt");
934    } else {
935        sel.index = i;
936        sel.rpl = USER_PRIV;
937        sel.ti = SEL_LDT;
938        tcr->ldt_selector = sel;
939    }
940}
941
942void free_tcr_extra_segment(TCR *tcr)
943{
944  /* load %fs with null segement selector */
945  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
946  if (i386_set_ldt(tcr->ldt_selector.index, NULL, 1) < 0)
947    perror("i386_set_ldt");
948  tcr->ldt_selector = NULL_SEL;
949}
950#endif
951
952#ifdef LINUX
953
954#include <asm/ldt.h>
955#include <sys/syscall.h>
956
957/* see desc_struct in kernel/include/asm-i386/processor.h */
958typedef struct {
959  uint32_t a;
960  uint32_t b;
961} linux_desc_struct;
962
963
964#define desc_avail(d) (((d)->a) == 0)
965
966linux_desc_struct linux_ldt_entries[LDT_ENTRIES];
967
968/* We have to ask the Linux kernel for a copy of the ldt table
969   and manage it ourselves.  It's not clear that this is
970   thread-safe in general, but we can at least ensure that
971   it's thread-safe wrt lisp threads. */
972
973pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
974
975int
976modify_ldt(int func, void *ptr, unsigned long bytecount)
977{
978  return syscall(__NR_modify_ldt, func, ptr, bytecount);
979}
980
981
982void
983setup_tcr_extra_segment(TCR *tcr)
984{
985  int i, n;
986  short sel;
987  struct user_desc u = {1, 0, 0, 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1};
988  linux_desc_struct *d = linux_ldt_entries;
989
990  pthread_mutex_lock(&ldt_lock);
991  n = modify_ldt(0,d,LDT_ENTRIES*LDT_ENTRY_SIZE)/LDT_ENTRY_SIZE;
992  for (i = 0; i < n; i++,d++) {
993    if (desc_avail(d)) {
994      break;
995    }
996  }
997  if (i == LDT_ENTRIES) {
998    pthread_mutex_unlock(&ldt_lock);
999    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
1000    _exit(1);
1001  }
1002  u.entry_number = i;
1003  u.base_addr = (uint32_t)tcr;
1004  u.limit = sizeof(TCR);
1005  u.limit_in_pages = 0;
1006  if (modify_ldt(1,&u,sizeof(struct user_desc)) != 0) {
1007    pthread_mutex_unlock(&ldt_lock);
1008    fprintf(dbgout,"Can't assign LDT entry\n");
1009    _exit(1);
1010  }
1011  sel = (i << 3) | 7;
1012  tcr->ldt_selector = sel;
1013  pthread_mutex_unlock(&ldt_lock);
1014}
1015
1016void
1017free_tcr_extra_segment(TCR *tcr)
1018{
1019  struct user_desc u = {0, 0, 0, 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0};
1020  short sel = tcr->ldt_selector;
1021
1022  pthread_mutex_lock(&ldt_lock);
1023  /* load %fs with null segment selector */
1024  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1025  tcr->ldt_selector = 0;
1026  u.entry_number = (sel>>3);
1027  modify_ldt(1,&u,sizeof(struct user_desc));
1028  pthread_mutex_unlock(&ldt_lock);
1029 
1030}
1031
1032#endif
1033
1034#ifdef WINDOWS
1035bitvector ldt_entries_in_use = NULL;
1036HANDLE ldt_lock;
1037
1038typedef struct {
1039  DWORD offset;
1040  DWORD size;
1041  LDT_ENTRY entry;
1042} win32_ldt_info;
1043
1044
1045int WINAPI (*NtQueryInformationProcess)(HANDLE,DWORD,VOID*,DWORD,DWORD*);
1046int WINAPI (*NtSetInformationProcess)(HANDLE,DWORD,VOID*,DWORD);
1047
1048void
1049init_win32_ldt()
1050{
1051  HANDLE hNtdll;
1052  int status = 0xc0000002;
1053  win32_ldt_info info;
1054  DWORD nret;
1055 
1056
1057  ldt_entries_in_use=malloc(8192/8);
1058  zero_bits(ldt_entries_in_use,8192);
1059  ldt_lock = CreateMutex(NULL,0,NULL);
1060
1061  hNtdll = LoadLibrary("ntdll.dll");
1062  NtQueryInformationProcess = (void*)GetProcAddress(hNtdll, "NtQueryInformationProcess");
1063  NtSetInformationProcess = (void*)GetProcAddress(hNtdll, "NtSetInformationProcess");
1064  if (NtQueryInformationProcess != NULL) {
1065    info.offset = 0;
1066    info.size = sizeof(LDT_ENTRY);
1067    status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1068  }
1069
1070  if (status) {
1071    fprintf(dbgout, "This application can't run under this OS version\n");
1072    _exit(1);
1073  }
1074}
1075
1076void
1077setup_tcr_extra_segment(TCR *tcr)
1078{
1079}
1080
1081void 
1082free_tcr_extra_segment(TCR *tcr)
1083{
1084}
1085
1086#endif
1087#ifdef FREEBSD
1088#include <machine/segments.h>
1089#include <machine/sysarch.h>
1090
1091/* It'd be tempting to use i386_set_fsbase() here, but there doesn't
1092   seem to be any way to free the GDT entry it creates.  Actually,
1093   it's not clear that that really sets a GDT entry; let's see */
1094
1095#define FREEBSD_USE_SET_FSBASE 1
1096void
1097setup_tcr_extra_segment(TCR *tcr)
1098{
1099#if !FREEBSD_USE_SET_FSBASE
1100  struct segment_descriptor sd;
1101  uintptr_t addr = (uintptr_t)tcr;
1102  unsigned int size = sizeof(*tcr);
1103  int i;
1104
1105  sd.sd_lolimit = (size - 1) & 0xffff;
1106  sd.sd_hilimit = ((size - 1) >> 16) & 0xf;
1107  sd.sd_lobase = addr & ((1<<24)-1);
1108  sd.sd_hibase = (addr>>24)&0xff;
1109
1110
1111
1112  sd.sd_type = 18;
1113  sd.sd_dpl = SEL_UPL;
1114  sd.sd_p = 1;
1115  sd.sd_def32 = 1;
1116  sd.sd_gran = 0;
1117
1118  i = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor *)&sd, 1);
1119
1120  if (i < 0) {
1121    perror("i386_set_ldt");
1122    exit(1);
1123  } else {
1124    tcr->ldt_selector = LSEL(i,SEL_UPL);
1125  }
1126#else
1127  extern unsigned short get_fs_register(void);
1128
1129  if (i386_set_fsbase((void*)tcr)) {
1130    perror("i386_set_fsbase");
1131    exit(1);
1132  }
1133
1134
1135  /* Once we've called i386_set_fsbase, we can't write to %fs. */
1136  tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL);
1137#endif
1138}
1139
1140void 
1141free_tcr_extra_segment(TCR *tcr)
1142{
1143#if FREEBSD_USE_SET_FSBASE
1144  /* On a 32-bit kernel, this allocates a GDT entry.  It's not clear
1145     what it would mean to deallocate that entry. */
1146  /* If we're running on a 64-bit kernel, we can't write to %fs */
1147#else
1148  int idx = tcr->ldt_selector >> 3;
1149  /* load %fs with null segment selector */
1150  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1151  if (i386_set_ldt(idx, NULL, 1) < 0)
1152    perror("i386_set_ldt");
1153#endif
1154  tcr->ldt_selector = 0;
1155}
1156#endif
1157
1158#ifdef SOLARIS
1159#include <sys/sysi86.h>
1160
1161bitvector ldt_entries_in_use = NULL;
1162pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
1163
1164void
1165solaris_ldt_init()
1166{
1167  int fd;
1168  struct ssd s;
1169
1170  ldt_entries_in_use=malloc(8192/8);
1171  zero_bits(ldt_entries_in_use,8192);
1172 
1173  fd = open("/proc/self/ldt", O_RDONLY);
1174
1175  while(read(fd,&s,sizeof(s)) == sizeof(s)) {
1176    set_bit(ldt_entries_in_use,s.sel>>3);
1177  }
1178  close(fd);
1179}
1180   
1181
1182void
1183setup_tcr_extra_segment(TCR *tcr)
1184{
1185  struct ssd s;
1186  int i;
1187
1188  pthread_mutex_lock(&ldt_lock);
1189
1190  for (i = 0; i < 8192; i++) {
1191    if (!ref_bit(ldt_entries_in_use,i)) {
1192      s.sel = (i<<3)|7;
1193      s.bo = (unsigned int)tcr;
1194      s.ls = sizeof(TCR);
1195      s.acc1 = 0xf2;
1196      s.acc2 = 4;
1197
1198      if (sysi86(SI86DSCR, &s) >= 0) {
1199        set_bit(ldt_entries_in_use,i);
1200        tcr->ldt_selector = (i<<3)|7;
1201        pthread_mutex_unlock(&ldt_lock);
1202        return;
1203      }
1204      set_bit(ldt_entries_in_use,i);
1205    }
1206  }
1207  pthread_mutex_unlock(&ldt_lock);
1208  fprintf(dbgout, "All 8192 LDT descriptors in use\n");
1209  _exit(1);
1210
1211
1212 
1213}
1214
1215void 
1216free_tcr_extra_segment(TCR *tcr)
1217{
1218  struct ssd s;
1219  int i;
1220
1221  pthread_mutex_lock(&ldt_lock);
1222  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1223  s.sel = tcr->ldt_selector;
1224  i = s.sel>>3;
1225  tcr->ldt_selector = 0;
1226  s.bo = 0;
1227  s.ls = 0;
1228  s.acc1 = 0;
1229  s.acc2 = 0;
1230  sysi86(SI86DSCR, &s);
1231  clr_bit(ldt_entries_in_use,i);
1232  pthread_mutex_unlock(&ldt_lock);
1233}
1234
1235#endif
1236#endif
1237
1238#ifdef ARM
1239extern int arm_architecture_version;
1240
1241void
1242init_arm_tcr_sptab(TCR *tcr)
1243{
1244  extern LispObj *sptab;
1245  extern LispObj *sptab_end;
1246  LispObj *p, *q;
1247
1248  for (p=sptab,q = tcr->sptab;
1249       p<sptab_end;
1250       p++,q++) {
1251    *q = *p;
1252  }
1253}
1254#endif       
1255 
1256 
1257
1258
1259/*
1260  Caller must hold the area_lock.
1261*/
1262TCR *
1263new_tcr(natural vstack_size, natural tstack_size)
1264{
1265  extern area
1266    *allocate_vstack_holding_area_lock(natural),
1267    *allocate_tstack_holding_area_lock(natural);
1268  area *a;
1269  int i;
1270#ifndef WINDOWS
1271  sigset_t sigmask;
1272
1273  sigemptyset(&sigmask);
1274  pthread_sigmask(SIG_SETMASK,&sigmask, NULL);
1275#endif
1276
1277#ifdef HAVE_TLS
1278  TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15));
1279  current_tcr = tcr;
1280#else /* no TLS */
1281  TCR *tcr = allocate_tcr();
1282#endif
1283
1284#ifdef ARM
1285  init_arm_tcr_sptab(tcr);
1286  tcr->architecture_version = (arm_architecture_version-ARM_ARCHITECTURE_v7) << fixnumshift;
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
1356#ifdef WIN_32
1357__declspec(dllexport)
1358#endif
1359shutdown_thread_tcr(void *arg)
1360{
1361#ifdef DARWIN
1362  extern void darwin_free_tcr(TCR *);
1363#endif
1364  TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0);
1365
1366  area *vs, *ts, *cs;
1367 
1368  if (current == NULL) {
1369    current = tcr;
1370  }
1371
1372  if (--(TCR_AUX(tcr)->shutdown_count) == 0) {
1373    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
1374      LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1375        callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1376   
1377      tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1378      ((void (*)())ptr_from_lispobj(callback_ptr))(1);
1379      tsd_set(lisp_global(TCR_KEY), NULL);
1380    }
1381#ifdef DARWIN
1382#endif
1383    LOCK(lisp_global(TCR_AREA_LOCK),current);
1384    vs = tcr->vs_area;
1385    tcr->vs_area = NULL;
1386#ifndef ARM
1387    ts = tcr->ts_area;
1388    tcr->ts_area = NULL;
1389#endif
1390    cs = TCR_AUX(tcr)->cs_area;
1391    TCR_AUX(tcr)->cs_area = NULL;
1392    if (vs) {
1393      condemn_area_holding_area_lock(vs);
1394    }
1395#ifndef ARM
1396    if (ts) {
1397      condemn_area_holding_area_lock(ts);
1398    }
1399#endif
1400    if (cs) {
1401      condemn_area_holding_area_lock(cs);
1402    }
1403    /* If we use the sigaltstack mechanism, we always keep the
1404       altstack separate from other stacks now.
1405    */
1406#ifdef USE_SIGALTSTACK
1407    {
1408      stack_t new, current;
1409      new.ss_flags = SS_DISABLE;
1410      if (sigaltstack(&new, &current) == 0) {
1411        munmap(current.ss_sp, current.ss_size);
1412      }
1413    }
1414#endif
1415    destroy_semaphore(&TCR_AUX(tcr)->suspend);
1416    destroy_semaphore(&TCR_AUX(tcr)->resume);
1417    destroy_semaphore(&TCR_AUX(tcr)->reset_completion);
1418    destroy_semaphore(&TCR_AUX(tcr)->activate);
1419    tcr->tlb_limit = 0;
1420    free(tcr->tlb_pointer);
1421    tcr->tlb_pointer = NULL;
1422#ifdef WINDOWS
1423    if (TCR_AUX(tcr)->osid != 0) {
1424      CloseHandle((HANDLE)(TCR_AUX(tcr)->osid));
1425    }
1426#endif
1427    TCR_AUX(tcr)->osid = 0;
1428    tcr->interrupt_pending = 0;
1429    TCR_AUX(tcr)->termination_semaphore = NULL;
1430#if defined(HAVE_TLS) || defined(WIN_32) || defined(DARWIN)
1431    dequeue_tcr(tcr);
1432#endif
1433#ifdef X8632
1434    free_tcr_extra_segment(tcr);
1435#endif
1436#ifdef WINDOWS
1437    CloseHandle((HANDLE)TCR_AUX(tcr)->io_datum);
1438    TCR_AUX(tcr)->io_datum = NULL;
1439    free(TCR_AUX(tcr)->native_thread_info);
1440    TCR_AUX(tcr)->native_thread_info = NULL;
1441#ifdef WIN_32
1442    free(tcr->aux);
1443    tcr->aux = NULL;
1444#endif
1445#endif
1446#ifdef DARWIN
1447    darwin_free_tcr(tcr);
1448#endif
1449    UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1450#ifdef HAVE_TLS
1451    if (current_tcr == tcr) {
1452      current_tcr = NULL;
1453      memset(tcr,0,sizeof(tcr));
1454    }
1455#endif
1456  } else {
1457    tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1458  }
1459}
1460
1461void
1462tcr_cleanup(void *arg)
1463{
1464  TCR *tcr = (TCR *)arg;
1465  area *a;
1466
1467  a = tcr->vs_area;
1468  if (a) {
1469    a->active = a->high;
1470  }
1471#ifndef ARM
1472  a = tcr->ts_area;
1473  if (a) {
1474    a->active = a->high;
1475  }
1476#endif
1477  a = TCR_AUX(tcr)->cs_area;
1478  if (a) {
1479    a->active = a->high;
1480  }
1481  tcr->valence = TCR_STATE_FOREIGN;
1482  TCR_AUX(tcr)->shutdown_count = 1;
1483  shutdown_thread_tcr(tcr);
1484  tsd_set(lisp_global(TCR_KEY), NULL);
1485}
1486
1487void *
1488current_native_thread_id()
1489{
1490  return ((void *) (natural)
1491#ifdef LINUX
1492#ifdef __NR_gettid
1493          syscall(__NR_gettid)
1494#else
1495          getpid()
1496#endif
1497#endif
1498#ifdef DARWIN
1499          pthread_mach_thread_np(pthread_self())
1500#endif
1501#ifdef FREEBSD
1502          pthread_self()
1503#endif
1504#ifdef SOLARIS
1505          pthread_self()
1506#endif
1507#ifdef WINDOWS
1508          GetCurrentThreadId()
1509#endif
1510          );
1511}
1512
1513
1514void
1515thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size)
1516{
1517  area *a, *register_cstack_holding_area_lock(BytePtr, natural);
1518
1519  TCR_AUX(tcr)->osid = current_thread_osid();
1520  TCR_AUX(tcr)->native_thread_id = current_native_thread_id();
1521  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1522  a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size);
1523  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1524  TCR_AUX(tcr)->cs_area = a;
1525  a->owner = tcr;
1526#ifdef ARM
1527  tcr->last_lisp_frame = (natural)(a->high);
1528#endif
1529  TCR_AUX(tcr)->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1530#ifdef LINUX
1531#ifdef PPC
1532#ifndef PPC64
1533  tcr->native_thread_info = current_r2;
1534#endif
1535#endif
1536#endif
1537  TCR_AUX(tcr)->errno_loc = (int *)(&errno);
1538  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1539#ifdef LINUX
1540  linux_exception_init(tcr);
1541#endif
1542#ifdef WINDOWS
1543  TCR_AUX(tcr)->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
1544  TCR_AUX(tcr)->native_thread_info = malloc(sizeof(CONTEXT));
1545#endif
1546  TCR_AUX(tcr)->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1547}
1548
1549/*
1550  Register the specified tcr as "belonging to" the current thread.
1551  Under Darwin, setup Mach exception handling for the thread.
1552  Install cleanup handlers for thread termination.
1553*/
1554void
1555register_thread_tcr(TCR *tcr)
1556{
1557  void *stack_base = NULL;
1558  natural stack_size = 0;
1559
1560  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1561  thread_init_tcr(tcr, stack_base, stack_size);
1562  enqueue_tcr(tcr);
1563}
1564
1565
1566 
1567 
1568
1569Ptr
1570create_stack(natural size)
1571{
1572  Ptr p;
1573  size=align_to_power_of_2(size, log2_page_size);
1574  p = (Ptr) MapMemoryForStack((size_t)size);
1575  if (p != (Ptr)(-1)) {
1576    *((size_t *)p) = size;
1577    return p;
1578  }
1579  allocation_failure(true, size);
1580  return NULL;
1581}
1582
1583void *
1584allocate_stack(natural size)
1585{
1586  return create_stack(size);
1587}
1588
1589void
1590free_stack(void *s)
1591{
1592  size_t size = *((size_t *)s);
1593  UnMapMemory(s, size);
1594}
1595
1596Boolean threads_initialized = false;
1597
1598#ifndef USE_FUTEX
1599#ifdef WINDOWS
1600void
1601count_cpus()
1602{
1603  SYSTEM_INFO si;
1604
1605  GetSystemInfo(&si);
1606  if (si.dwNumberOfProcessors > 1) {
1607    spin_lock_tries = 1024;
1608  }
1609}
1610#else
1611void
1612count_cpus()
1613{
1614  int n = sysconf(_SC_NPROCESSORS_CONF);
1615 
1616  if (n > 1) {
1617    spin_lock_tries = 1024;
1618  }
1619}
1620#endif
1621#endif
1622
1623void
1624init_threads(void * stack_base, TCR *tcr)
1625{
1626  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1627#ifdef WINDOWS
1628  lisp_global(TCR_KEY) = TlsAlloc();
1629  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1630  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
1631#else
1632  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1633  thread_signal_setup();
1634#endif
1635
1636#ifndef USE_FUTEX
1637  count_cpus();
1638#endif
1639  threads_initialized = true;
1640}
1641
1642
1643#ifdef WINDOWS
1644unsigned CALLBACK
1645#else
1646void *
1647#endif
1648lisp_thread_entry(void *param)
1649{
1650  thread_activation *activation = (thread_activation *)param;
1651  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1652  LispObj *start_vsp;
1653#ifndef WINDOWS
1654  sigset_t mask, old_mask;
1655
1656  sigemptyset(&mask);
1657  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1658#endif
1659
1660  register_thread_tcr(tcr);
1661
1662#ifndef WINDOWS
1663  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1664#endif
1665  tcr->vs_area->active -= node_size;
1666  *(--tcr->save_vsp) = lisp_nil;
1667  start_vsp = tcr->save_vsp;
1668  enable_fp_exceptions();
1669  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1670  activation->tcr = tcr;
1671  SEM_RAISE(activation->created);
1672  do {
1673    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1674    SEM_WAIT_FOREVER(TCR_AUX(tcr)->activate);
1675    /* Now go run some lisp code */
1676    start_lisp(TCR_TO_TSD(tcr),0);
1677    tcr->save_vsp = start_vsp;
1678  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1679#ifndef WINDOWS
1680  pthread_cleanup_pop(true);
1681#else
1682  tcr_cleanup(tcr);
1683#endif
1684#ifdef WINDOWS
1685  return 0;
1686#else
1687  return NULL;
1688#endif
1689}
1690
1691typedef 
1692short (*suspendf)();
1693
1694
1695void
1696suspend_current_cooperative_thread()
1697{
1698  static suspendf cooperative_suspend = NULL;
1699  void *xFindSymbol(void*,char*);
1700
1701  if (cooperative_suspend == NULL) {
1702    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
1703  }
1704  if (cooperative_suspend) {
1705    cooperative_suspend(1 /* kCurrentThreadID */,
1706                        1 /* kStoppedThreadState */,
1707                        0 /* kAnyThreadID */);
1708  }
1709}
1710
1711void *
1712cooperative_thread_startup(void *arg)
1713{
1714
1715  TCR *tcr = get_tcr(0);
1716  LispObj *start_vsp;
1717
1718  if (!tcr) {
1719    return NULL;
1720  }
1721#ifndef WINDOWS
1722  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1723#endif
1724  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1725  start_vsp = tcr->save_vsp;
1726  do {
1727    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1728    suspend_current_cooperative_thread();
1729     
1730    start_lisp(tcr, 0);
1731    tcr->save_vsp = start_vsp;
1732  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1733#ifndef WINDOWS
1734  pthread_cleanup_pop(true);
1735#else
1736  tcr_cleanup(tcr);
1737#endif
1738  return NULL;
1739}
1740
1741void *
1742xNewThread(natural control_stack_size,
1743           natural value_stack_size,
1744           natural temp_stack_size)
1745
1746{
1747  thread_activation activation;
1748
1749
1750  activation.tsize = temp_stack_size;
1751  activation.vsize = value_stack_size;
1752  activation.tcr = 0;
1753  activation.created = new_semaphore(0);
1754  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1755                           NULL, 
1756                           lisp_thread_entry,
1757                           (void *) &activation)) {
1758   
1759    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1760  }
1761  destroy_semaphore(&activation.created); 
1762
1763#ifdef USE_DTRACE
1764  if (CCL_CREATE_THREAD_ENABLED() && activation.tcr) {
1765    CCL_CREATE_THREAD(activation.tcr->osid);
1766  }
1767#endif
1768
1769  return TCR_TO_TSD(activation.tcr);
1770}
1771
1772Boolean
1773active_tcr_p(TCR *q)
1774{
1775  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1776 
1777  do {
1778    if (p == q) {
1779      return true;
1780    }
1781    p = TCR_AUX(p)->next;
1782  } while (p != head);
1783  return false;
1784}
1785
1786
1787OSErr
1788xDisposeThread(TCR *tcr)
1789{
1790  return 0;                     /* I don't think that this is ever called. */
1791}
1792
1793OSErr
1794xYieldToThread(TCR *target)
1795{
1796  Bug(NULL, "xYieldToThread ?");
1797  return 0;
1798}
1799 
1800OSErr
1801xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1802{
1803  Bug(NULL, "xThreadCurrentStackSpace ?");
1804  return 0;
1805}
1806
1807
1808#ifdef WINDOWS
1809Boolean
1810create_system_thread(size_t stack_size,
1811                     void* stackaddr,
1812                     unsigned CALLBACK (*start_routine)(void *),
1813                     void* param)
1814{
1815  HANDLE thread_handle;
1816  Boolean won = false;
1817
1818  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1819
1820  thread_handle = (HANDLE)_beginthreadex(NULL, 
1821                                         stack_size,
1822                                         start_routine,
1823                                         param,
1824                                         0, 
1825                                         NULL);
1826
1827  if (thread_handle == NULL) {
1828    wperror("CreateThread");
1829  } else {
1830    won = true;
1831    CloseHandle(thread_handle);
1832  }
1833  return won;
1834}
1835#else
1836Boolean
1837create_system_thread(size_t stack_size,  void *stackaddr,
1838                     void *(*start_routine)(void *), void *param)
1839{
1840  pthread_attr_t attr;
1841  pthread_t returned_thread;
1842  int err;
1843  TCR *current = get_tcr(true);
1844
1845  pthread_attr_init(&attr);
1846  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1847
1848  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1849    stack_size = PTHREAD_STACK_MIN;
1850  }
1851
1852  stack_size = ensure_stack_limit(stack_size);
1853  if (stackaddr != NULL) {
1854    /* Size must have been specified.  Sort of makes sense ... */
1855    pthread_attr_setstack(&attr, stackaddr, stack_size);
1856  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1857    pthread_attr_setstacksize(&attr,stack_size);
1858  }
1859
1860  /*
1861     I think that's just about enough ... create the thread.
1862     Well ... not quite enough.  In Leopard (at least), many
1863     pthread routines grab an internal spinlock when validating
1864     their arguments.  If we suspend a thread that owns this
1865     spinlock, we deadlock.  We can't in general keep that
1866     from happening: if arbitrary C code is suspended while
1867     it owns the spinlock, we still deadlock.  It seems that
1868     the best that we can do is to keep -this- code from
1869     getting suspended (by grabbing TCR_AREA_LOCK)
1870  */
1871  LOCK(lisp_global(TCR_AREA_LOCK),current);
1872  err = pthread_create(&returned_thread, &attr, start_routine, param);
1873  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1874  pthread_attr_destroy(&attr);
1875  return (err == 0);
1876}
1877#endif
1878
1879TCR *
1880get_tcr(Boolean create)
1881{
1882#ifdef HAVE_TLS
1883  TCR *current = current_tcr;
1884#elif defined(WIN_32)
1885  TCR *current = ((TCR *)((char *)NtCurrentTeb() + TCR_BIAS))->linear;
1886#else
1887  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1888  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1889#endif
1890
1891  if ((current == NULL) && create) {
1892    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1893      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1894    int i, nbindwords = 0;
1895    extern natural initial_stack_size;
1896   
1897    /* Make one. */
1898    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1899    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1900    register_thread_tcr(current);
1901#ifdef DEBUG_TCR_CREATION
1902#ifndef WINDOWS
1903    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
1904#endif
1905#endif
1906    current->vs_area->active -= node_size;
1907    *(--current->save_vsp) = lisp_nil;
1908#ifdef PPC
1909#define NSAVEREGS 8
1910#endif
1911#ifdef X8664
1912#define NSAVEREGS 4
1913#endif
1914#ifdef X8632
1915#define NSAVEREGS 0
1916#endif
1917#ifdef ARM
1918#define NSAVEREGS 0
1919#endif
1920    for (i = 0; i < NSAVEREGS; i++) {
1921      *(--current->save_vsp) = 0;
1922      current->vs_area->active -= node_size;
1923    }
1924    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1925    for (i = 0; i < nbindwords; i++) {
1926      *(--current->save_vsp) = 0;
1927      current->vs_area->active -= node_size;
1928    }
1929    TCR_AUX(current)->shutdown_count = 1;
1930    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1931
1932  }
1933 
1934  return current;
1935}
1936
1937#ifdef WINDOWS
1938void *
1939pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
1940{
1941  /* Thread has started to return from an exception. */
1942  if (where < restore_windows_context_iret) {
1943    /* In the process of restoring registers; context still in
1944       %rcx.  Just make our suspend_context be the context
1945       we're trying to restore, so that we'll resume from
1946       the suspend in the same context that we're trying to
1947       restore */
1948#ifdef WIN_64
1949    *pcontext = * (CONTEXT *)(pcontext->Rcx);
1950#else
1951    if (where == restore_windows_context_start) {
1952      *pcontext = * (CONTEXT *)((pcontext->Esp)+4);
1953    } else {
1954      *pcontext = * (CONTEXT *)(pcontext->Ecx);
1955    }
1956#endif
1957  } else {
1958    /* Most of the context has already been restored; fix %rcx
1959       if need be, then restore ss:rsp, cs:rip, and flags. */
1960#ifdef WIN_64
1961    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1962
1963    pcontext->Rip = iret_frame->Rip;
1964    pcontext->SegCs = (WORD) iret_frame->Cs;
1965    pcontext->EFlags = (DWORD) iret_frame->Rflags;
1966    pcontext->Rsp = iret_frame->Rsp;
1967    pcontext->SegSs = (WORD) iret_frame->Ss;
1968#else
1969    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
1970
1971    pcontext->Eip = iret_frame->Eip;
1972    pcontext->SegCs = (WORD) iret_frame->Cs;
1973    pcontext->EFlags = (DWORD) iret_frame->EFlags;
1974    pcontext->Esp += sizeof(ia32_iret_frame);
1975#endif
1976  }
1977  tcr->pending_exception_context = NULL;
1978  /* We basically never return from an exception unless we
1979     were executing lisp code when the exception returned.
1980     If that ever changes, we need to know what valence
1981     would have been restored here.*/
1982  tcr->valence = TCR_STATE_LISP;
1983}
1984
1985Boolean
1986suspend_tcr(TCR *tcr)
1987{
1988  int suspend_count = atomic_incf(&(TCR_AUX(tcr)->suspend_count));
1989  DWORD rc;
1990  if (suspend_count == 1) {
1991    CONTEXT  *pcontext = (CONTEXT *)TCR_AUX(tcr)->native_thread_info;
1992    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
1993    pc where;
1994    area *cs = TCR_AUX(tcr)->cs_area;
1995    LispObj foreign_rsp;
1996
1997    if (hthread == NULL) {
1998      return false;
1999    }
2000    rc = SuspendThread(hthread);
2001    if (rc == -1) {
2002      /* If the thread's simply dead, we should handle that here */
2003      return false;
2004    }
2005    pcontext->ContextFlags = CONTEXT_ALL;
2006    rc = GetThreadContext(hthread, pcontext);
2007    if (rc == 0) {
2008      return false;
2009    }
2010    where = (pc)(xpPC(pcontext));
2011
2012    if ((where >= restore_windows_context_start) &&
2013        (where < restore_windows_context_end) &&
2014        (tcr->valence != TCR_STATE_LISP)) {
2015#ifdef WIN_64
2016      tcr->valence = xpGPR(pcontext,REG_R8);
2017#else
2018      tcr->valence = ((LispObj *)(xpGPR(pcontext,Isp)))[3];
2019#endif
2020      pcontext = tcr->pending_exception_context;
2021      tcr->pending_exception_context = NULL; 
2022      where = (pc)(xpPC(pcontext));
2023    }
2024    if (tcr->valence == TCR_STATE_LISP) {
2025      if ((where >= restore_windows_context_start) &&
2026          (where < restore_windows_context_end)) {
2027        pc_luser_restore_windows_context(pcontext, tcr, where);
2028      } else {
2029        area *ts = tcr->ts_area;
2030        /* If we're in the lisp heap, or in x86-spentry??.o, or in
2031           x86-subprims??.o, or in the subprims jump table at #x15000,
2032           or on the tstack ... we're just executing lisp code.  Otherwise,
2033           we got an exception while executing lisp code, but haven't
2034           entered the handler yet (still in Windows exception glue
2035           or switching stacks or something.)  In the latter case, we
2036           basically want to get to he handler and have it notice
2037           the pending exception request, and suspend the thread at that
2038           point. */
2039        if (!((where < (pc)lisp_global(HEAP_END)) &&
2040              (where >= (pc)lisp_global(HEAP_START))) &&
2041            (!((where < (pc)(managed_static_area->active)) &&
2042              (where >= (pc)(readonly_area->low)))) &&
2043            !((where < spentry_end) && (where >= spentry_start)) &&
2044            !((where < subprims_end) && (where >= subprims_start)) &&
2045            !((where < (pc) 0x16000) &&
2046              (where >= (pc) 0x15000)) &&
2047            !((where < (pc) (ts->high)) &&
2048              (where >= (pc) (ts->low)))) {
2049          /* The thread has lisp valence, but is not executing code
2050             where we expect lisp code to be and is not exiting from
2051             an exception handler.  That pretty much means that it's
2052             on its way into an exception handler; we have to handshake
2053             until it enters an exception-wait state. */
2054          /* There are likely race conditions here */
2055          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2056          ResumeThread(hthread);
2057          SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2058          pcontext = NULL;
2059        }
2060      }
2061    }
2062    /* If we're really running lisp code, there's some reason to
2063       suspect that Windows is lying about that; the thread may have
2064       already committed to processing an exception and just not have
2065       reentered user mode.  If there's a way to determine that more
2066       reliably, I don't know what it is.  We can catch some cases of
2067       that by looking at whether the PC is at a UUO or other
2068       "intentional" illegal instruction and letting the thread enter
2069       exception handling, treating this case just like the case
2070       above. 
2071
2072       When people say that Windows sucks, they aren't always just
2073       talking about all of the other ways that it sucks.
2074    */
2075    if ((*where == INTN_OPCODE) ||
2076        ((*where == XUUO_OPCODE_0) && (where[1] == XUUO_OPCODE_1))) {
2077      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2078      ResumeThread(hthread);
2079      SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2080      pcontext = NULL;
2081    }
2082    TCR_AUX(tcr)->suspend_context = pcontext;
2083    return true;
2084  }
2085  return false;
2086}
2087#else
2088Boolean
2089suspend_tcr(TCR *tcr)
2090{
2091  int suspend_count = atomic_incf(&(tcr->suspend_count));
2092  pthread_t thread;
2093  if (suspend_count == 1) {
2094    thread = (pthread_t)(tcr->osid);
2095    if ((thread != (pthread_t) 0) &&
2096        (pthread_kill(thread, thread_suspend_signal) == 0)) {
2097      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2098    } else {
2099      /* A problem using pthread_kill.  On Darwin, this can happen
2100         if the thread has had its signal mask surgically removed
2101         by pthread_exit.  If the native (Mach) thread can be suspended,
2102         do that and return true; otherwise, flag the tcr as belonging
2103         to a dead thread by setting tcr->osid to 0.
2104      */
2105      tcr->osid = 0;
2106      return false;
2107    }
2108    return true;
2109  }
2110  return false;
2111}
2112#endif
2113
2114#ifdef WINDOWS
2115Boolean
2116tcr_suspend_ack(TCR *tcr)
2117{
2118  return true;
2119}
2120#else
2121Boolean
2122tcr_suspend_ack(TCR *tcr)
2123{
2124  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
2125    SEM_WAIT_FOREVER(tcr->suspend);
2126    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2127  }
2128  return true;
2129}
2130#endif
2131     
2132
2133Boolean
2134kill_tcr(TCR *tcr)
2135{
2136  TCR *current = get_tcr(true);
2137  Boolean result = false;
2138
2139  LOCK(lisp_global(TCR_AREA_LOCK),current);
2140  {
2141    LispObj osid = TCR_AUX(tcr)->osid;
2142   
2143    if (osid) {
2144      result = true;
2145#ifdef WINDOWS
2146      /* What we really want to do here is (something like)
2147         forcing the thread to run quit_handler().  For now,
2148         mark the TCR as dead and kill the Windows thread. */
2149      /* xxx TerminateThread() bad */
2150      TCR_AUX(tcr)->osid = 0;
2151      if (!TerminateThread((HANDLE)osid, 0)) {
2152        CloseHandle((HANDLE)osid);
2153        result = false;
2154      } else {
2155        CloseHandle((HANDLE)osid);
2156        shutdown_thread_tcr(tcr);
2157      }
2158#else
2159      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2160        result = false;
2161      }
2162#endif
2163    }
2164  }
2165  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2166  return result;
2167}
2168
2169Boolean
2170lisp_suspend_tcr(TCR *tcr)
2171{
2172  Boolean suspended;
2173  TCR *current = get_tcr(true);
2174 
2175  LOCK(lisp_global(TCR_AREA_LOCK),current);
2176  suspended = suspend_tcr(tcr);
2177  if (suspended) {
2178    while (!tcr_suspend_ack(tcr));
2179  }
2180  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2181  return suspended;
2182}
2183         
2184#ifdef WINDOWS
2185Boolean
2186resume_tcr(TCR *tcr)
2187{
2188  int suspend_count = atomic_decf(&(TCR_AUX(tcr)->suspend_count)), err;
2189  DWORD rc;
2190  if (suspend_count == 0) {
2191    CONTEXT *context = TCR_AUX(tcr)->suspend_context;
2192    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
2193
2194
2195    TCR_AUX(tcr)->suspend_context = NULL;
2196    if (context) {
2197      if (tcr->valence == TCR_STATE_LISP) {
2198        rc = SetThreadContext(hthread,context);
2199        if (! rc) {
2200          Bug(NULL,"SetThreadContext");
2201          return false;
2202        }
2203      }
2204      rc = ResumeThread(hthread);
2205      if (rc == -1) {
2206        Bug(NULL,"ResumeThread");
2207        return false;
2208      }
2209      return true;
2210    } else {
2211      SEM_RAISE(TCR_AUX(tcr)->resume);
2212      return true;
2213    }
2214  }
2215  return false;
2216}   
2217#else
2218Boolean
2219resume_tcr(TCR *tcr)
2220{
2221  int suspend_count = atomic_decf(&(tcr->suspend_count));
2222  if (suspend_count == 0) {
2223    void *s = (tcr->resume);
2224    if (s != NULL) {
2225      SEM_RAISE(s);
2226      return true;
2227    }
2228  }
2229  return false;
2230}
2231#endif
2232
2233   
2234
2235
2236Boolean
2237lisp_resume_tcr(TCR *tcr)
2238{
2239  Boolean resumed;
2240  TCR *current = get_tcr(true);
2241 
2242  LOCK(lisp_global(TCR_AREA_LOCK),current);
2243  resumed = resume_tcr(tcr);
2244  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2245  return resumed;
2246}
2247
2248
2249TCR *freed_tcrs = NULL;
2250
2251void
2252enqueue_freed_tcr (TCR *tcr)
2253{
2254#ifndef HAVE_TLS
2255  TCR_AUX(tcr)->next = freed_tcrs;
2256  freed_tcrs = tcr;
2257#endif
2258}
2259
2260/* It's not clear that we can safely condemn a dead tcr's areas, since
2261   we may not be able to call free() if a suspended thread owns a
2262   malloc lock. At least make the areas appear to be empty.
2263*/
2264   
2265
2266void
2267normalize_dead_tcr_areas(TCR *tcr)
2268{
2269  area *a;
2270
2271  a = tcr->vs_area;
2272  if (a) {
2273    a->active = a->high;
2274  }
2275
2276#ifndef ARM
2277  a = tcr->ts_area;
2278  if (a) {
2279    a->active = a->high;
2280  }
2281#endif
2282
2283  a = TCR_AUX(tcr)->cs_area;
2284  if (a) {
2285    a->active = a->high;
2286  }
2287}
2288   
2289void
2290free_freed_tcrs ()
2291{
2292#ifdef DARWIN
2293  extern void darwin_free_tcr(TCR *);
2294#endif
2295  TCR *current, *next;
2296
2297  for (current = freed_tcrs; current; current = next) {
2298    next = TCR_AUX(current)->next;
2299#ifndef HAVE_TLS
2300#ifdef WIN_32
2301    /* We sort of have TLS in that the TEB is per-thread.  We free the
2302     * tcr aux vector elsewhere. */
2303#else
2304#ifdef DARWIN
2305    darwin_free_tcr(current);
2306#else
2307    free(current);
2308#endif
2309#endif
2310#endif
2311  }
2312  freed_tcrs = NULL;
2313}
2314
2315void
2316suspend_other_threads(Boolean for_gc)
2317{
2318  TCR *current = get_tcr(true), *other, *next;
2319  int dead_tcr_count = 0;
2320  Boolean all_acked;
2321
2322  LOCK(lisp_global(TCR_AREA_LOCK), current);
2323  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2324    if ((TCR_AUX(other)->osid != 0)) {
2325      suspend_tcr(other);
2326      if (TCR_AUX(other)->osid == 0) {
2327        dead_tcr_count++;
2328      }
2329    } else {
2330      dead_tcr_count++;
2331    }
2332  }
2333
2334  do {
2335    all_acked = true;
2336    for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2337      if ((TCR_AUX(other)->osid != 0)) {
2338        if (!tcr_suspend_ack(other)) {
2339          all_acked = false;
2340        }
2341      }
2342    }
2343  } while(! all_acked);
2344
2345     
2346
2347  /* All other threads are suspended; can safely delete dead tcrs now */
2348  if (dead_tcr_count) {
2349    for (other = TCR_AUX(current)->next; other != current; other = next) {
2350      next = TCR_AUX(other)->next;
2351      if (TCR_AUX(other)->osid == 0)  {
2352        normalize_dead_tcr_areas(other);
2353        dequeue_tcr(other);
2354        enqueue_freed_tcr(other);
2355      }
2356    }
2357  }
2358}
2359
2360void
2361lisp_suspend_other_threads()
2362{
2363  suspend_other_threads(false);
2364}
2365
2366void
2367resume_other_threads(Boolean for_gc)
2368{
2369  TCR *current = get_tcr(true), *other;
2370
2371  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2372    if ((TCR_AUX(other)->osid != 0)) {
2373      resume_tcr(other);
2374    }
2375  }
2376  free_freed_tcrs();
2377  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2378}
2379
2380void
2381lisp_resume_other_threads()
2382{
2383  resume_other_threads(false);
2384}
2385
2386
2387
2388rwlock *
2389rwlock_new()
2390{
2391  extern int cache_block_size;
2392
2393  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2394  rwlock *rw = NULL;;
2395 
2396  if (p) {
2397    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2398    rw->malloced_ptr = p;
2399#ifndef USE_FUTEX
2400    rw->reader_signal = new_semaphore(0);
2401    rw->writer_signal = new_semaphore(0);
2402    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2403      if (rw->reader_signal) {
2404        destroy_semaphore(&(rw->reader_signal));
2405      } else {
2406        destroy_semaphore(&(rw->writer_signal));
2407      }
2408      free(rw);
2409      rw = NULL;
2410    }
2411#endif
2412  }
2413  return rw;
2414}
2415
2416     
2417/*
2418  Try to get read access to a multiple-readers/single-writer lock.  If
2419  we already have read access, return success (indicating that the
2420  lock is held another time.  If we already have write access to the
2421  lock ... that won't work; return EDEADLK.  Wait until no other
2422  thread has or is waiting for write access, then indicate that we
2423  hold read access once.
2424*/
2425#ifndef USE_FUTEX
2426int
2427rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2428{
2429  int err = 0;
2430 
2431  LOCK_SPINLOCK(rw->spin, tcr);
2432
2433  if (rw->writer == tcr) {
2434    RELEASE_SPINLOCK(rw->spin);
2435    return EDEADLK;
2436  }
2437
2438  while (rw->blocked_writers || (rw->state > 0)) {
2439    rw->blocked_readers++;
2440    RELEASE_SPINLOCK(rw->spin);
2441    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2442    LOCK_SPINLOCK(rw->spin,tcr);
2443    rw->blocked_readers--;
2444    if (err == EINTR) {
2445      err = 0;
2446    }
2447    if (err) {
2448      RELEASE_SPINLOCK(rw->spin);
2449      return err;
2450    }
2451  }
2452  rw->state--;
2453  RELEASE_SPINLOCK(rw->spin);
2454  return err;
2455}
2456#else
2457int
2458rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2459{
2460  natural waitval;
2461
2462  lock_futex(&rw->spin);
2463
2464  if (rw->writer == tcr) {
2465    unlock_futex(&rw->spin);
2466    return EDEADLOCK;
2467  }
2468  while (1) {
2469    if (rw->writer == NULL) {
2470      --rw->state;
2471      unlock_futex(&rw->spin);
2472      return 0;
2473    }
2474    rw->blocked_readers++;
2475    waitval = rw->reader_signal;
2476    unlock_futex(&rw->spin);
2477    futex_wait(&rw->reader_signal,waitval);
2478    lock_futex(&rw->spin);
2479    rw->blocked_readers--;
2480  }
2481  return 0;
2482}
2483#endif   
2484
2485
2486/*
2487  Try to obtain write access to the lock.
2488  It is an error if we already have read access, but it's hard to
2489  detect that.
2490  If we already have write access, increment the count that indicates
2491  that.
2492  Otherwise, wait until the lock is not held for reading or writing,
2493  then assert write access.
2494*/
2495
2496#ifndef USE_FUTEX
2497int
2498rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2499{
2500  int err = 0;
2501
2502  LOCK_SPINLOCK(rw->spin,tcr);
2503  if (rw->writer == tcr) {
2504    rw->state++;
2505    RELEASE_SPINLOCK(rw->spin);
2506    return 0;
2507  }
2508
2509  while (rw->state != 0) {
2510    rw->blocked_writers++;
2511    RELEASE_SPINLOCK(rw->spin);
2512    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2513    LOCK_SPINLOCK(rw->spin,tcr);
2514    rw->blocked_writers--;
2515    if (err == EINTR) {
2516      err = 0;
2517    }
2518    if (err) {
2519      RELEASE_SPINLOCK(rw->spin);
2520      return err;
2521    }
2522  }
2523  rw->state = 1;
2524  rw->writer = tcr;
2525  RELEASE_SPINLOCK(rw->spin);
2526  return err;
2527}
2528
2529#else
2530int
2531rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2532{
2533  int err = 0;
2534  natural waitval;
2535
2536  lock_futex(&rw->spin);
2537  if (rw->writer == tcr) {
2538    rw->state++;
2539    unlock_futex(&rw->spin);
2540    return 0;
2541  }
2542
2543  while (rw->state != 0) {
2544    rw->blocked_writers++;
2545    waitval = rw->writer_signal;
2546    unlock_futex(&rw->spin);
2547    futex_wait(&rw->writer_signal,waitval);
2548    lock_futex(&rw->spin);
2549    rw->blocked_writers--;
2550  }
2551  rw->state = 1;
2552  rw->writer = tcr;
2553  unlock_futex(&rw->spin);
2554  return err;
2555}
2556#endif
2557
2558/*
2559  Sort of the same as above, only return EBUSY if we'd have to wait.
2560*/
2561#ifndef USE_FUTEX
2562int
2563rwlock_try_wlock(rwlock *rw, TCR *tcr)
2564{
2565  int ret = EBUSY;
2566
2567  LOCK_SPINLOCK(rw->spin,tcr);
2568  if (rw->writer == tcr) {
2569    rw->state++;
2570    ret = 0;
2571  } else {
2572    if (rw->state == 0) {
2573      rw->writer = tcr;
2574      rw->state = 1;
2575      ret = 0;
2576    }
2577  }
2578  RELEASE_SPINLOCK(rw->spin);
2579  return ret;
2580}
2581#else
2582int
2583rwlock_try_wlock(rwlock *rw, TCR *tcr)
2584{
2585  int ret = EBUSY;
2586
2587  lock_futex(&rw->spin);
2588  if (rw->writer == tcr) {
2589    rw->state++;
2590    ret = 0;
2591  } else {
2592    if (rw->state == 0) {
2593      rw->writer = tcr;
2594      rw->state = 1;
2595      ret = 0;
2596    }
2597  }
2598  unlock_futex(&rw->spin);
2599  return ret;
2600}
2601#endif
2602
2603#ifndef USE_FUTEX
2604int
2605rwlock_try_rlock(rwlock *rw, TCR *tcr)
2606{
2607  int ret = EBUSY;
2608
2609  LOCK_SPINLOCK(rw->spin,tcr);
2610  if (rw->state <= 0) {
2611    --rw->state;
2612    ret = 0;
2613  }
2614  RELEASE_SPINLOCK(rw->spin);
2615  return ret;
2616}
2617#else
2618int
2619rwlock_try_rlock(rwlock *rw, TCR *tcr)
2620{
2621  int ret = EBUSY;
2622
2623  lock_futex(&rw->spin);
2624  if (rw->state <= 0) {
2625    --rw->state;
2626    ret = 0;
2627  }
2628  unlock_futex(&rw->spin);
2629  return ret;
2630}
2631#endif
2632
2633
2634
2635#ifndef USE_FUTEX
2636int
2637rwlock_unlock(rwlock *rw, TCR *tcr)
2638{
2639
2640  int err = 0;
2641  natural blocked_readers = 0;
2642
2643  LOCK_SPINLOCK(rw->spin,tcr);
2644  if (rw->state > 0) {
2645    if (rw->writer != tcr) {
2646      err = EINVAL;
2647    } else {
2648      --rw->state;
2649      if (rw->state == 0) {
2650        rw->writer = NULL;
2651      }
2652    }
2653  } else {
2654    if (rw->state < 0) {
2655      ++rw->state;
2656    } else {
2657      err = EINVAL;
2658    }
2659  }
2660  if (err) {
2661    RELEASE_SPINLOCK(rw->spin);
2662    return err;
2663  }
2664 
2665  if (rw->state == 0) {
2666    if (rw->blocked_writers) {
2667      SEM_RAISE(rw->writer_signal);
2668    } else {
2669      blocked_readers = rw->blocked_readers;
2670      if (blocked_readers) {
2671        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2672      }
2673    }
2674  }
2675  RELEASE_SPINLOCK(rw->spin);
2676  return 0;
2677}
2678#else
2679int
2680rwlock_unlock(rwlock *rw, TCR *tcr)
2681{
2682
2683  int err = 0;
2684
2685  lock_futex(&rw->spin);
2686  if (rw->state > 0) {
2687    if (rw->writer != tcr) {
2688      err = EINVAL;
2689    } else {
2690      --rw->state;
2691      if (rw->state == 0) {
2692        rw->writer = NULL;
2693      }
2694    }
2695  } else {
2696    if (rw->state < 0) {
2697      ++rw->state;
2698    } else {
2699      err = EINVAL;
2700    }
2701  }
2702  if (err) {
2703    unlock_futex(&rw->spin);
2704    return err;
2705  }
2706 
2707  if (rw->state == 0) {
2708    if (rw->blocked_writers) {
2709      ++rw->writer_signal;
2710      unlock_futex(&rw->spin);
2711      futex_wake(&rw->writer_signal,1);
2712      return 0;
2713    }
2714    if (rw->blocked_readers) {
2715      ++rw->reader_signal;
2716      unlock_futex(&rw->spin);
2717      futex_wake(&rw->reader_signal, INT_MAX);
2718      return 0;
2719    }
2720  }
2721  unlock_futex(&rw->spin);
2722  return 0;
2723}
2724#endif
2725
2726       
2727void
2728rwlock_destroy(rwlock *rw)
2729{
2730#ifndef USE_FUTEX
2731  destroy_semaphore((void **)&rw->reader_signal);
2732  destroy_semaphore((void **)&rw->writer_signal);
2733#endif
2734  free((void *)(rw->malloced_ptr));
2735}
2736
2737
2738
2739
Note: See TracBrowser for help on using the repository browser.