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

Last change on this file since 15438 was 15438, checked in by gb, 7 years ago

allocate_tcr(): always do Mach port stuff on Darwin.

  • 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  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
1549    TCR_AUX(tcr)->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1550  }
1551#ifdef LINUX
1552#ifdef PPC
1553#ifndef PPC64
1554  tcr->native_thread_info = current_r2;
1555#endif
1556#endif
1557#endif
1558  TCR_AUX(tcr)->errno_loc = (int *)(&errno);
1559  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1560#ifdef DARWIN
1561  extern Boolean use_mach_exception_handling;
1562  if (use_mach_exception_handling) {
1563    darwin_exception_init(tcr);
1564  }
1565#endif
1566#ifdef LINUX
1567  linux_exception_init(tcr);
1568#endif
1569#ifdef WINDOWS
1570  TCR_AUX(tcr)->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
1571  TCR_AUX(tcr)->native_thread_info = malloc(sizeof(CONTEXT));
1572#endif
1573  TCR_AUX(tcr)->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1574}
1575
1576/*
1577  Register the specified tcr as "belonging to" the current thread.
1578  Under Darwin, setup Mach exception handling for the thread.
1579  Install cleanup handlers for thread termination.
1580*/
1581void
1582register_thread_tcr(TCR *tcr)
1583{
1584  void *stack_base = NULL;
1585  natural stack_size = 0;
1586
1587  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1588  thread_init_tcr(tcr, stack_base, stack_size);
1589  enqueue_tcr(tcr);
1590}
1591
1592
1593 
1594 
1595
1596Ptr
1597create_stack(natural size)
1598{
1599  Ptr p;
1600  size=align_to_power_of_2(size, log2_page_size);
1601  p = (Ptr) MapMemoryForStack((size_t)size);
1602  if (p != (Ptr)(-1)) {
1603    *((size_t *)p) = size;
1604    return p;
1605  }
1606  allocation_failure(true, size);
1607  return NULL;
1608}
1609
1610void *
1611allocate_stack(natural size)
1612{
1613  return create_stack(size);
1614}
1615
1616void
1617free_stack(void *s)
1618{
1619  size_t size = *((size_t *)s);
1620  UnMapMemory(s, size);
1621}
1622
1623Boolean threads_initialized = false;
1624
1625#ifndef USE_FUTEX
1626#ifdef WINDOWS
1627void
1628count_cpus()
1629{
1630  SYSTEM_INFO si;
1631
1632  GetSystemInfo(&si);
1633  if (si.dwNumberOfProcessors > 1) {
1634    spin_lock_tries = 1024;
1635  }
1636}
1637#else
1638void
1639count_cpus()
1640{
1641  int n = sysconf(_SC_NPROCESSORS_CONF);
1642 
1643  if (n > 1) {
1644    spin_lock_tries = 1024;
1645  }
1646}
1647#endif
1648#endif
1649
1650void
1651init_threads(void * stack_base, TCR *tcr)
1652{
1653  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1654#ifdef WINDOWS
1655  lisp_global(TCR_KEY) = TlsAlloc();
1656  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1657  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
1658#else
1659  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1660  thread_signal_setup();
1661#endif
1662
1663#ifndef USE_FUTEX
1664  count_cpus();
1665#endif
1666  threads_initialized = true;
1667}
1668
1669
1670#ifdef WINDOWS
1671unsigned CALLBACK
1672#else
1673void *
1674#endif
1675lisp_thread_entry(void *param)
1676{
1677  thread_activation *activation = (thread_activation *)param;
1678  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1679  LispObj *start_vsp;
1680#ifndef WINDOWS
1681  sigset_t mask, old_mask;
1682
1683  sigemptyset(&mask);
1684  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1685#endif
1686
1687  register_thread_tcr(tcr);
1688
1689#ifndef WINDOWS
1690  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1691#endif
1692  tcr->vs_area->active -= node_size;
1693  *(--tcr->save_vsp) = lisp_nil;
1694  start_vsp = tcr->save_vsp;
1695  enable_fp_exceptions();
1696  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1697  activation->tcr = tcr;
1698  SEM_RAISE(activation->created);
1699  do {
1700    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1701    SEM_WAIT_FOREVER(TCR_AUX(tcr)->activate);
1702    /* Now go run some lisp code */
1703    start_lisp(TCR_TO_TSD(tcr),0);
1704    tcr->save_vsp = start_vsp;
1705  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1706#ifndef WINDOWS
1707  pthread_cleanup_pop(true);
1708#else
1709  tcr_cleanup(tcr);
1710#endif
1711#ifdef WINDOWS
1712  return 0;
1713#else
1714  return NULL;
1715#endif
1716}
1717
1718typedef 
1719short (*suspendf)();
1720
1721
1722void
1723suspend_current_cooperative_thread()
1724{
1725  static suspendf cooperative_suspend = NULL;
1726  void *xFindSymbol(void*,char*);
1727
1728  if (cooperative_suspend == NULL) {
1729    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
1730  }
1731  if (cooperative_suspend) {
1732    cooperative_suspend(1 /* kCurrentThreadID */,
1733                        1 /* kStoppedThreadState */,
1734                        0 /* kAnyThreadID */);
1735  }
1736}
1737
1738void *
1739cooperative_thread_startup(void *arg)
1740{
1741
1742  TCR *tcr = get_tcr(0);
1743  LispObj *start_vsp;
1744
1745  if (!tcr) {
1746    return NULL;
1747  }
1748#ifndef WINDOWS
1749  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1750#endif
1751  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1752  start_vsp = tcr->save_vsp;
1753  do {
1754    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1755    suspend_current_cooperative_thread();
1756     
1757    start_lisp(tcr, 0);
1758    tcr->save_vsp = start_vsp;
1759  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1760#ifndef WINDOWS
1761  pthread_cleanup_pop(true);
1762#else
1763  tcr_cleanup(tcr);
1764#endif
1765  return NULL;
1766}
1767
1768void *
1769xNewThread(natural control_stack_size,
1770           natural value_stack_size,
1771           natural temp_stack_size)
1772
1773{
1774  thread_activation activation;
1775
1776
1777  activation.tsize = temp_stack_size;
1778  activation.vsize = value_stack_size;
1779  activation.tcr = 0;
1780  activation.created = new_semaphore(0);
1781  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1782                           NULL, 
1783                           lisp_thread_entry,
1784                           (void *) &activation)) {
1785   
1786    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1787  }
1788  destroy_semaphore(&activation.created); 
1789
1790#ifdef USE_DTRACE
1791  if (CCL_CREATE_THREAD_ENABLED() && activation.tcr) {
1792    CCL_CREATE_THREAD(activation.tcr->osid);
1793  }
1794#endif
1795
1796  return TCR_TO_TSD(activation.tcr);
1797}
1798
1799Boolean
1800active_tcr_p(TCR *q)
1801{
1802  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1803 
1804  do {
1805    if (p == q) {
1806      return true;
1807    }
1808    p = TCR_AUX(p)->next;
1809  } while (p != head);
1810  return false;
1811}
1812
1813
1814OSErr
1815xDisposeThread(TCR *tcr)
1816{
1817  return 0;                     /* I don't think that this is ever called. */
1818}
1819
1820OSErr
1821xYieldToThread(TCR *target)
1822{
1823  Bug(NULL, "xYieldToThread ?");
1824  return 0;
1825}
1826 
1827OSErr
1828xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1829{
1830  Bug(NULL, "xThreadCurrentStackSpace ?");
1831  return 0;
1832}
1833
1834
1835#ifdef WINDOWS
1836Boolean
1837create_system_thread(size_t stack_size,
1838                     void* stackaddr,
1839                     unsigned CALLBACK (*start_routine)(void *),
1840                     void* param)
1841{
1842  HANDLE thread_handle;
1843  Boolean won = false;
1844
1845  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1846
1847  thread_handle = (HANDLE)_beginthreadex(NULL, 
1848                                         stack_size,
1849                                         start_routine,
1850                                         param,
1851                                         0, 
1852                                         NULL);
1853
1854  if (thread_handle == NULL) {
1855    wperror("CreateThread");
1856  } else {
1857    won = true;
1858    CloseHandle(thread_handle);
1859  }
1860  return won;
1861}
1862#else
1863Boolean
1864create_system_thread(size_t stack_size,  void *stackaddr,
1865                     void *(*start_routine)(void *), void *param)
1866{
1867  pthread_attr_t attr;
1868  pthread_t returned_thread;
1869  int err;
1870  TCR *current = get_tcr(true);
1871
1872  pthread_attr_init(&attr);
1873  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1874
1875  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1876    stack_size = PTHREAD_STACK_MIN;
1877  }
1878
1879  stack_size = ensure_stack_limit(stack_size);
1880  if (stackaddr != NULL) {
1881    /* Size must have been specified.  Sort of makes sense ... */
1882    pthread_attr_setstack(&attr, stackaddr, stack_size);
1883  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1884    pthread_attr_setstacksize(&attr,stack_size);
1885  }
1886
1887  /*
1888     I think that's just about enough ... create the thread.
1889     Well ... not quite enough.  In Leopard (at least), many
1890     pthread routines grab an internal spinlock when validating
1891     their arguments.  If we suspend a thread that owns this
1892     spinlock, we deadlock.  We can't in general keep that
1893     from happening: if arbitrary C code is suspended while
1894     it owns the spinlock, we still deadlock.  It seems that
1895     the best that we can do is to keep -this- code from
1896     getting suspended (by grabbing TCR_AREA_LOCK)
1897  */
1898  LOCK(lisp_global(TCR_AREA_LOCK),current);
1899  err = pthread_create(&returned_thread, &attr, start_routine, param);
1900  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1901  pthread_attr_destroy(&attr);
1902  return (err == 0);
1903}
1904#endif
1905
1906TCR *
1907get_tcr(Boolean create)
1908{
1909#ifdef HAVE_TLS
1910  TCR *current = current_tcr;
1911#elif defined(WIN_32)
1912  TCR *current = ((TCR *)((char *)NtCurrentTeb() + TCR_BIAS))->linear;
1913#else
1914  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1915  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1916#endif
1917
1918  if ((current == NULL) && create) {
1919    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1920      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1921    int i, nbindwords = 0;
1922    extern natural initial_stack_size;
1923   
1924    /* Make one. */
1925    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1926    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1927    register_thread_tcr(current);
1928#ifdef DEBUG_TCR_CREATION
1929#ifndef WINDOWS
1930    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
1931#endif
1932#endif
1933    current->vs_area->active -= node_size;
1934    *(--current->save_vsp) = lisp_nil;
1935#ifdef PPC
1936#define NSAVEREGS 8
1937#endif
1938#ifdef X8664
1939#define NSAVEREGS 4
1940#endif
1941#ifdef X8632
1942#define NSAVEREGS 0
1943#endif
1944#ifdef ARM
1945#define NSAVEREGS 0
1946#endif
1947    for (i = 0; i < NSAVEREGS; i++) {
1948      *(--current->save_vsp) = 0;
1949      current->vs_area->active -= node_size;
1950    }
1951    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1952    for (i = 0; i < nbindwords; i++) {
1953      *(--current->save_vsp) = 0;
1954      current->vs_area->active -= node_size;
1955    }
1956    TCR_AUX(current)->shutdown_count = 1;
1957    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1958
1959  }
1960 
1961  return current;
1962}
1963
1964#ifdef WINDOWS
1965void *
1966pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
1967{
1968  /* Thread has started to return from an exception. */
1969  if (where < restore_windows_context_iret) {
1970    /* In the process of restoring registers; context still in
1971       %rcx.  Just make our suspend_context be the context
1972       we're trying to restore, so that we'll resume from
1973       the suspend in the same context that we're trying to
1974       restore */
1975#ifdef WIN_64
1976    *pcontext = * (CONTEXT *)(pcontext->Rcx);
1977#else
1978    if (where == restore_windows_context_start) {
1979      *pcontext = * (CONTEXT *)((pcontext->Esp)+4);
1980    } else {
1981      *pcontext = * (CONTEXT *)(pcontext->Ecx);
1982    }
1983#endif
1984  } else {
1985    /* Most of the context has already been restored; fix %rcx
1986       if need be, then restore ss:rsp, cs:rip, and flags. */
1987#ifdef WIN_64
1988    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1989
1990    pcontext->Rip = iret_frame->Rip;
1991    pcontext->SegCs = (WORD) iret_frame->Cs;
1992    pcontext->EFlags = (DWORD) iret_frame->Rflags;
1993    pcontext->Rsp = iret_frame->Rsp;
1994    pcontext->SegSs = (WORD) iret_frame->Ss;
1995#else
1996    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
1997
1998    pcontext->Eip = iret_frame->Eip;
1999    pcontext->SegCs = (WORD) iret_frame->Cs;
2000    pcontext->EFlags = (DWORD) iret_frame->EFlags;
2001    pcontext->Esp += sizeof(ia32_iret_frame);
2002#endif
2003  }
2004  tcr->pending_exception_context = NULL;
2005  /* We basically never return from an exception unless we
2006     were executing lisp code when the exception returned.
2007     If that ever changes, we need to know what valence
2008     would have been restored here.*/
2009  tcr->valence = TCR_STATE_LISP;
2010}
2011
2012Boolean
2013suspend_tcr(TCR *tcr)
2014{
2015  int suspend_count = atomic_incf(&(TCR_AUX(tcr)->suspend_count));
2016  DWORD rc;
2017  if (suspend_count == 1) {
2018    CONTEXT  *pcontext = (CONTEXT *)TCR_AUX(tcr)->native_thread_info;
2019    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
2020    pc where;
2021    area *cs = TCR_AUX(tcr)->cs_area;
2022    LispObj foreign_rsp;
2023
2024    if (hthread == NULL) {
2025      return false;
2026    }
2027    rc = SuspendThread(hthread);
2028    if (rc == -1) {
2029      /* If the thread's simply dead, we should handle that here */
2030      return false;
2031    }
2032    pcontext->ContextFlags = CONTEXT_ALL;
2033    rc = GetThreadContext(hthread, pcontext);
2034    if (rc == 0) {
2035      return false;
2036    }
2037    where = (pc)(xpPC(pcontext));
2038
2039    if ((where >= restore_windows_context_start) &&
2040        (where < restore_windows_context_end) &&
2041        (tcr->valence != TCR_STATE_LISP)) {
2042#ifdef WIN_64
2043      tcr->valence = xpGPR(pcontext,REG_R8);
2044#else
2045      tcr->valence = ((LispObj *)(xpGPR(pcontext,Isp)))[3];
2046#endif
2047      pcontext = tcr->pending_exception_context;
2048      tcr->pending_exception_context = NULL; 
2049      where = (pc)(xpPC(pcontext));
2050    }
2051    if (tcr->valence == TCR_STATE_LISP) {
2052      if ((where >= restore_windows_context_start) &&
2053          (where < restore_windows_context_end)) {
2054        pc_luser_restore_windows_context(pcontext, tcr, where);
2055      } else {
2056        area *ts = tcr->ts_area;
2057        /* If we're in the lisp heap, or in x86-spentry??.o, or in
2058           x86-subprims??.o, or in the subprims jump table at #x15000,
2059           or on the tstack ... we're just executing lisp code.  Otherwise,
2060           we got an exception while executing lisp code, but haven't
2061           entered the handler yet (still in Windows exception glue
2062           or switching stacks or something.)  In the latter case, we
2063           basically want to get to he handler and have it notice
2064           the pending exception request, and suspend the thread at that
2065           point. */
2066        if (!((where < (pc)lisp_global(HEAP_END)) &&
2067              (where >= (pc)lisp_global(HEAP_START))) &&
2068            (!((where < (pc)(managed_static_area->active)) &&
2069              (where >= (pc)(readonly_area->low)))) &&
2070            !((where < spentry_end) && (where >= spentry_start)) &&
2071            !((where < subprims_end) && (where >= subprims_start)) &&
2072            !((where < (pc) 0x16000) &&
2073              (where >= (pc) 0x15000)) &&
2074            !((where < (pc) (ts->high)) &&
2075              (where >= (pc) (ts->low)))) {
2076          /* The thread has lisp valence, but is not executing code
2077             where we expect lisp code to be and is not exiting from
2078             an exception handler.  That pretty much means that it's
2079             on its way into an exception handler; we have to handshake
2080             until it enters an exception-wait state. */
2081          /* There are likely race conditions here */
2082          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2083          ResumeThread(hthread);
2084          SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2085          pcontext = NULL;
2086        }
2087      }
2088    }
2089    /* If we're really running lisp code, there's some reason to
2090       suspect that Windows is lying about that; the thread may have
2091       already committed to processing an exception and just not have
2092       reentered user mode.  If there's a way to determine that more
2093       reliably, I don't know what it is.  We can catch some cases of
2094       that by looking at whether the PC is at a UUO or other
2095       "intentional" illegal instruction and letting the thread enter
2096       exception handling, treating this case just like the case
2097       above. 
2098
2099       When people say that Windows sucks, they aren't always just
2100       talking about all of the other ways that it sucks.
2101    */
2102    if ((*where == INTN_OPCODE) ||
2103        ((*where == XUUO_OPCODE_0) && (where[1] == XUUO_OPCODE_1))) {
2104      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2105      ResumeThread(hthread);
2106      SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2107      pcontext = NULL;
2108    }
2109    TCR_AUX(tcr)->suspend_context = pcontext;
2110    return true;
2111  }
2112  return false;
2113}
2114#else
2115Boolean
2116suspend_tcr(TCR *tcr)
2117{
2118  int suspend_count = atomic_incf(&(tcr->suspend_count));
2119  pthread_t thread;
2120  if (suspend_count == 1) {
2121    thread = (pthread_t)(tcr->osid);
2122    if ((thread != (pthread_t) 0) &&
2123        (pthread_kill(thread, thread_suspend_signal) == 0)) {
2124      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2125    } else {
2126      /* A problem using pthread_kill.  On Darwin, this can happen
2127         if the thread has had its signal mask surgically removed
2128         by pthread_exit.  If the native (Mach) thread can be suspended,
2129         do that and return true; otherwise, flag the tcr as belonging
2130         to a dead thread by setting tcr->osid to 0.
2131      */
2132      tcr->osid = 0;
2133      return false;
2134    }
2135    return true;
2136  }
2137  return false;
2138}
2139#endif
2140
2141#ifdef WINDOWS
2142Boolean
2143tcr_suspend_ack(TCR *tcr)
2144{
2145  return true;
2146}
2147#else
2148Boolean
2149tcr_suspend_ack(TCR *tcr)
2150{
2151  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
2152    SEM_WAIT_FOREVER(tcr->suspend);
2153    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2154  }
2155  return true;
2156}
2157#endif
2158     
2159
2160Boolean
2161kill_tcr(TCR *tcr)
2162{
2163  TCR *current = get_tcr(true);
2164  Boolean result = false;
2165
2166  LOCK(lisp_global(TCR_AREA_LOCK),current);
2167  {
2168    LispObj osid = TCR_AUX(tcr)->osid;
2169   
2170    if (osid) {
2171      result = true;
2172#ifdef WINDOWS
2173      /* What we really want to do here is (something like)
2174         forcing the thread to run quit_handler().  For now,
2175         mark the TCR as dead and kill the Windows thread. */
2176      /* xxx TerminateThread() bad */
2177      TCR_AUX(tcr)->osid = 0;
2178      if (!TerminateThread((HANDLE)osid, 0)) {
2179        CloseHandle((HANDLE)osid);
2180        result = false;
2181      } else {
2182        CloseHandle((HANDLE)osid);
2183        shutdown_thread_tcr(tcr);
2184      }
2185#else
2186      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2187        result = false;
2188      }
2189#endif
2190    }
2191  }
2192  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2193  return result;
2194}
2195
2196Boolean
2197lisp_suspend_tcr(TCR *tcr)
2198{
2199  Boolean suspended;
2200  TCR *current = get_tcr(true);
2201 
2202  LOCK(lisp_global(TCR_AREA_LOCK),current);
2203  suspended = suspend_tcr(tcr);
2204  if (suspended) {
2205    while (!tcr_suspend_ack(tcr));
2206  }
2207  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2208  return suspended;
2209}
2210         
2211#ifdef WINDOWS
2212Boolean
2213resume_tcr(TCR *tcr)
2214{
2215  int suspend_count = atomic_decf(&(TCR_AUX(tcr)->suspend_count)), err;
2216  DWORD rc;
2217  if (suspend_count == 0) {
2218    CONTEXT *context = TCR_AUX(tcr)->suspend_context;
2219    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
2220
2221
2222    TCR_AUX(tcr)->suspend_context = NULL;
2223    if (context) {
2224      if (tcr->valence == TCR_STATE_LISP) {
2225        rc = SetThreadContext(hthread,context);
2226        if (! rc) {
2227          Bug(NULL,"SetThreadContext");
2228          return false;
2229        }
2230      }
2231      rc = ResumeThread(hthread);
2232      if (rc == -1) {
2233        Bug(NULL,"ResumeThread");
2234        return false;
2235      }
2236      return true;
2237    } else {
2238      SEM_RAISE(TCR_AUX(tcr)->resume);
2239      return true;
2240    }
2241  }
2242  return false;
2243}   
2244#else
2245Boolean
2246resume_tcr(TCR *tcr)
2247{
2248  int suspend_count = atomic_decf(&(tcr->suspend_count));
2249  if (suspend_count == 0) {
2250    void *s = (tcr->resume);
2251    if (s != NULL) {
2252      SEM_RAISE(s);
2253      return true;
2254    }
2255  }
2256  return false;
2257}
2258#endif
2259
2260   
2261
2262
2263Boolean
2264lisp_resume_tcr(TCR *tcr)
2265{
2266  Boolean resumed;
2267  TCR *current = get_tcr(true);
2268 
2269  LOCK(lisp_global(TCR_AREA_LOCK),current);
2270  resumed = resume_tcr(tcr);
2271  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2272  return resumed;
2273}
2274
2275
2276TCR *freed_tcrs = NULL;
2277
2278void
2279enqueue_freed_tcr (TCR *tcr)
2280{
2281#ifndef HAVE_TLS
2282  TCR_AUX(tcr)->next = freed_tcrs;
2283  freed_tcrs = tcr;
2284#endif
2285}
2286
2287/* It's not clear that we can safely condemn a dead tcr's areas, since
2288   we may not be able to call free() if a suspended thread owns a
2289   malloc lock. At least make the areas appear to be empty.
2290*/
2291   
2292
2293void
2294normalize_dead_tcr_areas(TCR *tcr)
2295{
2296  area *a;
2297
2298  a = tcr->vs_area;
2299  if (a) {
2300    a->active = a->high;
2301  }
2302
2303#ifndef ARM
2304  a = tcr->ts_area;
2305  if (a) {
2306    a->active = a->high;
2307  }
2308#endif
2309
2310  a = TCR_AUX(tcr)->cs_area;
2311  if (a) {
2312    a->active = a->high;
2313  }
2314}
2315   
2316void
2317free_freed_tcrs ()
2318{
2319#ifdef DARWIN64
2320  extern void darwin_free_tcr(TCR *);
2321#endif
2322  TCR *current, *next;
2323
2324  for (current = freed_tcrs; current; current = next) {
2325    next = TCR_AUX(current)->next;
2326#ifndef HAVE_TLS
2327#ifdef WIN_32
2328    /* We sort of have TLS in that the TEB is per-thread.  We free the
2329     * tcr aux vector elsewhere. */
2330#else
2331#ifdef DARWIN64
2332    darwin_free_tcr(current);
2333#else
2334    free(current);
2335#endif
2336#endif
2337#endif
2338  }
2339  freed_tcrs = NULL;
2340}
2341
2342void
2343suspend_other_threads(Boolean for_gc)
2344{
2345  TCR *current = get_tcr(true), *other, *next;
2346  int dead_tcr_count = 0;
2347  Boolean all_acked;
2348
2349  LOCK(lisp_global(TCR_AREA_LOCK), current);
2350  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2351    if ((TCR_AUX(other)->osid != 0)) {
2352      suspend_tcr(other);
2353      if (TCR_AUX(other)->osid == 0) {
2354        dead_tcr_count++;
2355      }
2356    } else {
2357      dead_tcr_count++;
2358    }
2359  }
2360
2361  do {
2362    all_acked = true;
2363    for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2364      if ((TCR_AUX(other)->osid != 0)) {
2365        if (!tcr_suspend_ack(other)) {
2366          all_acked = false;
2367        }
2368      }
2369    }
2370  } while(! all_acked);
2371
2372     
2373
2374  /* All other threads are suspended; can safely delete dead tcrs now */
2375  if (dead_tcr_count) {
2376    for (other = TCR_AUX(current)->next; other != current; other = next) {
2377      next = TCR_AUX(other)->next;
2378      if (TCR_AUX(other)->osid == 0)  {
2379        normalize_dead_tcr_areas(other);
2380        dequeue_tcr(other);
2381        enqueue_freed_tcr(other);
2382      }
2383    }
2384  }
2385}
2386
2387void
2388lisp_suspend_other_threads()
2389{
2390  suspend_other_threads(false);
2391}
2392
2393void
2394resume_other_threads(Boolean for_gc)
2395{
2396  TCR *current = get_tcr(true), *other;
2397
2398  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2399    if ((TCR_AUX(other)->osid != 0)) {
2400      resume_tcr(other);
2401    }
2402  }
2403  free_freed_tcrs();
2404  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2405}
2406
2407void
2408lisp_resume_other_threads()
2409{
2410  resume_other_threads(false);
2411}
2412
2413
2414
2415rwlock *
2416rwlock_new()
2417{
2418  extern int cache_block_size;
2419
2420  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2421  rwlock *rw = NULL;;
2422 
2423  if (p) {
2424    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2425    rw->malloced_ptr = p;
2426#ifndef USE_FUTEX
2427    rw->reader_signal = new_semaphore(0);
2428    rw->writer_signal = new_semaphore(0);
2429    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2430      if (rw->reader_signal) {
2431        destroy_semaphore(&(rw->reader_signal));
2432      } else {
2433        destroy_semaphore(&(rw->writer_signal));
2434      }
2435      free(rw);
2436      rw = NULL;
2437    }
2438#endif
2439  }
2440  return rw;
2441}
2442
2443     
2444/*
2445  Try to get read access to a multiple-readers/single-writer lock.  If
2446  we already have read access, return success (indicating that the
2447  lock is held another time.  If we already have write access to the
2448  lock ... that won't work; return EDEADLK.  Wait until no other
2449  thread has or is waiting for write access, then indicate that we
2450  hold read access once.
2451*/
2452#ifndef USE_FUTEX
2453int
2454rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2455{
2456  int err = 0;
2457 
2458  LOCK_SPINLOCK(rw->spin, tcr);
2459
2460  if (rw->writer == tcr) {
2461    RELEASE_SPINLOCK(rw->spin);
2462    return EDEADLK;
2463  }
2464
2465  while (rw->blocked_writers || (rw->state > 0)) {
2466    rw->blocked_readers++;
2467    RELEASE_SPINLOCK(rw->spin);
2468    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2469    LOCK_SPINLOCK(rw->spin,tcr);
2470    rw->blocked_readers--;
2471    if (err == EINTR) {
2472      err = 0;
2473    }
2474    if (err) {
2475      RELEASE_SPINLOCK(rw->spin);
2476      return err;
2477    }
2478  }
2479  rw->state--;
2480  RELEASE_SPINLOCK(rw->spin);
2481  return err;
2482}
2483#else
2484int
2485rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2486{
2487  natural waitval;
2488
2489  lock_futex(&rw->spin);
2490
2491  if (rw->writer == tcr) {
2492    unlock_futex(&rw->spin);
2493    return EDEADLOCK;
2494  }
2495  while (1) {
2496    if (rw->writer == NULL) {
2497      --rw->state;
2498      unlock_futex(&rw->spin);
2499      return 0;
2500    }
2501    rw->blocked_readers++;
2502    waitval = rw->reader_signal;
2503    unlock_futex(&rw->spin);
2504    futex_wait(&rw->reader_signal,waitval);
2505    lock_futex(&rw->spin);
2506    rw->blocked_readers--;
2507  }
2508  return 0;
2509}
2510#endif   
2511
2512
2513/*
2514  Try to obtain write access to the lock.
2515  It is an error if we already have read access, but it's hard to
2516  detect that.
2517  If we already have write access, increment the count that indicates
2518  that.
2519  Otherwise, wait until the lock is not held for reading or writing,
2520  then assert write access.
2521*/
2522
2523#ifndef USE_FUTEX
2524int
2525rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2526{
2527  int err = 0;
2528
2529  LOCK_SPINLOCK(rw->spin,tcr);
2530  if (rw->writer == tcr) {
2531    rw->state++;
2532    RELEASE_SPINLOCK(rw->spin);
2533    return 0;
2534  }
2535
2536  while (rw->state != 0) {
2537    rw->blocked_writers++;
2538    RELEASE_SPINLOCK(rw->spin);
2539    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2540    LOCK_SPINLOCK(rw->spin,tcr);
2541    rw->blocked_writers--;
2542    if (err == EINTR) {
2543      err = 0;
2544    }
2545    if (err) {
2546      RELEASE_SPINLOCK(rw->spin);
2547      return err;
2548    }
2549  }
2550  rw->state = 1;
2551  rw->writer = tcr;
2552  RELEASE_SPINLOCK(rw->spin);
2553  return err;
2554}
2555
2556#else
2557int
2558rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2559{
2560  int err = 0;
2561  natural waitval;
2562
2563  lock_futex(&rw->spin);
2564  if (rw->writer == tcr) {
2565    rw->state++;
2566    unlock_futex(&rw->spin);
2567    return 0;
2568  }
2569
2570  while (rw->state != 0) {
2571    rw->blocked_writers++;
2572    waitval = rw->writer_signal;
2573    unlock_futex(&rw->spin);
2574    futex_wait(&rw->writer_signal,waitval);
2575    lock_futex(&rw->spin);
2576    rw->blocked_writers--;
2577  }
2578  rw->state = 1;
2579  rw->writer = tcr;
2580  unlock_futex(&rw->spin);
2581  return err;
2582}
2583#endif
2584
2585/*
2586  Sort of the same as above, only return EBUSY if we'd have to wait.
2587*/
2588#ifndef USE_FUTEX
2589int
2590rwlock_try_wlock(rwlock *rw, TCR *tcr)
2591{
2592  int ret = EBUSY;
2593
2594  LOCK_SPINLOCK(rw->spin,tcr);
2595  if (rw->writer == tcr) {
2596    rw->state++;
2597    ret = 0;
2598  } else {
2599    if (rw->state == 0) {
2600      rw->writer = tcr;
2601      rw->state = 1;
2602      ret = 0;
2603    }
2604  }
2605  RELEASE_SPINLOCK(rw->spin);
2606  return ret;
2607}
2608#else
2609int
2610rwlock_try_wlock(rwlock *rw, TCR *tcr)
2611{
2612  int ret = EBUSY;
2613
2614  lock_futex(&rw->spin);
2615  if (rw->writer == tcr) {
2616    rw->state++;
2617    ret = 0;
2618  } else {
2619    if (rw->state == 0) {
2620      rw->writer = tcr;
2621      rw->state = 1;
2622      ret = 0;
2623    }
2624  }
2625  unlock_futex(&rw->spin);
2626  return ret;
2627}
2628#endif
2629
2630#ifndef USE_FUTEX
2631int
2632rwlock_try_rlock(rwlock *rw, TCR *tcr)
2633{
2634  int ret = EBUSY;
2635
2636  LOCK_SPINLOCK(rw->spin,tcr);
2637  if (rw->state <= 0) {
2638    --rw->state;
2639    ret = 0;
2640  }
2641  RELEASE_SPINLOCK(rw->spin);
2642  return ret;
2643}
2644#else
2645int
2646rwlock_try_rlock(rwlock *rw, TCR *tcr)
2647{
2648  int ret = EBUSY;
2649
2650  lock_futex(&rw->spin);
2651  if (rw->state <= 0) {
2652    --rw->state;
2653    ret = 0;
2654  }
2655  unlock_futex(&rw->spin);
2656  return ret;
2657}
2658#endif
2659
2660
2661
2662#ifndef USE_FUTEX
2663int
2664rwlock_unlock(rwlock *rw, TCR *tcr)
2665{
2666
2667  int err = 0;
2668  natural blocked_readers = 0;
2669
2670  LOCK_SPINLOCK(rw->spin,tcr);
2671  if (rw->state > 0) {
2672    if (rw->writer != tcr) {
2673      err = EINVAL;
2674    } else {
2675      --rw->state;
2676      if (rw->state == 0) {
2677        rw->writer = NULL;
2678      }
2679    }
2680  } else {
2681    if (rw->state < 0) {
2682      ++rw->state;
2683    } else {
2684      err = EINVAL;
2685    }
2686  }
2687  if (err) {
2688    RELEASE_SPINLOCK(rw->spin);
2689    return err;
2690  }
2691 
2692  if (rw->state == 0) {
2693    if (rw->blocked_writers) {
2694      SEM_RAISE(rw->writer_signal);
2695    } else {
2696      blocked_readers = rw->blocked_readers;
2697      if (blocked_readers) {
2698        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2699      }
2700    }
2701  }
2702  RELEASE_SPINLOCK(rw->spin);
2703  return 0;
2704}
2705#else
2706int
2707rwlock_unlock(rwlock *rw, TCR *tcr)
2708{
2709
2710  int err = 0;
2711
2712  lock_futex(&rw->spin);
2713  if (rw->state > 0) {
2714    if (rw->writer != tcr) {
2715      err = EINVAL;
2716    } else {
2717      --rw->state;
2718      if (rw->state == 0) {
2719        rw->writer = NULL;
2720      }
2721    }
2722  } else {
2723    if (rw->state < 0) {
2724      ++rw->state;
2725    } else {
2726      err = EINVAL;
2727    }
2728  }
2729  if (err) {
2730    unlock_futex(&rw->spin);
2731    return err;
2732  }
2733 
2734  if (rw->state == 0) {
2735    if (rw->blocked_writers) {
2736      ++rw->writer_signal;
2737      unlock_futex(&rw->spin);
2738      futex_wake(&rw->writer_signal,1);
2739      return 0;
2740    }
2741    if (rw->blocked_readers) {
2742      ++rw->reader_signal;
2743      unlock_futex(&rw->spin);
2744      futex_wake(&rw->reader_signal, INT_MAX);
2745      return 0;
2746    }
2747  }
2748  unlock_futex(&rw->spin);
2749  return 0;
2750}
2751#endif
2752
2753       
2754void
2755rwlock_destroy(rwlock *rw)
2756{
2757#ifndef USE_FUTEX
2758  destroy_semaphore((void **)&rw->reader_signal);
2759  destroy_semaphore((void **)&rw->writer_signal);
2760#endif
2761  free((void *)(rw->malloced_ptr));
2762}
2763
2764
2765
2766#ifdef DARWIN
2767/* For debugging. */
2768int
2769mach_port_send_refs(mach_port_t port)
2770{
2771  mach_port_urefs_t nrefs;
2772  ipc_space_t task = mach_task_self();
2773 
2774  if (mach_port_get_refs(task,port,MACH_PORT_RIGHT_SEND,&nrefs) == KERN_SUCCESS) {
2775    return nrefs;
2776  }
2777  return -1;
2778}
2779#endif
2780
Note: See TracBrowser for help on using the repository browser.