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

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

Suppress some warnings from llvm.

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