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

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

pmcl-kernel.c: In register_cstack_holding_area_lock(), if stack is too

small for soft/hard protected areas, just set hard/soft limits to
physical limits and don't write-protect any regions (on architectures
that want to do this.)

thread_manager.c: even foreign TCR's need to set tcr->cs_limit, so that

rmark() doesn't exhaust the stack.

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