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

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

Use a cast in the code that sets up errno_loc in the TCR.
Revive jvm_init(), since Apple's JVM still/again clobbers Mach exception
ports.

Add kernel-import info for jvm-init for all architectures. (The kernel
import table isn't architecture-specific, though some entries effectively
are.)

Tweak jni.lisp a bit; still needs lots of work.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 60.2 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  postGCfree((void *)(m->malloced_ptr));
388}
389
390/*
391  If we're already the owner (or if the lock is free), lock it
392  and increment the lock count; otherwise, return EBUSY without
393  waiting.
394*/
395
396#ifndef USE_FUTEX
397int
398recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free)
399{
400  TCR *owner = m->owner;
401
402  LOCK_SPINLOCK(m->spinlock,tcr);
403  if (owner == tcr) {
404    m->count++;
405    if (was_free) {
406      *was_free = 0;
407      RELEASE_SPINLOCK(m->spinlock);
408      return 0;
409    }
410  }
411  if (store_conditional((natural*)&(m->avail), 0, 1) == 0) {
412    m->owner = tcr;
413    m->count = 1;
414    if (was_free) {
415      *was_free = 1;
416    }
417    RELEASE_SPINLOCK(m->spinlock);
418    return 0;
419  }
420
421  RELEASE_SPINLOCK(m->spinlock);
422  return EBUSY;
423}
424#else
425int
426recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free)
427{
428  TCR *owner = m->owner;
429
430  if (owner == tcr) {
431    m->count++;
432    if (was_free) {
433      *was_free = 0;
434      return 0;
435    }
436  }
437  if (store_conditional((natural*)&(m->avail), 0, 1) == 0) {
438    m->owner = tcr;
439    m->count = 1;
440    if (was_free) {
441      *was_free = 1;
442    }
443    return 0;
444  }
445
446  return EBUSY;
447}
448#endif
449
450void
451sem_wait_forever(SEMAPHORE s)
452{
453  int status;
454
455  do {
456#ifdef USE_MACH_SEMAPHORES
457    mach_timespec_t q = {1,0};
458    status = SEM_TIMEDWAIT(s,q);
459#endif
460#ifdef USE_POSIX_SEMAPHORES
461    struct timespec q;
462    gettimeofday((struct timeval *)&q, NULL);
463    q.tv_sec += 1;
464    status = SEM_TIMEDWAIT(s,&q);
465#endif
466#ifdef USE_WINDOWS_SEMAPHORES
467    status = (WaitForSingleObject(s,1000L) == WAIT_TIMEOUT) ? 1 : 0;
468#endif
469  } while (status != 0);
470}
471
472int
473wait_on_semaphore(void *s, int seconds, int millis)
474{
475#ifdef USE_POSIX_SEMAPHORES
476  int nanos = (millis % 1000) * 1000000;
477  int status;
478
479  struct timespec q;
480  gettimeofday((struct timeval *)&q, NULL);
481  q.tv_nsec *= 1000L;  /* microseconds -> nanoseconds */
482   
483  q.tv_nsec += nanos;
484  if (q.tv_nsec >= 1000000000L) {
485    q.tv_nsec -= 1000000000L;
486    seconds += 1;
487  }
488  q.tv_sec += seconds;
489  status = SEM_TIMEDWAIT(s, &q);
490  if (status < 0) {
491    return errno;
492  }
493  return status;
494#endif
495#ifdef USE_MACH_SEMAPHORES
496  int nanos = (millis % 1000) * 1000000;
497  mach_timespec_t q = {seconds, nanos};
498  int status = SEM_TIMEDWAIT(s, q);
499
500 
501  switch (status) {
502  case 0: return 0;
503  case KERN_OPERATION_TIMED_OUT: return ETIMEDOUT;
504  case KERN_ABORTED: return EINTR;
505  default: return EINVAL;
506  }
507#endif
508#ifdef USE_WINDOWS_SEMAPHORES
509  switch (WaitForSingleObjectEx(s, seconds*1000L+(DWORD)millis,true)) {
510  case WAIT_OBJECT_0:
511    return 0;
512  case WAIT_TIMEOUT:
513    return /* ETIMEDOUT */ WAIT_TIMEOUT;
514  case WAIT_IO_COMPLETION:
515    return EINTR;
516  default:
517    break;
518  }
519  return EINVAL;
520
521#endif
522}
523
524
525int
526semaphore_maybe_timedwait(void *s, struct timespec *t)
527{
528  if (t) {
529    return wait_on_semaphore(s, t->tv_sec, t->tv_nsec/1000000L);
530  }
531  SEM_WAIT_FOREVER(s);
532  return 0;
533}
534
535void
536signal_semaphore(SEMAPHORE s)
537{
538  SEM_RAISE(s);
539}
540
541 
542#ifdef WINDOWS
543LispObj
544current_thread_osid()
545{
546  TCR *tcr = get_tcr(false);
547  LispObj current = 0;
548
549  if (tcr) {
550    current = TCR_AUX(tcr)->osid;
551  }
552  if (current == 0) {
553    DuplicateHandle(GetCurrentProcess(),
554                    GetCurrentThread(),
555                    GetCurrentProcess(),
556                    (LPHANDLE)(&current),
557                    0,
558                    FALSE,
559                    DUPLICATE_SAME_ACCESS);
560    if (tcr) {
561      TCR_AUX(tcr)->osid = current;
562    }
563  }
564  return current;
565}
566#else
567LispObj
568current_thread_osid()
569{
570  return (LispObj)ptr_to_lispobj(pthread_self());
571}
572#endif
573
574
575int thread_suspend_signal = 0, thread_kill_signal = 0;
576
577
578
579void
580linux_exception_init(TCR *tcr)
581{
582}
583
584
585TCR *
586get_interrupt_tcr(Boolean create)
587{
588  return get_tcr(create);
589}
590 
591void
592suspend_resume_handler(int signo, siginfo_t *info, ExceptionInformation *context)
593{
594  TCR *tcr = get_interrupt_tcr(false);
595 
596  if (tcr == NULL) {
597    /* Got a suspend signal sent to the pthread. */
598    extern natural initial_stack_size;
599    void register_thread_tcr(TCR *);
600   
601    tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
602    TCR_AUX(tcr)->suspend_count = 1;
603    tcr->vs_area->active -= node_size;
604    *(--tcr->save_vsp) = lisp_nil;
605    register_thread_tcr(tcr);
606  }
607  if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<<fixnumshift)) {
608    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
609  } else {
610    TCR_AUX(tcr)->suspend_context = context;
611    SEM_RAISE(TCR_AUX(tcr)->suspend);
612    SEM_WAIT_FOREVER(TCR_AUX(tcr)->resume);
613    TCR_AUX(tcr)->suspend_context = NULL;
614  }
615  SIGRETURN(context);
616}
617
618 
619
620/*
621  'base' should be set to the bottom (origin) of the stack, e.g., the
622  end from which it grows.
623*/
624 
625#ifdef WINDOWS
626void
627os_get_current_thread_stack_bounds(void **base, natural *size)
628{
629  natural natbase;
630  MEMORY_BASIC_INFORMATION info;
631  void *addr = (void *)current_stack_pointer();
632 
633  VirtualQuery(addr, &info, sizeof(info));
634  natbase = (natural)info.BaseAddress+info.RegionSize;
635  *size = natbase - (natural)(info.AllocationBase);
636  *base = (void *)natbase;
637}
638#else
639void
640os_get_current_thread_stack_bounds(void **base, natural *size)
641{
642  pthread_t p = pthread_self();
643#ifdef DARWIN
644  *base = pthread_get_stackaddr_np(p);
645  *size = pthread_get_stacksize_np(p);
646#endif
647#ifdef LINUX
648  pthread_attr_t attr;
649
650  pthread_getattr_np(p,&attr);
651  pthread_attr_getstack(&attr, base, size);
652  pthread_attr_destroy(&attr);
653  *(natural *)base += *size;
654#endif
655#ifdef FREEBSD
656  pthread_attr_t attr;
657  void * temp_base;
658  size_t temp_size;
659 
660
661  pthread_attr_init(&attr); 
662  pthread_attr_get_np(p, &attr);
663  pthread_attr_getstackaddr(&attr,&temp_base);
664  pthread_attr_getstacksize(&attr,&temp_size);
665  *base = (void *)((natural)temp_base + temp_size);
666  *size = temp_size;
667  pthread_attr_destroy(&attr);
668#endif
669#ifdef SOLARIS
670  stack_t st;
671 
672  thr_stksegment(&st);
673  *size = st.ss_size;
674  *base = st.ss_sp;
675 
676#endif
677}
678#endif
679
680void *
681new_semaphore(int count)
682{
683#ifdef USE_POSIX_SEMAPHORES
684  sem_t *s = malloc(sizeof(sem_t));
685  sem_init(s, 0, count);
686  return s;
687#endif
688#ifdef USE_MACH_SEMAPHORES
689  semaphore_t s = (semaphore_t)0;
690  semaphore_create(mach_task_self(),&s, SYNC_POLICY_FIFO, count);
691  return (void *)(natural)s;
692#endif
693#ifdef USE_WINDOWS_SEMAPHORES
694  return CreateSemaphore(NULL, count, 0x7fffL, NULL);
695#endif
696}
697
698RECURSIVE_LOCK
699new_recursive_lock()
700{
701  extern int cache_block_size;
702  void *p = calloc(1,sizeof(_recursive_lock)+cache_block_size-1);
703  RECURSIVE_LOCK m = NULL;
704#ifndef USE_FUTEX
705  void *signal = new_semaphore(0);
706#endif
707  if (p) {
708    m = (RECURSIVE_LOCK) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
709    m->malloced_ptr = p;
710  }
711
712#ifdef USE_FUTEX
713  if (m) {
714    return m;
715  }
716#else
717  if (m && signal) {
718    m->signal = signal;
719    return m;
720  }
721  if (m) {
722    free(p);
723  }
724  if (signal) {
725    destroy_semaphore(&signal);
726  }
727#endif
728  return NULL;
729}
730
731void
732destroy_semaphore(void **s)
733{
734  if (*s) {
735#ifdef USE_POSIX_SEMAPHORES
736    sem_destroy((sem_t *)*s);
737    if (lisp_global(IN_GC)) {
738      postGCfree(*s);
739    } else {
740      free(*s);
741    }
742#endif
743#ifdef USE_MACH_SEMAPHORES
744    semaphore_destroy(mach_task_self(),((semaphore_t)(natural) *s));
745#endif
746#ifdef USE_WINDOWS_SEMAPHORES
747    CloseHandle(*s);
748#endif
749    *s=NULL;
750  }
751}
752
753#ifdef WINDOWS
754void
755tsd_set(LispObj key, void *datum)
756{
757  TlsSetValue((DWORD)key, datum);
758}
759
760void *
761tsd_get(LispObj key)
762{
763  return TlsGetValue((DWORD)key);
764}
765#else
766void
767tsd_set(LispObj key, void *datum)
768{
769  pthread_setspecific((pthread_key_t)key, datum);
770}
771
772void *
773tsd_get(LispObj key)
774{
775  return pthread_getspecific((pthread_key_t)key);
776}
777#endif
778
779void
780dequeue_tcr(TCR *tcr)
781{
782  TCR *next, *prev;
783
784  next = TCR_AUX(tcr)->next;
785  prev = TCR_AUX(tcr)->prev;
786
787  TCR_AUX(prev)->next = next;
788  TCR_AUX(next)->prev = prev;
789  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = NULL;
790#ifdef X86
791  tcr->linear = NULL;
792#endif
793}
794 
795void
796enqueue_tcr(TCR *new)
797{
798  TCR *head, *tail;
799 
800  LOCK(lisp_global(TCR_AREA_LOCK),new);
801  head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR));
802  tail = TCR_AUX(head)->prev;
803  TCR_AUX(tail)->next = new;
804  TCR_AUX(head)->prev = new;
805  TCR_AUX(new)->prev = tail;
806  TCR_AUX(new)->next = head;
807  UNLOCK(lisp_global(TCR_AREA_LOCK),new);
808}
809
810#ifdef WIN_32
811TCR *
812allocate_tcr()
813{
814  void *p = calloc(1,sizeof(struct tcr_aux));
815  char *teb = (char *)NtCurrentTeb();
816  TCR *tcr = (TCR *)(teb + TCR_BIAS);
817
818  if (p == NULL)
819    allocation_failure(true, sizeof(struct tcr_aux));
820
821  if ((intptr_t)p & 03) {
822    fprintf(dbgout, "%p not aligned\n", p);
823    exit(1);
824  }
825  memset(tcr, 0, sizeof(TCR));
826  tcr->aux = p;
827  return tcr;
828}
829#else
830TCR *
831allocate_tcr()
832{
833  TCR *tcr, *chain = NULL, *next;
834#ifdef DARWIN
835  extern Boolean use_mach_exception_handling;
836  kern_return_t kret;
837  mach_port_t
838    thread_exception_port,
839    task_self = mach_task_self();
840#endif
841  for (;;) {
842    tcr = calloc(1, sizeof(TCR));
843#ifdef DARWIN
844#if WORD_SIZE == 64
845    if (((unsigned)((natural)tcr)) != ((natural)tcr)) {
846      tcr->next = chain;
847      chain = tcr;
848      continue;
849    }
850#endif
851    if (use_mach_exception_handling) {
852      thread_exception_port = (mach_port_t)((natural)tcr);
853      kret = mach_port_allocate_name(task_self,
854                                     MACH_PORT_RIGHT_RECEIVE,
855                                     thread_exception_port);
856    } else {
857      kret = KERN_SUCCESS;
858    }
859
860    if (kret != KERN_SUCCESS) {
861      tcr->next = chain;
862      chain = tcr;
863      continue;
864    }
865#endif
866    for (;chain;chain = next) {
867      next = chain->next;
868      free(chain);
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
1246void
1247init_arm_tcr_sptab(TCR *tcr)
1248{
1249  extern LispObj *sptab;
1250  extern LispObj *sptab_end;
1251  LispObj *p, *q;
1252
1253  for (p=sptab,q = tcr->sptab;
1254       p<sptab_end;
1255       p++,q++) {
1256    *q = *p;
1257  }
1258}
1259#endif       
1260 
1261 
1262
1263
1264/*
1265  Caller must hold the area_lock.
1266*/
1267TCR *
1268new_tcr(natural vstack_size, natural tstack_size)
1269{
1270  extern area
1271    *allocate_vstack_holding_area_lock(natural),
1272    *allocate_tstack_holding_area_lock(natural);
1273  area *a;
1274  int i;
1275#ifndef WINDOWS
1276  sigset_t sigmask;
1277
1278  sigemptyset(&sigmask);
1279  pthread_sigmask(SIG_SETMASK,&sigmask, NULL);
1280#endif
1281
1282#ifdef HAVE_TLS
1283  TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15));
1284  current_tcr = tcr;
1285#else /* no TLS */
1286  TCR *tcr = allocate_tcr();
1287#endif
1288
1289#ifdef ARM
1290  init_arm_tcr_sptab(tcr);
1291#endif
1292#ifdef X86
1293  setup_tcr_extra_segment(tcr);
1294  tcr->linear = tcr;
1295#ifdef X8632
1296  tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK;
1297#endif
1298#endif
1299
1300#if (WORD_SIZE == 64)
1301  tcr->single_float_convert.tag = subtag_single_float;
1302#endif
1303  TCR_AUX(tcr)->suspend = new_semaphore(0);
1304  TCR_AUX(tcr)->resume = new_semaphore(0);
1305  TCR_AUX(tcr)->reset_completion = new_semaphore(0);
1306  TCR_AUX(tcr)->activate = new_semaphore(0);
1307  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1308  a = allocate_vstack_holding_area_lock(vstack_size);
1309  tcr->vs_area = a;
1310  a->owner = tcr;
1311  tcr->save_vsp = (LispObj *) a->active; 
1312#ifndef ARM
1313  a = allocate_tstack_holding_area_lock(tstack_size);
1314#endif
1315  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1316#ifndef ARM
1317  tcr->ts_area = a;
1318  a->owner = tcr;
1319  tcr->save_tsp = (LispObj *) a->active;
1320#endif
1321#ifdef X86
1322  tcr->next_tsp = tcr->save_tsp;
1323#endif
1324
1325  tcr->valence = TCR_STATE_FOREIGN;
1326#ifdef PPC
1327  tcr->lisp_fpscr.words.l = 0xd0;
1328#endif
1329#ifdef X86
1330  tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | 
1331#if 1                           /* Mask underflow; too hard to
1332                                   deal with denorms if underflow is
1333                                   enabled */
1334    (1 << MXCSR_UM_BIT) | 
1335#endif
1336    (1 << MXCSR_PM_BIT);
1337#endif
1338#ifdef ARM
1339  tcr->lisp_fpscr = 
1340    (1 << FPSCR_IOE_BIT) | 
1341    (1 << FPSCR_DZE_BIT) |
1342    (1 << FPSCR_OFE_BIT);
1343#endif
1344  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
1345  tcr->tlb_limit = 2048<<fixnumshift;
1346  tcr->tlb_pointer = (LispObj *)malloc(tcr->tlb_limit);
1347  for (i = 0; i < 2048; i++) {
1348    tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker;
1349  }
1350  TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<<fixnum_shift);
1351#ifndef WINDOWS
1352  tcr->shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS;
1353#else
1354  TCR_AUX(tcr)->shutdown_count = 1;
1355#endif
1356  return tcr;
1357}
1358
1359void
1360shutdown_thread_tcr(void *arg)
1361{
1362  TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0);
1363
1364  area *vs, *ts, *cs;
1365#ifdef DARWIN
1366  mach_port_t kernel_thread;
1367#endif
1368 
1369  if (current == NULL) {
1370    current = tcr;
1371  }
1372
1373  if (--(TCR_AUX(tcr)->shutdown_count) == 0) {
1374    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
1375      LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1376        callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1377   
1378      tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1379      ((void (*)())ptr_from_lispobj(callback_ptr))(1);
1380      tsd_set(lisp_global(TCR_KEY), NULL);
1381    }
1382#ifdef DARWIN
1383    darwin_exception_cleanup(tcr);
1384    kernel_thread = (mach_port_t) (uint32_t)(natural)( TCR_AUX(tcr)->native_thread_id);
1385#endif
1386    LOCK(lisp_global(TCR_AREA_LOCK),current);
1387    vs = tcr->vs_area;
1388    tcr->vs_area = NULL;
1389#ifndef ARM
1390    ts = tcr->ts_area;
1391    tcr->ts_area = NULL;
1392#endif
1393    cs = TCR_AUX(tcr)->cs_area;
1394    TCR_AUX(tcr)->cs_area = NULL;
1395    if (vs) {
1396      condemn_area_holding_area_lock(vs);
1397    }
1398#ifndef ARM
1399    if (ts) {
1400      condemn_area_holding_area_lock(ts);
1401    }
1402#endif
1403    if (cs) {
1404      condemn_area_holding_area_lock(cs);
1405    }
1406    /* On some platforms - currently just linuxarm - we have to
1407       allocate a separate alternate signal stack (rather than just
1408       using a few pages of the thread's main stack.)  Disable and
1409       free that alternate stack here.
1410    */
1411#ifdef ARM
1412#if defined(LINUX)
1413    {
1414      stack_t new, current;
1415      new.ss_flags = SS_DISABLE;
1416      if (sigaltstack(&new, &current) == 0) {
1417        munmap(current.ss_sp, current.ss_size);
1418      }
1419    }
1420#endif
1421#endif
1422    destroy_semaphore(&TCR_AUX(tcr)->suspend);
1423    destroy_semaphore(&TCR_AUX(tcr)->resume);
1424    destroy_semaphore(&TCR_AUX(tcr)->reset_completion);
1425    destroy_semaphore(&TCR_AUX(tcr)->activate);
1426    tcr->tlb_limit = 0;
1427    free(tcr->tlb_pointer);
1428    tcr->tlb_pointer = NULL;
1429#ifdef WINDOWS
1430    if (TCR_AUX(tcr)->osid != 0) {
1431      CloseHandle((HANDLE)(TCR_AUX(tcr)->osid));
1432    }
1433#endif
1434    TCR_AUX(tcr)->osid = 0;
1435    tcr->interrupt_pending = 0;
1436    TCR_AUX(tcr)->termination_semaphore = NULL;
1437#if defined(HAVE_TLS) || defined(WIN_32)
1438    dequeue_tcr(tcr);
1439#endif
1440#ifdef X8632
1441    free_tcr_extra_segment(tcr);
1442#endif
1443#ifdef WINDOWS
1444    CloseHandle((HANDLE)TCR_AUX(tcr)->io_datum);
1445    TCR_AUX(tcr)->io_datum = NULL;
1446    free(TCR_AUX(tcr)->native_thread_info);
1447    TCR_AUX(tcr)->native_thread_info = NULL;
1448#ifdef WIN_32
1449    free(tcr->aux);
1450    tcr->aux = NULL;
1451#endif
1452#endif
1453    UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1454#ifdef DARWIN
1455    {
1456      mach_port_urefs_t nrefs;
1457      ipc_space_t task = mach_task_self();
1458
1459      if (mach_port_get_refs(task,kernel_thread,MACH_PORT_RIGHT_SEND,&nrefs) == KERN_SUCCESS) {
1460        if (nrefs > 1) {
1461          mach_port_mod_refs(task,kernel_thread,MACH_PORT_RIGHT_SEND,-(nrefs-1));
1462        }
1463      }
1464    }
1465#endif
1466  } else {
1467    tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1468  }
1469}
1470
1471void
1472tcr_cleanup(void *arg)
1473{
1474  TCR *tcr = (TCR *)arg;
1475  area *a;
1476
1477  a = tcr->vs_area;
1478  if (a) {
1479    a->active = a->high;
1480  }
1481#ifndef ARM
1482  a = tcr->ts_area;
1483  if (a) {
1484    a->active = a->high;
1485  }
1486#endif
1487  a = TCR_AUX(tcr)->cs_area;
1488  if (a) {
1489    a->active = a->high;
1490  }
1491  tcr->valence = TCR_STATE_FOREIGN;
1492  TCR_AUX(tcr)->shutdown_count = 1;
1493  shutdown_thread_tcr(tcr);
1494  tsd_set(lisp_global(TCR_KEY), NULL);
1495}
1496
1497void *
1498current_native_thread_id()
1499{
1500  return ((void *) (natural)
1501#ifdef LINUX
1502#ifdef __NR_gettid
1503          syscall(__NR_gettid)
1504#else
1505          getpid()
1506#endif
1507#endif
1508#ifdef DARWIN
1509          pthread_mach_thread_np(pthread_self())
1510#endif
1511#ifdef FREEBSD
1512          pthread_self()
1513#endif
1514#ifdef SOLARIS
1515          pthread_self()
1516#endif
1517#ifdef WINDOWS
1518          GetCurrentThreadId()
1519#endif
1520          );
1521}
1522
1523
1524void
1525thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size)
1526{
1527  area *a, *register_cstack_holding_area_lock(BytePtr, natural);
1528
1529  TCR_AUX(tcr)->osid = current_thread_osid();
1530  TCR_AUX(tcr)->native_thread_id = current_native_thread_id();
1531  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1532  a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size);
1533  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1534  TCR_AUX(tcr)->cs_area = a;
1535  a->owner = tcr;
1536#ifdef ARM
1537  tcr->last_lisp_frame = (natural)(a->high);
1538#endif
1539  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
1540    TCR_AUX(tcr)->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1541  }
1542#ifdef LINUX
1543#ifdef PPC
1544#ifndef PPC64
1545  tcr->native_thread_info = current_r2;
1546#endif
1547#endif
1548#endif
1549  TCR_AUX(tcr)->errno_loc = (int *)(&errno);
1550  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1551#ifdef DARWIN
1552  extern Boolean use_mach_exception_handling;
1553  if (use_mach_exception_handling) {
1554    darwin_exception_init(tcr);
1555  }
1556#endif
1557#ifdef LINUX
1558  linux_exception_init(tcr);
1559#endif
1560#ifdef WINDOWS
1561  TCR_AUX(tcr)->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
1562  TCR_AUX(tcr)->native_thread_info = malloc(sizeof(CONTEXT));
1563#endif
1564  TCR_AUX(tcr)->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1565}
1566
1567/*
1568  Register the specified tcr as "belonging to" the current thread.
1569  Under Darwin, setup Mach exception handling for the thread.
1570  Install cleanup handlers for thread termination.
1571*/
1572void
1573register_thread_tcr(TCR *tcr)
1574{
1575  void *stack_base = NULL;
1576  natural stack_size = 0;
1577
1578  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1579  thread_init_tcr(tcr, stack_base, stack_size);
1580  enqueue_tcr(tcr);
1581}
1582
1583
1584 
1585 
1586
1587Ptr
1588create_stack(natural size)
1589{
1590  Ptr p;
1591  size=align_to_power_of_2(size, log2_page_size);
1592  p = (Ptr) MapMemoryForStack((size_t)size);
1593  if (p != (Ptr)(-1)) {
1594    *((size_t *)p) = size;
1595    return p;
1596  }
1597  allocation_failure(true, size);
1598  return NULL;
1599}
1600
1601void *
1602allocate_stack(natural size)
1603{
1604  return create_stack(size);
1605}
1606
1607void
1608free_stack(void *s)
1609{
1610  size_t size = *((size_t *)s);
1611  UnMapMemory(s, size);
1612}
1613
1614Boolean threads_initialized = false;
1615
1616#ifndef USE_FUTEX
1617#ifdef WINDOWS
1618void
1619count_cpus()
1620{
1621  SYSTEM_INFO si;
1622
1623  GetSystemInfo(&si);
1624  if (si.dwNumberOfProcessors > 1) {
1625    spin_lock_tries = 1024;
1626  }
1627}
1628#else
1629void
1630count_cpus()
1631{
1632  int n = sysconf(_SC_NPROCESSORS_CONF);
1633 
1634  if (n > 1) {
1635    spin_lock_tries = 1024;
1636  }
1637}
1638#endif
1639#endif
1640
1641void
1642init_threads(void * stack_base, TCR *tcr)
1643{
1644  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1645#ifdef WINDOWS
1646  lisp_global(TCR_KEY) = TlsAlloc();
1647  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1648  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
1649#else
1650  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1651  thread_signal_setup();
1652#endif
1653
1654#ifndef USE_FUTEX
1655  count_cpus();
1656#endif
1657  threads_initialized = true;
1658}
1659
1660
1661#ifdef WINDOWS
1662unsigned CALLBACK
1663#else
1664void *
1665#endif
1666lisp_thread_entry(void *param)
1667{
1668  thread_activation *activation = (thread_activation *)param;
1669  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1670  LispObj *start_vsp;
1671#ifndef WINDOWS
1672  sigset_t mask, old_mask;
1673
1674  sigemptyset(&mask);
1675  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1676#endif
1677
1678  register_thread_tcr(tcr);
1679
1680#ifndef WINDOWS
1681  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1682#endif
1683  tcr->vs_area->active -= node_size;
1684  *(--tcr->save_vsp) = lisp_nil;
1685  start_vsp = tcr->save_vsp;
1686  enable_fp_exceptions();
1687  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1688  activation->tcr = tcr;
1689  SEM_RAISE(activation->created);
1690  do {
1691    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1692    SEM_WAIT_FOREVER(TCR_AUX(tcr)->activate);
1693    /* Now go run some lisp code */
1694    start_lisp(TCR_TO_TSD(tcr),0);
1695    tcr->save_vsp = start_vsp;
1696  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1697#ifndef WINDOWS
1698  pthread_cleanup_pop(true);
1699#else
1700  tcr_cleanup(tcr);
1701#endif
1702#ifdef WINDOWS
1703  return 0;
1704#else
1705  return NULL;
1706#endif
1707}
1708
1709typedef 
1710short (*suspendf)();
1711
1712
1713void
1714suspend_current_cooperative_thread()
1715{
1716  static suspendf cooperative_suspend = NULL;
1717  void *xFindSymbol(void*,char*);
1718
1719  if (cooperative_suspend == NULL) {
1720    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
1721  }
1722  if (cooperative_suspend) {
1723    cooperative_suspend(1 /* kCurrentThreadID */,
1724                        1 /* kStoppedThreadState */,
1725                        0 /* kAnyThreadID */);
1726  }
1727}
1728
1729void *
1730cooperative_thread_startup(void *arg)
1731{
1732
1733  TCR *tcr = get_tcr(0);
1734  LispObj *start_vsp;
1735
1736  if (!tcr) {
1737    return NULL;
1738  }
1739#ifndef WINDOWS
1740  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1741#endif
1742  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1743  start_vsp = tcr->save_vsp;
1744  do {
1745    SEM_RAISE(TCR_AUX(tcr)->reset_completion);
1746    suspend_current_cooperative_thread();
1747     
1748    start_lisp(tcr, 0);
1749    tcr->save_vsp = start_vsp;
1750  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1751#ifndef WINDOWS
1752  pthread_cleanup_pop(true);
1753#else
1754  tcr_cleanup(tcr);
1755#endif
1756}
1757
1758void *
1759xNewThread(natural control_stack_size,
1760           natural value_stack_size,
1761           natural temp_stack_size)
1762
1763{
1764  thread_activation activation;
1765
1766
1767  activation.tsize = temp_stack_size;
1768  activation.vsize = value_stack_size;
1769  activation.tcr = 0;
1770  activation.created = new_semaphore(0);
1771  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1772                           NULL, 
1773                           lisp_thread_entry,
1774                           (void *) &activation)) {
1775   
1776    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1777  }
1778  destroy_semaphore(&activation.created); 
1779
1780#ifdef USE_DTRACE
1781  if (CCL_CREATE_THREAD_ENABLED() && activation.tcr) {
1782    CCL_CREATE_THREAD(activation.tcr->osid);
1783  }
1784#endif
1785
1786  return TCR_TO_TSD(activation.tcr);
1787}
1788
1789Boolean
1790active_tcr_p(TCR *q)
1791{
1792  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1793 
1794  do {
1795    if (p == q) {
1796      return true;
1797    }
1798    p = TCR_AUX(p)->next;
1799  } while (p != head);
1800  return false;
1801}
1802
1803
1804OSErr
1805xDisposeThread(TCR *tcr)
1806{
1807  return 0;                     /* I don't think that this is ever called. */
1808}
1809
1810OSErr
1811xYieldToThread(TCR *target)
1812{
1813  Bug(NULL, "xYieldToThread ?");
1814  return 0;
1815}
1816 
1817OSErr
1818xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1819{
1820  Bug(NULL, "xThreadCurrentStackSpace ?");
1821  return 0;
1822}
1823
1824
1825#ifdef WINDOWS
1826Boolean
1827create_system_thread(size_t stack_size,
1828                     void* stackaddr,
1829                     unsigned CALLBACK (*start_routine)(void *),
1830                     void* param)
1831{
1832  HANDLE thread_handle;
1833  Boolean won = false;
1834
1835  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1836
1837  thread_handle = (HANDLE)_beginthreadex(NULL, 
1838                                         stack_size,
1839                                         start_routine,
1840                                         param,
1841                                         0, 
1842                                         NULL);
1843
1844  if (thread_handle == NULL) {
1845    wperror("CreateThread");
1846  } else {
1847    won = true;
1848    CloseHandle(thread_handle);
1849  }
1850  return won;
1851}
1852#else
1853Boolean
1854create_system_thread(size_t stack_size,  void *stackaddr,
1855                     void *(*start_routine)(void *), void *param)
1856{
1857  pthread_attr_t attr;
1858  pthread_t returned_thread;
1859  int err;
1860  TCR *current = get_tcr(true);
1861
1862  pthread_attr_init(&attr);
1863  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1864
1865  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1866    stack_size = PTHREAD_STACK_MIN;
1867  }
1868
1869  stack_size = ensure_stack_limit(stack_size);
1870  if (stackaddr != NULL) {
1871    /* Size must have been specified.  Sort of makes sense ... */
1872    pthread_attr_setstack(&attr, stackaddr, stack_size);
1873  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1874    pthread_attr_setstacksize(&attr,stack_size);
1875  }
1876
1877  /*
1878     I think that's just about enough ... create the thread.
1879     Well ... not quite enough.  In Leopard (at least), many
1880     pthread routines grab an internal spinlock when validating
1881     their arguments.  If we suspend a thread that owns this
1882     spinlock, we deadlock.  We can't in general keep that
1883     from happening: if arbitrary C code is suspended while
1884     it owns the spinlock, we still deadlock.  It seems that
1885     the best that we can do is to keep -this- code from
1886     getting suspended (by grabbing TCR_AREA_LOCK)
1887  */
1888  LOCK(lisp_global(TCR_AREA_LOCK),current);
1889  err = pthread_create(&returned_thread, &attr, start_routine, param);
1890  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1891  pthread_attr_destroy(&attr);
1892  return (err == 0);
1893}
1894#endif
1895
1896TCR *
1897get_tcr(Boolean create)
1898{
1899#ifdef HAVE_TLS
1900  TCR *current = current_tcr;
1901#elif defined(WIN_32)
1902  TCR *current = ((TCR *)((char *)NtCurrentTeb() + TCR_BIAS))->linear;
1903#else
1904  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1905  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1906#endif
1907
1908  if ((current == NULL) && create) {
1909    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1910      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1911    int i, nbindwords = 0;
1912    extern natural initial_stack_size;
1913   
1914    /* Make one. */
1915    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1916    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1917    register_thread_tcr(current);
1918#ifdef DEBUG_TCR_CREATION
1919#ifndef WINDOWS
1920    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
1921#endif
1922#endif
1923    current->vs_area->active -= node_size;
1924    *(--current->save_vsp) = lisp_nil;
1925#ifdef PPC
1926#define NSAVEREGS 8
1927#endif
1928#ifdef X8664
1929#define NSAVEREGS 4
1930#endif
1931#ifdef X8632
1932#define NSAVEREGS 0
1933#endif
1934#ifdef ARM
1935#define NSAVEREGS 0
1936#endif
1937    for (i = 0; i < NSAVEREGS; i++) {
1938      *(--current->save_vsp) = 0;
1939      current->vs_area->active -= node_size;
1940    }
1941    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1942    for (i = 0; i < nbindwords; i++) {
1943      *(--current->save_vsp) = 0;
1944      current->vs_area->active -= node_size;
1945    }
1946    TCR_AUX(current)->shutdown_count = 1;
1947    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1948
1949  }
1950 
1951  return current;
1952}
1953
1954#ifdef WINDOWS
1955void *
1956pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
1957{
1958  /* Thread has started to return from an exception. */
1959  if (where < restore_windows_context_iret) {
1960    /* In the process of restoring registers; context still in
1961       %rcx.  Just make our suspend_context be the context
1962       we're trying to restore, so that we'll resume from
1963       the suspend in the same context that we're trying to
1964       restore */
1965#ifdef WIN_64
1966    *pcontext = * (CONTEXT *)(pcontext->Rcx);
1967#else
1968    if (where == restore_windows_context_start) {
1969      *pcontext = * (CONTEXT *)((pcontext->Esp)+4);
1970    } else {
1971      *pcontext = * (CONTEXT *)(pcontext->Ecx);
1972    }
1973#endif
1974  } else {
1975    /* Most of the context has already been restored; fix %rcx
1976       if need be, then restore ss:rsp, cs:rip, and flags. */
1977#ifdef WIN_64
1978    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1979
1980    pcontext->Rip = iret_frame->Rip;
1981    pcontext->SegCs = (WORD) iret_frame->Cs;
1982    pcontext->EFlags = (DWORD) iret_frame->Rflags;
1983    pcontext->Rsp = iret_frame->Rsp;
1984    pcontext->SegSs = (WORD) iret_frame->Ss;
1985#else
1986    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
1987
1988    pcontext->Eip = iret_frame->Eip;
1989    pcontext->SegCs = (WORD) iret_frame->Cs;
1990    pcontext->EFlags = (DWORD) iret_frame->EFlags;
1991    pcontext->Esp += sizeof(ia32_iret_frame);
1992#endif
1993  }
1994  tcr->pending_exception_context = NULL;
1995  /* We basically never return from an exception unless we
1996     were executing lisp code when the exception returned.
1997     If that ever changes, we need to know what valence
1998     would have been restored here.*/
1999  tcr->valence = TCR_STATE_LISP;
2000}
2001
2002Boolean
2003suspend_tcr(TCR *tcr)
2004{
2005  int suspend_count = atomic_incf(&(TCR_AUX(tcr)->suspend_count));
2006  DWORD rc;
2007  if (suspend_count == 1) {
2008    CONTEXT  *pcontext = (CONTEXT *)TCR_AUX(tcr)->native_thread_info;
2009    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
2010    pc where;
2011    area *cs = TCR_AUX(tcr)->cs_area;
2012    LispObj foreign_rsp;
2013
2014    if (hthread == NULL) {
2015      return false;
2016    }
2017    rc = SuspendThread(hthread);
2018    if (rc == -1) {
2019      /* If the thread's simply dead, we should handle that here */
2020      return false;
2021    }
2022    pcontext->ContextFlags = CONTEXT_ALL;
2023    rc = GetThreadContext(hthread, pcontext);
2024    if (rc == 0) {
2025      return false;
2026    }
2027    where = (pc)(xpPC(pcontext));
2028
2029    if ((where >= restore_windows_context_start) &&
2030        (where < restore_windows_context_end) &&
2031        (tcr->valence != TCR_STATE_LISP)) {
2032#ifdef WIN_64
2033      tcr->valence = xpGPR(pcontext,REG_R8);
2034#else
2035      tcr->valence = ((LispObj *)(xpGPR(pcontext,Isp)))[3];
2036#endif
2037      pcontext = tcr->pending_exception_context;
2038      tcr->pending_exception_context = NULL; 
2039      where = (pc)(xpPC(pcontext));
2040    }
2041    if (tcr->valence == TCR_STATE_LISP) {
2042      if ((where >= restore_windows_context_start) &&
2043          (where < restore_windows_context_end)) {
2044        pc_luser_restore_windows_context(pcontext, tcr, where);
2045      } else {
2046        area *ts = tcr->ts_area;
2047        /* If we're in the lisp heap, or in x86-spentry??.o, or in
2048           x86-subprims??.o, or in the subprims jump table at #x15000,
2049           or on the tstack ... we're just executing lisp code.  Otherwise,
2050           we got an exception while executing lisp code, but haven't
2051           entered the handler yet (still in Windows exception glue
2052           or switching stacks or something.)  In the latter case, we
2053           basically want to get to he handler and have it notice
2054           the pending exception request, and suspend the thread at that
2055           point. */
2056        if (!((where < (pc)lisp_global(HEAP_END)) &&
2057              (where >= (pc)lisp_global(HEAP_START))) &&
2058            (!((where < (pc)(managed_static_area->active)) &&
2059              (where >= (pc)(readonly_area->low)))) &&
2060            !((where < spentry_end) && (where >= spentry_start)) &&
2061            !((where < subprims_end) && (where >= subprims_start)) &&
2062            !((where < (pc) 0x16000) &&
2063              (where >= (pc) 0x15000)) &&
2064            !((where < (pc) (ts->high)) &&
2065              (where >= (pc) (ts->low)))) {
2066          /* The thread has lisp valence, but is not executing code
2067             where we expect lisp code to be and is not exiting from
2068             an exception handler.  That pretty much means that it's
2069             on its way into an exception handler; we have to handshake
2070             until it enters an exception-wait state. */
2071          /* There are likely race conditions here */
2072          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2073          ResumeThread(hthread);
2074          SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2075          pcontext = NULL;
2076        }
2077      }
2078    }
2079    /* If we're really running lisp code, there's some reason to
2080       suspect that Windows is lying about that; the thread may have
2081       already committed to processing an exception and just not have
2082       reentered user mode.  If there's a way to determine that more
2083       reliably, I don't know what it is.  We can catch some cases of
2084       that by looking at whether the PC is at a UUO or other
2085       "intentional" illegal instruction and letting the thread enter
2086       exception handling, treating this case just like the case
2087       above. 
2088
2089       When people say that Windows sucks, they aren't always just
2090       talking about all of the other ways that it sucks.
2091    */
2092    if ((*where == INTN_OPCODE) ||
2093        ((*where == XUUO_OPCODE_0) && (where[1] == XUUO_OPCODE_1))) {
2094      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2095      ResumeThread(hthread);
2096      SEM_WAIT_FOREVER(TCR_AUX(tcr)->suspend);
2097      pcontext = NULL;
2098    }
2099    TCR_AUX(tcr)->suspend_context = pcontext;
2100    return true;
2101  }
2102  return false;
2103}
2104#else
2105Boolean
2106suspend_tcr(TCR *tcr)
2107{
2108  int suspend_count = atomic_incf(&(tcr->suspend_count));
2109  pthread_t thread;
2110  if (suspend_count == 1) {
2111    thread = (pthread_t)(tcr->osid);
2112    if ((thread != (pthread_t) 0) &&
2113        (pthread_kill(thread, thread_suspend_signal) == 0)) {
2114      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2115    } else {
2116      /* A problem using pthread_kill.  On Darwin, this can happen
2117         if the thread has had its signal mask surgically removed
2118         by pthread_exit.  If the native (Mach) thread can be suspended,
2119         do that and return true; otherwise, flag the tcr as belonging
2120         to a dead thread by setting tcr->osid to 0.
2121      */
2122      tcr->osid = 0;
2123      return false;
2124    }
2125    return true;
2126  }
2127  return false;
2128}
2129#endif
2130
2131#ifdef WINDOWS
2132Boolean
2133tcr_suspend_ack(TCR *tcr)
2134{
2135  return true;
2136}
2137#else
2138Boolean
2139tcr_suspend_ack(TCR *tcr)
2140{
2141  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
2142    SEM_WAIT_FOREVER(tcr->suspend);
2143    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2144  }
2145  return true;
2146}
2147#endif
2148     
2149
2150Boolean
2151kill_tcr(TCR *tcr)
2152{
2153  TCR *current = get_tcr(true);
2154  Boolean result = false;
2155
2156  LOCK(lisp_global(TCR_AREA_LOCK),current);
2157  {
2158    LispObj osid = TCR_AUX(tcr)->osid;
2159   
2160    if (osid) {
2161      result = true;
2162#ifdef WINDOWS
2163      /* What we really want to do here is (something like)
2164         forcing the thread to run quit_handler().  For now,
2165         mark the TCR as dead and kill the Windows thread. */
2166      /* xxx TerminateThread() bad */
2167      TCR_AUX(tcr)->osid = 0;
2168      if (!TerminateThread((HANDLE)osid, 0)) {
2169        CloseHandle((HANDLE)osid);
2170        result = false;
2171      } else {
2172        CloseHandle((HANDLE)osid);
2173        shutdown_thread_tcr(tcr);
2174      }
2175#else
2176      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2177        result = false;
2178      }
2179#endif
2180    }
2181  }
2182  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2183  return result;
2184}
2185
2186Boolean
2187lisp_suspend_tcr(TCR *tcr)
2188{
2189  Boolean suspended;
2190  TCR *current = get_tcr(true);
2191 
2192  LOCK(lisp_global(TCR_AREA_LOCK),current);
2193  suspended = suspend_tcr(tcr);
2194  if (suspended) {
2195    while (!tcr_suspend_ack(tcr));
2196  }
2197  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2198  return suspended;
2199}
2200         
2201#ifdef WINDOWS
2202Boolean
2203resume_tcr(TCR *tcr)
2204{
2205  int suspend_count = atomic_decf(&(TCR_AUX(tcr)->suspend_count)), err;
2206  DWORD rc;
2207  if (suspend_count == 0) {
2208    CONTEXT *context = TCR_AUX(tcr)->suspend_context;
2209    HANDLE hthread = (HANDLE)(TCR_AUX(tcr)->osid);
2210
2211
2212    TCR_AUX(tcr)->suspend_context = NULL;
2213    if (context) {
2214      if (tcr->valence == TCR_STATE_LISP) {
2215        rc = SetThreadContext(hthread,context);
2216        if (! rc) {
2217          Bug(NULL,"SetThreadContext");
2218          return false;
2219        }
2220      }
2221      rc = ResumeThread(hthread);
2222      if (rc == -1) {
2223        Bug(NULL,"ResumeThread");
2224        return false;
2225      }
2226      return true;
2227    } else {
2228      SEM_RAISE(TCR_AUX(tcr)->resume);
2229      return true;
2230    }
2231  }
2232  return false;
2233}   
2234#else
2235Boolean
2236resume_tcr(TCR *tcr)
2237{
2238  int suspend_count = atomic_decf(&(tcr->suspend_count));
2239  if (suspend_count == 0) {
2240    void *s = (tcr->resume);
2241    if (s != NULL) {
2242      SEM_RAISE(s);
2243      return true;
2244    }
2245  }
2246  return false;
2247}
2248#endif
2249
2250   
2251
2252
2253Boolean
2254lisp_resume_tcr(TCR *tcr)
2255{
2256  Boolean resumed;
2257  TCR *current = get_tcr(true);
2258 
2259  LOCK(lisp_global(TCR_AREA_LOCK),current);
2260  resumed = resume_tcr(tcr);
2261  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2262  return resumed;
2263}
2264
2265
2266TCR *freed_tcrs = NULL;
2267
2268void
2269enqueue_freed_tcr (TCR *tcr)
2270{
2271#ifndef HAVE_TLS
2272  TCR_AUX(tcr)->next = freed_tcrs;
2273  freed_tcrs = tcr;
2274#endif
2275}
2276
2277/* It's not clear that we can safely condemn a dead tcr's areas, since
2278   we may not be able to call free() if a suspended thread owns a
2279   malloc lock. At least make the areas appear to be empty.
2280*/
2281   
2282
2283void
2284normalize_dead_tcr_areas(TCR *tcr)
2285{
2286  area *a;
2287
2288  a = tcr->vs_area;
2289  if (a) {
2290    a->active = a->high;
2291  }
2292
2293#ifndef ARM
2294  a = tcr->ts_area;
2295  if (a) {
2296    a->active = a->high;
2297  }
2298#endif
2299
2300  a = TCR_AUX(tcr)->cs_area;
2301  if (a) {
2302    a->active = a->high;
2303  }
2304}
2305   
2306void
2307free_freed_tcrs ()
2308{
2309  TCR *current, *next;
2310
2311  for (current = freed_tcrs; current; current = next) {
2312    next = TCR_AUX(current)->next;
2313#ifndef HAVE_TLS
2314#ifdef WIN_32
2315    /* We sort of have TLS in that the TEB is per-thread.  We free the
2316     * tcr aux vector elsewhere. */
2317#else
2318    free(current);
2319#endif
2320#endif
2321  }
2322  freed_tcrs = NULL;
2323}
2324
2325void
2326suspend_other_threads(Boolean for_gc)
2327{
2328  TCR *current = get_tcr(true), *other, *next;
2329  int dead_tcr_count = 0;
2330  Boolean all_acked;
2331
2332  LOCK(lisp_global(TCR_AREA_LOCK), current);
2333  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2334    if ((TCR_AUX(other)->osid != 0)) {
2335      suspend_tcr(other);
2336      if (TCR_AUX(other)->osid == 0) {
2337        dead_tcr_count++;
2338      }
2339    } else {
2340      dead_tcr_count++;
2341    }
2342  }
2343
2344  do {
2345    all_acked = true;
2346    for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2347      if ((TCR_AUX(other)->osid != 0)) {
2348        if (!tcr_suspend_ack(other)) {
2349          all_acked = false;
2350        }
2351      }
2352    }
2353  } while(! all_acked);
2354
2355     
2356
2357  /* All other threads are suspended; can safely delete dead tcrs now */
2358  if (dead_tcr_count) {
2359    for (other = TCR_AUX(current)->next; other != current; other = next) {
2360      next = TCR_AUX(other)->next;
2361      if (TCR_AUX(other)->osid == 0)  {
2362        normalize_dead_tcr_areas(other);
2363        dequeue_tcr(other);
2364        enqueue_freed_tcr(other);
2365      }
2366    }
2367  }
2368}
2369
2370void
2371lisp_suspend_other_threads()
2372{
2373  suspend_other_threads(false);
2374}
2375
2376void
2377resume_other_threads(Boolean for_gc)
2378{
2379  TCR *current = get_tcr(true), *other;
2380
2381  for (other = TCR_AUX(current)->next; other != current; other = TCR_AUX(other)->next) {
2382    if ((TCR_AUX(other)->osid != 0)) {
2383      resume_tcr(other);
2384    }
2385  }
2386  free_freed_tcrs();
2387  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2388}
2389
2390void
2391lisp_resume_other_threads()
2392{
2393  resume_other_threads(false);
2394}
2395
2396
2397
2398rwlock *
2399rwlock_new()
2400{
2401  extern int cache_block_size;
2402
2403  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2404  rwlock *rw = NULL;;
2405 
2406  if (p) {
2407    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2408    rw->malloced_ptr = p;
2409#ifndef USE_FUTEX
2410    rw->reader_signal = new_semaphore(0);
2411    rw->writer_signal = new_semaphore(0);
2412    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2413      if (rw->reader_signal) {
2414        destroy_semaphore(&(rw->reader_signal));
2415      } else {
2416        destroy_semaphore(&(rw->writer_signal));
2417      }
2418      free(rw);
2419      rw = NULL;
2420    }
2421#endif
2422  }
2423  return rw;
2424}
2425
2426     
2427/*
2428  Try to get read access to a multiple-readers/single-writer lock.  If
2429  we already have read access, return success (indicating that the
2430  lock is held another time.  If we already have write access to the
2431  lock ... that won't work; return EDEADLK.  Wait until no other
2432  thread has or is waiting for write access, then indicate that we
2433  hold read access once.
2434*/
2435#ifndef USE_FUTEX
2436int
2437rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2438{
2439  int err = 0;
2440 
2441  LOCK_SPINLOCK(rw->spin, tcr);
2442
2443  if (rw->writer == tcr) {
2444    RELEASE_SPINLOCK(rw->spin);
2445    return EDEADLK;
2446  }
2447
2448  while (rw->blocked_writers || (rw->state > 0)) {
2449    rw->blocked_readers++;
2450    RELEASE_SPINLOCK(rw->spin);
2451    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2452    LOCK_SPINLOCK(rw->spin,tcr);
2453    rw->blocked_readers--;
2454    if (err == EINTR) {
2455      err = 0;
2456    }
2457    if (err) {
2458      RELEASE_SPINLOCK(rw->spin);
2459      return err;
2460    }
2461  }
2462  rw->state--;
2463  RELEASE_SPINLOCK(rw->spin);
2464  return err;
2465}
2466#else
2467int
2468rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2469{
2470  natural waitval;
2471
2472  lock_futex(&rw->spin);
2473
2474  if (rw->writer == tcr) {
2475    unlock_futex(&rw->spin);
2476    return EDEADLOCK;
2477  }
2478  while (1) {
2479    if (rw->writer == NULL) {
2480      --rw->state;
2481      unlock_futex(&rw->spin);
2482      return 0;
2483    }
2484    rw->blocked_readers++;
2485    waitval = rw->reader_signal;
2486    unlock_futex(&rw->spin);
2487    futex_wait(&rw->reader_signal,waitval);
2488    lock_futex(&rw->spin);
2489    rw->blocked_readers--;
2490  }
2491  return 0;
2492}
2493#endif   
2494
2495
2496/*
2497  Try to obtain write access to the lock.
2498  It is an error if we already have read access, but it's hard to
2499  detect that.
2500  If we already have write access, increment the count that indicates
2501  that.
2502  Otherwise, wait until the lock is not held for reading or writing,
2503  then assert write access.
2504*/
2505
2506#ifndef USE_FUTEX
2507int
2508rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2509{
2510  int err = 0;
2511
2512  LOCK_SPINLOCK(rw->spin,tcr);
2513  if (rw->writer == tcr) {
2514    rw->state++;
2515    RELEASE_SPINLOCK(rw->spin);
2516    return 0;
2517  }
2518
2519  while (rw->state != 0) {
2520    rw->blocked_writers++;
2521    RELEASE_SPINLOCK(rw->spin);
2522    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2523    LOCK_SPINLOCK(rw->spin,tcr);
2524    rw->blocked_writers--;
2525    if (err == EINTR) {
2526      err = 0;
2527    }
2528    if (err) {
2529      RELEASE_SPINLOCK(rw->spin);
2530      return err;
2531    }
2532  }
2533  rw->state = 1;
2534  rw->writer = tcr;
2535  RELEASE_SPINLOCK(rw->spin);
2536  return err;
2537}
2538
2539#else
2540int
2541rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2542{
2543  int err = 0;
2544  natural waitval;
2545
2546  lock_futex(&rw->spin);
2547  if (rw->writer == tcr) {
2548    rw->state++;
2549    unlock_futex(&rw->spin);
2550    return 0;
2551  }
2552
2553  while (rw->state != 0) {
2554    rw->blocked_writers++;
2555    waitval = rw->writer_signal;
2556    unlock_futex(&rw->spin);
2557    futex_wait(&rw->writer_signal,waitval);
2558    lock_futex(&rw->spin);
2559    rw->blocked_writers--;
2560  }
2561  rw->state = 1;
2562  rw->writer = tcr;
2563  unlock_futex(&rw->spin);
2564  return err;
2565}
2566#endif
2567
2568/*
2569  Sort of the same as above, only return EBUSY if we'd have to wait.
2570*/
2571#ifndef USE_FUTEX
2572int
2573rwlock_try_wlock(rwlock *rw, TCR *tcr)
2574{
2575  int ret = EBUSY;
2576
2577  LOCK_SPINLOCK(rw->spin,tcr);
2578  if (rw->writer == tcr) {
2579    rw->state++;
2580    ret = 0;
2581  } else {
2582    if (rw->state == 0) {
2583      rw->writer = tcr;
2584      rw->state = 1;
2585      ret = 0;
2586    }
2587  }
2588  RELEASE_SPINLOCK(rw->spin);
2589  return ret;
2590}
2591#else
2592int
2593rwlock_try_wlock(rwlock *rw, TCR *tcr)
2594{
2595  int ret = EBUSY;
2596
2597  lock_futex(&rw->spin);
2598  if (rw->writer == tcr) {
2599    rw->state++;
2600    ret = 0;
2601  } else {
2602    if (rw->state == 0) {
2603      rw->writer = tcr;
2604      rw->state = 1;
2605      ret = 0;
2606    }
2607  }
2608  unlock_futex(&rw->spin);
2609  return ret;
2610}
2611#endif
2612
2613#ifndef USE_FUTEX
2614int
2615rwlock_try_rlock(rwlock *rw, TCR *tcr)
2616{
2617  int ret = EBUSY;
2618
2619  LOCK_SPINLOCK(rw->spin,tcr);
2620  if (rw->state <= 0) {
2621    --rw->state;
2622    ret = 0;
2623  }
2624  RELEASE_SPINLOCK(rw->spin);
2625  return ret;
2626}
2627#else
2628int
2629rwlock_try_rlock(rwlock *rw, TCR *tcr)
2630{
2631  int ret = EBUSY;
2632
2633  lock_futex(&rw->spin);
2634  if (rw->state <= 0) {
2635    --rw->state;
2636    ret = 0;
2637  }
2638  unlock_futex(&rw->spin);
2639  return ret;
2640}
2641#endif
2642
2643
2644
2645#ifndef USE_FUTEX
2646int
2647rwlock_unlock(rwlock *rw, TCR *tcr)
2648{
2649
2650  int err = 0;
2651  natural blocked_readers = 0;
2652
2653  LOCK_SPINLOCK(rw->spin,tcr);
2654  if (rw->state > 0) {
2655    if (rw->writer != tcr) {
2656      err = EINVAL;
2657    } else {
2658      --rw->state;
2659      if (rw->state == 0) {
2660        rw->writer = NULL;
2661      }
2662    }
2663  } else {
2664    if (rw->state < 0) {
2665      ++rw->state;
2666    } else {
2667      err = EINVAL;
2668    }
2669  }
2670  if (err) {
2671    RELEASE_SPINLOCK(rw->spin);
2672    return err;
2673  }
2674 
2675  if (rw->state == 0) {
2676    if (rw->blocked_writers) {
2677      SEM_RAISE(rw->writer_signal);
2678    } else {
2679      blocked_readers = rw->blocked_readers;
2680      if (blocked_readers) {
2681        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2682      }
2683    }
2684  }
2685  RELEASE_SPINLOCK(rw->spin);
2686  return 0;
2687}
2688#else
2689int
2690rwlock_unlock(rwlock *rw, TCR *tcr)
2691{
2692
2693  int err = 0;
2694
2695  lock_futex(&rw->spin);
2696  if (rw->state > 0) {
2697    if (rw->writer != tcr) {
2698      err = EINVAL;
2699    } else {
2700      --rw->state;
2701      if (rw->state == 0) {
2702        rw->writer = NULL;
2703      }
2704    }
2705  } else {
2706    if (rw->state < 0) {
2707      ++rw->state;
2708    } else {
2709      err = EINVAL;
2710    }
2711  }
2712  if (err) {
2713    unlock_futex(&rw->spin);
2714    return err;
2715  }
2716 
2717  if (rw->state == 0) {
2718    if (rw->blocked_writers) {
2719      ++rw->writer_signal;
2720      unlock_futex(&rw->spin);
2721      futex_wake(&rw->writer_signal,1);
2722      return 0;
2723    }
2724    if (rw->blocked_readers) {
2725      ++rw->reader_signal;
2726      unlock_futex(&rw->spin);
2727      futex_wake(&rw->reader_signal, INT_MAX);
2728      return 0;
2729    }
2730  }
2731  unlock_futex(&rw->spin);
2732  return 0;
2733}
2734#endif
2735
2736       
2737void
2738rwlock_destroy(rwlock *rw)
2739{
2740#ifndef USE_FUTEX
2741  destroy_semaphore((void **)&rw->reader_signal);
2742  destroy_semaphore((void **)&rw->writer_signal);
2743#endif
2744  postGCfree((void *)(rw->malloced_ptr));
2745}
2746
2747
2748
2749#ifdef DARWIN
2750/* For debugging. */
2751int
2752mach_port_send_refs(mach_port_t port)
2753{
2754  mach_port_urefs_t nrefs;
2755  ipc_space_t task = mach_task_self();
2756 
2757  if (mach_port_get_refs(task,port,MACH_PORT_RIGHT_SEND,&nrefs) == KERN_SUCCESS) {
2758    return nrefs;
2759  }
2760  return -1;
2761}
2762#endif
2763
Note: See TracBrowser for help on using the repository browser.