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

Last change on this file since 11581 was 11581, checked in by gb, 11 years ago

Hold TCR_AREA_LOCK when calling pthread_create(), to avoid Darwin lossage.

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