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

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

Try to use non-conflicting, platform-dependent signals instead of
SIGQUIT. (Darwin uses SIGEMT, which doesn't seem to be raised
by the kernel on x86 or PPC; other platfroms can use user-defined
(possibly "realtime" signals).

Rename kernel things that had 'quit' in their names and had to
do with terminating threads to instead have 'thread_kill' in
their names (e.g. quit_handler -> thread_kill_handler.)

In the x86 GC, at least in mark_root and the recursive case of
rmark, check the dnode against gc_area_dnode before mapping
a TRA to the containing function. (This keeps us from crashing
in those cases if we see a garbage root that's tagged as a TRA,
but that fixes the symptom and not the proble, that would cause
such a garbage root to appear.) This is x86-specific; the
PPC ports don't use TRAs.

Save lisp_heap_gc_threshold, the EGC enable state, and the
sizes of the ephemeral generations in the image and restore
them on startup. (The -T option - which sets the global
GC threshold from the command line - overrides any value
set in the image; more accurately, it does that if the value
of the -T argument isn't the default GC threshold size.)
This is probably the right idea, but it's an incompatible
change; people who override the defaults at build or startup
time may need to change how their systems are built and
initialized.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 55.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 (next = chain; next;) {
825      next = next->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}
1103
1104#endif
1105#ifdef FREEBSD
1106#include <machine/segments.h>
1107#include <machine/sysarch.h>
1108
1109/* It'd be tempting to use i386_set_fsbase() here, but there doesn't
1110   seem to be any way to free the GDT entry it creates.  Actually,
1111   it's not clear that that really sets a GDT entry; let's see */
1112
1113#define FREEBSD_USE_SET_FSBASE 1
1114void
1115setup_tcr_extra_segment(TCR *tcr)
1116{
1117#if !FREEBSD_USE_SET_FSBASE
1118  struct segment_descriptor sd;
1119  uintptr_t addr = (uintptr_t)tcr;
1120  unsigned int size = sizeof(*tcr);
1121  int i;
1122
1123  sd.sd_lolimit = (size - 1) & 0xffff;
1124  sd.sd_hilimit = ((size - 1) >> 16) & 0xf;
1125  sd.sd_lobase = addr & ((1<<24)-1);
1126  sd.sd_hibase = (addr>>24)&0xff;
1127
1128
1129
1130  sd.sd_type = 18;
1131  sd.sd_dpl = SEL_UPL;
1132  sd.sd_p = 1;
1133  sd.sd_def32 = 1;
1134  sd.sd_gran = 0;
1135
1136  i = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor *)&sd, 1);
1137
1138  if (i < 0) {
1139    perror("i386_set_ldt");
1140    exit(1);
1141  } else {
1142    tcr->ldt_selector = LSEL(i,SEL_UPL);
1143  }
1144#else
1145  if (i386_set_fsbase((void*)tcr)) {
1146    perror("i386_set_fsbase");
1147    exit(1);
1148  }
1149  /* Once we've called i386_set_fsbase, we can't write to %fs. */
1150  tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL);
1151#endif
1152}
1153
1154void 
1155free_tcr_extra_segment(TCR *tcr)
1156{
1157#if FREEBSD_USE_SET_FSBASE
1158  /* On a 32-bit kernel, this allocates a GDT entry.  It's not clear
1159     what it would mean to deallocate that entry. */
1160  /* If we're running on a 64-bit kernel, we can't write to %fs */
1161#else
1162  int idx = tcr->ldt_selector >> 3;
1163  /* load %fs with null segment selector */
1164  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1165  if (i386_set_ldt(idx, NULL, 1) < 0)
1166    perror("i386_set_ldt");
1167#endif
1168  tcr->ldt_selector = 0;
1169}
1170#endif
1171
1172#ifdef SOLARIS
1173#include <sys/sysi86.h>
1174
1175bitvector ldt_entries_in_use = NULL;
1176pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
1177
1178void
1179solaris_ldt_init()
1180{
1181  int fd;
1182  struct ssd s;
1183
1184  ldt_entries_in_use=malloc(8192/8);
1185  zero_bits(ldt_entries_in_use,8192);
1186 
1187  fd = open("/proc/self/ldt", O_RDONLY);
1188
1189  while(read(fd,&s,sizeof(s)) == sizeof(s)) {
1190    set_bit(ldt_entries_in_use,s.sel>>3);
1191  }
1192  close(fd);
1193}
1194   
1195
1196void
1197setup_tcr_extra_segment(TCR *tcr)
1198{
1199  struct ssd s;
1200  int i;
1201
1202  pthread_mutex_lock(&ldt_lock);
1203
1204  for (i = 0; i < 8192; i++) {
1205    if (!ref_bit(ldt_entries_in_use,i)) {
1206      s.sel = (i<<3)|7;
1207      s.bo = (unsigned int)tcr;
1208      s.ls = sizeof(TCR);
1209      s.acc1 = 0xf2;
1210      s.acc2 = 4;
1211
1212      if (sysi86(SI86DSCR, &s) >= 0) {
1213        set_bit(ldt_entries_in_use,i);
1214        tcr->ldt_selector = (i<<3)|7;
1215        pthread_mutex_unlock(&ldt_lock);
1216        return;
1217      }
1218      set_bit(ldt_entries_in_use,i);
1219    }
1220  }
1221  pthread_mutex_unlock(&ldt_lock);
1222  fprintf(stderr, "All 8192 LDT descriptors in use\n");
1223  _exit(1);
1224
1225
1226 
1227}
1228
1229void 
1230free_tcr_extra_segment(TCR *tcr)
1231{
1232  struct ssd s;
1233  int i;
1234
1235  pthread_mutex_lock(&ldt_lock);
1236  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1237  s.sel = tcr->ldt_selector;
1238  i = s.sel>>3;
1239  tcr->ldt_selector = 0;
1240  s.bo = 0;
1241  s.ls = 0;
1242  s.acc1 = 0;
1243  s.acc2 = 0;
1244  sysi86(SI86DSCR, &s);
1245  clr_bit(ldt_entries_in_use,i);
1246  pthread_mutex_unlock(&ldt_lock);
1247}
1248
1249#endif
1250#endif
1251
1252/*
1253  Caller must hold the area_lock.
1254*/
1255TCR *
1256new_tcr(natural vstack_size, natural tstack_size)
1257{
1258  extern area
1259    *allocate_vstack_holding_area_lock(natural),
1260    *allocate_tstack_holding_area_lock(natural);
1261  area *a;
1262  int i;
1263#ifndef WINDOWS
1264  sigset_t sigmask;
1265
1266  sigemptyset(&sigmask);
1267  pthread_sigmask(SIG_SETMASK,&sigmask, NULL);
1268#endif
1269
1270#ifdef HAVE_TLS
1271  TCR *tcr = &current_tcr;
1272#else /* no TLS */
1273  TCR *tcr = allocate_tcr();
1274#endif
1275
1276#ifdef X86
1277  setup_tcr_extra_segment(tcr);
1278  tcr->linear = tcr;
1279#ifdef X8632
1280  tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK;
1281#endif
1282#endif
1283
1284#if (WORD_SIZE == 64)
1285  tcr->single_float_convert.tag = subtag_single_float;
1286#endif
1287  lisp_global(TCR_COUNT) += (1<<fixnumshift);
1288  tcr->suspend = new_semaphore(0);
1289  tcr->resume = new_semaphore(0);
1290  tcr->reset_completion = new_semaphore(0);
1291  tcr->activate = new_semaphore(0);
1292  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1293  a = allocate_vstack_holding_area_lock(vstack_size);
1294  tcr->vs_area = a;
1295  a->owner = tcr;
1296  tcr->save_vsp = (LispObj *) a->active; 
1297  a = allocate_tstack_holding_area_lock(tstack_size);
1298  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1299  tcr->ts_area = a;
1300  a->owner = tcr;
1301  tcr->save_tsp = (LispObj *) a->active;
1302#ifdef X86
1303  tcr->next_tsp = tcr->save_tsp;
1304#endif
1305
1306  tcr->valence = TCR_STATE_FOREIGN;
1307#ifdef PPC
1308  tcr->lisp_fpscr.words.l = 0xd0;
1309#endif
1310#ifdef X86
1311  tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | 
1312#if 1                           /* Mask underflow; too hard to
1313                                   deal with denorms if underflow is
1314                                   enabled */
1315    (1 << MXCSR_UM_BIT) | 
1316#endif
1317    (1 << MXCSR_PM_BIT);
1318#endif
1319  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
1320  tcr->tlb_limit = 2048<<fixnumshift;
1321  tcr->tlb_pointer = (LispObj *)malloc(tcr->tlb_limit);
1322  for (i = 0; i < 2048; i++) {
1323    tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker;
1324  }
1325  TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<<fixnum_shift);
1326#ifndef WINDOWS
1327  tcr->shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS;
1328#else
1329  tcr->shutdown_count = 1;
1330#endif
1331  return tcr;
1332}
1333
1334void
1335shutdown_thread_tcr(void *arg)
1336{
1337  TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0);
1338
1339  area *vs, *ts, *cs;
1340  void *termination_semaphore;
1341 
1342  if (current == NULL) {
1343    current = tcr;
1344  }
1345
1346  if (--(tcr->shutdown_count) == 0) {
1347    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
1348      LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1349        callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1350   
1351      tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1352      ((void (*)())ptr_from_lispobj(callback_ptr))(1);
1353      tsd_set(lisp_global(TCR_KEY), NULL);
1354    }
1355#ifdef DARWIN
1356    darwin_exception_cleanup(tcr);
1357#endif
1358    LOCK(lisp_global(TCR_AREA_LOCK),current);
1359    vs = tcr->vs_area;
1360    tcr->vs_area = NULL;
1361    ts = tcr->ts_area;
1362    tcr->ts_area = NULL;
1363    cs = tcr->cs_area;
1364    tcr->cs_area = NULL;
1365    if (vs) {
1366      condemn_area_holding_area_lock(vs);
1367    }
1368    if (ts) {
1369      condemn_area_holding_area_lock(ts);
1370    }
1371    if (cs) {
1372      condemn_area_holding_area_lock(cs);
1373    }
1374    destroy_semaphore(&tcr->suspend);
1375    destroy_semaphore(&tcr->resume);
1376    destroy_semaphore(&tcr->reset_completion);
1377    destroy_semaphore(&tcr->activate);
1378    tcr->tlb_limit = 0;
1379    free(tcr->tlb_pointer);
1380    tcr->tlb_pointer = NULL;
1381    tcr->osid = 0;
1382    tcr->interrupt_pending = 0;
1383    termination_semaphore = tcr->termination_semaphore;
1384    tcr->termination_semaphore = NULL;
1385#ifdef HAVE_TLS
1386    dequeue_tcr(tcr);
1387#endif
1388#ifdef X8632
1389    free_tcr_extra_segment(tcr);
1390#endif
1391#ifdef WIN32
1392    CloseHandle((HANDLE)tcr->io_datum);
1393    tcr->io_datum = NULL;
1394    free(tcr->native_thread_info);
1395    tcr->native_thread_info = NULL;
1396#endif
1397    UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1398    if (termination_semaphore) {
1399      SEM_RAISE(termination_semaphore);
1400    }
1401  } else {
1402    tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1403  }
1404}
1405
1406void
1407tcr_cleanup(void *arg)
1408{
1409  TCR *tcr = (TCR *)arg;
1410  area *a;
1411
1412  a = tcr->vs_area;
1413  if (a) {
1414    a->active = a->high;
1415  }
1416  a = tcr->ts_area;
1417  if (a) {
1418    a->active = a->high;
1419  }
1420  a = tcr->cs_area;
1421  if (a) {
1422    a->active = a->high;
1423  }
1424  tcr->valence = TCR_STATE_FOREIGN;
1425  tcr->shutdown_count = 1;
1426  shutdown_thread_tcr(tcr);
1427  tsd_set(lisp_global(TCR_KEY), NULL);
1428}
1429
1430void *
1431current_native_thread_id()
1432{
1433  return ((void *) (natural)
1434#ifdef LINUX
1435#ifdef __NR_gettid
1436          syscall(__NR_gettid)
1437#else
1438          getpid()
1439#endif
1440#endif
1441#ifdef DARWIN
1442          mach_thread_self()
1443#endif
1444#ifdef FREEBSD
1445          pthread_self()
1446#endif
1447#ifdef SOLARIS
1448          pthread_self()
1449#endif
1450#ifdef WINDOWS
1451          GetCurrentThreadId()
1452#endif
1453          );
1454}
1455
1456
1457void
1458thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size)
1459{
1460  area *a, *register_cstack_holding_area_lock(BytePtr, natural);
1461
1462  tcr->osid = current_thread_osid();
1463  tcr->native_thread_id = current_native_thread_id();
1464  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1465  a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size);
1466  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1467  tcr->cs_area = a;
1468  a->owner = tcr;
1469  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
1470    tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1471  }
1472#ifdef LINUX
1473#ifdef PPC
1474#ifndef PPC64
1475  tcr->native_thread_info = current_r2;
1476#endif
1477#endif
1478#endif
1479  tcr->errno_loc = &errno;
1480  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1481#ifdef DARWIN
1482  extern Boolean use_mach_exception_handling;
1483  if (use_mach_exception_handling) {
1484    darwin_exception_init(tcr);
1485  }
1486#endif
1487#ifdef LINUX
1488  linux_exception_init(tcr);
1489#endif
1490#ifdef WINDOWS
1491  tcr->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
1492  tcr->native_thread_info = malloc(sizeof(CONTEXT));
1493#endif
1494  tcr->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1495}
1496
1497/*
1498  Register the specified tcr as "belonging to" the current thread.
1499  Under Darwin, setup Mach exception handling for the thread.
1500  Install cleanup handlers for thread termination.
1501*/
1502void
1503register_thread_tcr(TCR *tcr)
1504{
1505  void *stack_base = NULL;
1506  natural stack_size = 0;
1507
1508  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1509  thread_init_tcr(tcr, stack_base, stack_size);
1510  enqueue_tcr(tcr);
1511}
1512
1513
1514 
1515 
1516#ifndef MAP_GROWSDOWN
1517#define MAP_GROWSDOWN 0
1518#endif
1519
1520Ptr
1521create_stack(natural size)
1522{
1523  Ptr p;
1524  size=align_to_power_of_2(size, log2_page_size);
1525  p = (Ptr) MapMemoryForStack((size_t)size);
1526  if (p != (Ptr)(-1)) {
1527    *((size_t *)p) = size;
1528    return p;
1529  }
1530  allocation_failure(true, size);
1531
1532}
1533
1534void *
1535allocate_stack(natural size)
1536{
1537  return create_stack(size);
1538}
1539
1540void
1541free_stack(void *s)
1542{
1543  size_t size = *((size_t *)s);
1544  UnMapMemory(s, size);
1545}
1546
1547Boolean threads_initialized = false;
1548
1549#ifndef USE_FUTEX
1550#ifdef WINDOWS
1551void
1552count_cpus()
1553{
1554  SYSTEM_INFO si;
1555
1556  GetSystemInfo(&si);
1557  if (si.dwNumberOfProcessors > 1) {
1558    spin_lock_tries = 1024;
1559  }
1560}
1561#else
1562void
1563count_cpus()
1564{
1565#ifdef DARWIN
1566  /* As of OSX 10.4, Darwin doesn't define _SC_NPROCESSORS_ONLN */
1567#include <mach/host_info.h>
1568
1569  struct host_basic_info info;
1570  mach_msg_type_number_t count = HOST_BASIC_INFO_COUNT;
1571 
1572  if (KERN_SUCCESS == host_info(mach_host_self(), HOST_BASIC_INFO,(host_info_t)(&info),&count)) {
1573    if (info.max_cpus > 1) {
1574      spin_lock_tries = 1024;
1575    }
1576  }
1577#else
1578  int n = sysconf(_SC_NPROCESSORS_ONLN);
1579 
1580  if (n > 1) {
1581    spin_lock_tries = 1024;
1582  }
1583#endif
1584}
1585#endif
1586#endif
1587
1588void
1589init_threads(void * stack_base, TCR *tcr)
1590{
1591  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1592#ifdef WINDOWS
1593  lisp_global(TCR_KEY) = TlsAlloc();
1594  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1595#else
1596  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1597  thread_signal_setup();
1598#endif
1599
1600#ifndef USE_FUTEX
1601  count_cpus();
1602#endif
1603  threads_initialized = true;
1604}
1605
1606
1607#ifdef WINDOWS
1608unsigned CALLBACK
1609#else
1610void *
1611#endif
1612lisp_thread_entry(void *param)
1613{
1614  thread_activation *activation = (thread_activation *)param;
1615  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1616#ifndef WINDOWS
1617  sigset_t mask, old_mask;
1618
1619  sigemptyset(&mask);
1620  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1621#endif
1622
1623  register_thread_tcr(tcr);
1624
1625#ifndef WINDOWS
1626  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1627#endif
1628  tcr->vs_area->active -= node_size;
1629  *(--tcr->save_vsp) = lisp_nil;
1630  enable_fp_exceptions();
1631  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1632  activation->tcr = tcr;
1633  SEM_RAISE(activation->created);
1634  do {
1635    SEM_RAISE(tcr->reset_completion);
1636    SEM_WAIT_FOREVER(tcr->activate);
1637    /* Now go run some lisp code */
1638    start_lisp(TCR_TO_TSD(tcr),0);
1639  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1640#ifndef WINDOWS
1641  pthread_cleanup_pop(true);
1642#else
1643  tcr_cleanup(tcr);
1644#endif
1645#ifdef WINDOWS
1646  return 0;
1647#else
1648  return NULL;
1649#endif
1650}
1651
1652void *
1653xNewThread(natural control_stack_size,
1654           natural value_stack_size,
1655           natural temp_stack_size)
1656
1657{
1658  thread_activation activation;
1659
1660
1661  activation.tsize = temp_stack_size;
1662  activation.vsize = value_stack_size;
1663  activation.tcr = 0;
1664  activation.created = new_semaphore(0);
1665  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1666                           NULL, 
1667                           lisp_thread_entry,
1668                           (void *) &activation)) {
1669   
1670    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1671  }
1672  destroy_semaphore(&activation.created); 
1673  return TCR_TO_TSD(activation.tcr);
1674}
1675
1676Boolean
1677active_tcr_p(TCR *q)
1678{
1679  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1680 
1681  do {
1682    if (p == q) {
1683      return true;
1684    }
1685    p = p->next;
1686  } while (p != head);
1687  return false;
1688}
1689
1690#ifdef WINDOWS
1691OSErr
1692xDisposeThread(TCR *tcr)
1693{
1694  return 0;                     /* I don't think that this is ever called. */
1695}
1696#else
1697OSErr
1698xDisposeThread(TCR *tcr)
1699{
1700  if (tcr != (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR))) {
1701    if (active_tcr_p(tcr) && (tcr != get_tcr(false))) {
1702      pthread_cancel((pthread_t)(tcr->osid));
1703      return 0;
1704    }
1705  }
1706  return -50;
1707}
1708#endif
1709
1710OSErr
1711xYieldToThread(TCR *target)
1712{
1713  Bug(NULL, "xYieldToThread ?");
1714  return 0;
1715}
1716 
1717OSErr
1718xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1719{
1720  Bug(NULL, "xThreadCurrentStackSpace ?");
1721  return 0;
1722}
1723
1724
1725#ifdef WINDOWS
1726LispObj
1727create_system_thread(size_t stack_size,
1728                     void* stackaddr,
1729                     unsigned CALLBACK (*start_routine)(void *),
1730                     void* param)
1731{
1732  HANDLE thread_handle;
1733
1734  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1735
1736  thread_handle = (HANDLE)_beginthreadex(NULL, 
1737                                         0/*stack_size*/,
1738                                         start_routine,
1739                                         param,
1740                                         0, 
1741                                         NULL);
1742
1743  if (thread_handle == NULL) {
1744    wperror("CreateThread");
1745  }
1746  return (LispObj) ptr_to_lispobj(thread_handle);
1747}
1748#else
1749LispObj
1750create_system_thread(size_t stack_size,
1751                     void* stackaddr,
1752                     void* (*start_routine)(void *),
1753                     void* param)
1754{
1755  pthread_attr_t attr;
1756  pthread_t returned_thread = (pthread_t) 0;
1757
1758  pthread_attr_init(&attr);
1759  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1760
1761  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1762    stack_size = PTHREAD_STACK_MIN;
1763  }
1764
1765  stack_size = ensure_stack_limit(stack_size);
1766  if (stackaddr != NULL) {
1767    /* Size must have been specified.  Sort of makes sense ... */
1768#ifdef DARWIN
1769    Fatal("no pthread_attr_setsetstack. "," Which end of stack does address refer to?");
1770#else
1771    pthread_attr_setstack(&attr, stackaddr, stack_size);
1772#endif
1773  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1774    pthread_attr_setstacksize(&attr,stack_size);
1775  }
1776
1777  /*
1778     I think that's just about enough ... create the thread.
1779  */
1780  pthread_create(&returned_thread, &attr, start_routine, param);
1781  pthread_attr_destroy(&attr);
1782  return (LispObj) ptr_to_lispobj(returned_thread);
1783}
1784#endif
1785
1786TCR *
1787get_tcr(Boolean create)
1788{
1789#ifdef HAVE_TLS
1790  TCR *current = current_tcr.linear;
1791#else
1792  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1793  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1794#endif
1795
1796  if ((current == NULL) && create) {
1797    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1798      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1799    int i, nbindwords = 0;
1800    extern unsigned initial_stack_size;
1801   
1802    /* Make one. */
1803    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1804    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1805    register_thread_tcr(current);
1806#ifdef DEBUG_TCR_CREATION
1807#ifndef WINDOWS
1808    fprintf(stderr, "\ncreating TCR for pthread 0x%x", pthread_self());
1809#endif
1810#endif
1811    current->vs_area->active -= node_size;
1812    *(--current->save_vsp) = lisp_nil;
1813#ifdef PPC
1814#define NSAVEREGS 8
1815#endif
1816#ifdef X8664
1817#define NSAVEREGS 4
1818#endif
1819#ifdef X8632
1820#define NSAVEREGS 0
1821#endif
1822    for (i = 0; i < NSAVEREGS; i++) {
1823      *(--current->save_vsp) = 0;
1824      current->vs_area->active -= node_size;
1825    }
1826    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1827    for (i = 0; i < nbindwords; i++) {
1828      *(--current->save_vsp) = 0;
1829      current->vs_area->active -= node_size;
1830    }
1831    current->shutdown_count = 1;
1832    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1833
1834  }
1835 
1836  return current;
1837}
1838
1839#ifdef WINDOWS
1840
1841Boolean
1842suspend_tcr(TCR *tcr)
1843{
1844  int suspend_count = atomic_incf(&(tcr->suspend_count));
1845  DWORD rc;
1846  if (suspend_count == 1) {
1847    CONTEXT  *pcontext = (CONTEXT *)tcr->native_thread_info;
1848    HANDLE hthread = (HANDLE)(tcr->osid);
1849    pc where;
1850    area *cs = tcr->cs_area;
1851    LispObj foreign_rsp;
1852
1853    if (hthread == NULL) {
1854      return false;
1855    }
1856    rc = SuspendThread(hthread);
1857    if (rc == -1) {
1858      /* If the thread's simply dead, we should handle that here */
1859      return false;
1860    }
1861    pcontext->ContextFlags = CONTEXT_ALL;
1862    rc = GetThreadContext(hthread, pcontext);
1863    if (rc == 0) {
1864      return false;
1865    }
1866    where = (pc)(xpPC(pcontext));
1867
1868    if (tcr->valence == TCR_STATE_LISP) {
1869      if ((where >= restore_windows_context_start) &&
1870          (where < restore_windows_context_end)) {
1871        /* Thread has started to return from an exception. */
1872        if (where < restore_windows_context_load_rcx) {
1873          /* In the process of restoring registers; context still in
1874             %rcx.  Just make our suspend_context be the context
1875             we're trying to restore, so that we'll resume from
1876             the suspend in the same context that we're trying to
1877             restore */
1878#ifdef WIN_64
1879          *pcontext = * (CONTEXT *)(pcontext->Rcx);
1880#else
1881          fprintf(stderr, "missing win32 suspend code, case (1)\n");
1882#endif
1883        } else {
1884          /* Most of the context has already been restored; fix %rcx
1885             if need be, then restore ss:rsp, cs:rip, and flags. */
1886#ifdef WIN64
1887          x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1888          if (where == restore_windows_context_load_rcx) {
1889            pcontext->Rcx = ((CONTEXT*)(pcontext->Rcx))->Rcx;
1890          }
1891          pcontext->Rip = iret_frame->Rip;
1892          pcontext->SegCs = (WORD) iret_frame->Cs;
1893          pcontext->EFlags = (DWORD) iret_frame->Rflags;
1894          pcontext->Rsp = iret_frame->Rsp;
1895          pcontext->SegSs = (WORD) iret_frame->Ss;
1896#else
1897#warning need context setup for win32
1898          fprintf(stderr, "missing win32 suspend code, case (2)\n");
1899#endif
1900        }
1901        tcr->suspend_context = NULL;
1902      } else {
1903        area *ts = tcr->ts_area;
1904        /* If we're in the lisp heap, or in x86-spentry??.o, or in
1905           x86-subprims??.o, or in the subprims jump table at #x15000,
1906           or on the tstack ... we're just executing lisp code.  Otherwise,
1907           we got an exception while executing lisp code, but haven't
1908           entered the handler yet (still in Windows exception glue
1909           or switching stacks or something.)  In the latter case, we
1910           basically want to get to he handler and have it notice
1911           the pending exception request, and suspend the thread at that
1912           point. */
1913        if (!((where < (pc)lisp_global(HEAP_END)) &&
1914              (where >= (pc)lisp_global(HEAP_START))) &&
1915            !((where < spentry_end) && (where >= spentry_start)) &&
1916            !((where < subprims_end) && (where >= subprims_start)) &&
1917            !((where < (pc) 0x16000) &&
1918              (where >= (pc) 0x15000)) &&
1919            !((where < (pc) (ts->high)) &&
1920              (where >= (pc) (ts->low)))) {
1921          /* The thread has lisp valence, but is not executing code
1922             where we expect lisp code to be and is not exiting from
1923             an exception handler.  That pretty much means that it's
1924             on its way into an exception handler; we have to handshake
1925             until it enters an exception-wait state. */
1926          /* There are likely race conditions here */
1927          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
1928          ResumeThread(hthread);
1929          SEM_WAIT_FOREVER(tcr->suspend);
1930          SuspendThread(hthread);
1931          /* The thread is either waiting for its resume semaphore to
1932             be signaled or is about to wait.  Signal it now, while
1933             the thread's suspended. */
1934          SEM_RAISE(tcr->resume);
1935          pcontext->ContextFlags = CONTEXT_ALL;
1936          GetThreadContext(hthread, pcontext);
1937        }
1938      }
1939    } else {
1940      if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) {
1941        if (!tcr->pending_exception_context) {
1942          FBug(pcontext, "we're confused here.");
1943        }
1944        *pcontext = *tcr->pending_exception_context;
1945        tcr->pending_exception_context = NULL;
1946        tcr->valence = TCR_STATE_LISP;
1947      }
1948    }
1949    tcr->suspend_context = pcontext;
1950    return true;
1951  }
1952  return false;
1953}
1954#else
1955Boolean
1956suspend_tcr(TCR *tcr)
1957{
1958  int suspend_count = atomic_incf(&(tcr->suspend_count));
1959  pthread_t thread;
1960  if (suspend_count == 1) {
1961    thread = (pthread_t)(tcr->osid);
1962    if ((thread != (pthread_t) 0) &&
1963        (pthread_kill(thread, thread_suspend_signal) == 0)) {
1964      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
1965    } else {
1966      /* A problem using pthread_kill.  On Darwin, this can happen
1967         if the thread has had its signal mask surgically removed
1968         by pthread_exit.  If the native (Mach) thread can be suspended,
1969         do that and return true; otherwise, flag the tcr as belonging
1970         to a dead thread by setting tcr->osid to 0.
1971      */
1972      tcr->osid = 0;
1973      return false;
1974    }
1975    return true;
1976  }
1977  return false;
1978}
1979#endif
1980
1981#ifdef WINDOWS
1982Boolean
1983tcr_suspend_ack(TCR *tcr)
1984{
1985  return true;
1986}
1987#else
1988Boolean
1989tcr_suspend_ack(TCR *tcr)
1990{
1991  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
1992    SEM_WAIT_FOREVER(tcr->suspend);
1993    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
1994  }
1995  return true;
1996}
1997#endif
1998     
1999
2000Boolean
2001kill_tcr(TCR *tcr)
2002{
2003  TCR *current = get_tcr(true);
2004  Boolean result = false;
2005
2006  LOCK(lisp_global(TCR_AREA_LOCK),current);
2007  {
2008    LispObj osid = tcr->osid;
2009   
2010    if (osid) {
2011      result = true;
2012#ifdef WINDOWS
2013      /* What we really want to de hear is (something like)
2014         forcing the thread to run quit_handler().  For now,
2015         mark the TCR as dead and kill thw Windows thread. */
2016      tcr->osid = 0;
2017      if (!TerminateThread((HANDLE)osid, 0)) {
2018        result = false;
2019      } else {
2020        shutdown_thread_tcr(tcr);
2021      }
2022#else
2023      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2024        result = false;
2025      }
2026#endif
2027    }
2028  }
2029  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2030  return result;
2031}
2032
2033Boolean
2034lisp_suspend_tcr(TCR *tcr)
2035{
2036  Boolean suspended;
2037  TCR *current = get_tcr(true);
2038 
2039  LOCK(lisp_global(TCR_AREA_LOCK),current);
2040  suspended = suspend_tcr(tcr);
2041  if (suspended) {
2042    while (!tcr_suspend_ack(tcr));
2043  }
2044  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2045  return suspended;
2046}
2047         
2048#ifdef WINDOWS
2049Boolean
2050resume_tcr(TCR *tcr)
2051{
2052  int suspend_count = atomic_decf(&(tcr->suspend_count)), err;
2053  DWORD rc;
2054  if (suspend_count == 0) {
2055    CONTEXT *context = tcr->suspend_context;
2056    HANDLE hthread = (HANDLE)(tcr->osid);
2057
2058    if (context) {
2059      context->ContextFlags = CONTEXT_ALL;
2060      tcr->suspend_context = NULL;
2061      SetThreadContext(hthread,context);
2062      rc = ResumeThread(hthread);
2063      if (rc == -1) {
2064        wperror("ResumeThread");
2065        return false;
2066      }
2067      return true;
2068    }
2069  }
2070  return false;
2071}   
2072#else
2073Boolean
2074resume_tcr(TCR *tcr)
2075{
2076  int suspend_count = atomic_decf(&(tcr->suspend_count));
2077  if (suspend_count == 0) {
2078    void *s = (tcr->resume);
2079    if (s != NULL) {
2080      SEM_RAISE(s);
2081      return true;
2082    }
2083  }
2084  return false;
2085}
2086#endif
2087
2088   
2089
2090
2091Boolean
2092lisp_resume_tcr(TCR *tcr)
2093{
2094  Boolean resumed;
2095  TCR *current = get_tcr(true);
2096 
2097  LOCK(lisp_global(TCR_AREA_LOCK),current);
2098  resumed = resume_tcr(tcr);
2099  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2100  return resumed;
2101}
2102
2103
2104TCR *freed_tcrs = NULL;
2105
2106void
2107enqueue_freed_tcr (TCR *tcr)
2108{
2109#ifndef HAVE_TLS
2110  tcr->next = freed_tcrs;
2111  freed_tcrs = tcr;
2112#endif
2113}
2114
2115/* It's not clear that we can safely condemn a dead tcr's areas, since
2116   we may not be able to call free() if a suspended thread owns a
2117   malloc lock. At least make the areas appear to be empty.
2118*/
2119   
2120
2121void
2122normalize_dead_tcr_areas(TCR *tcr)
2123{
2124  area *a;
2125
2126  a = tcr->vs_area;
2127  if (a) {
2128    a->active = a->high;
2129  }
2130
2131  a = tcr->ts_area;
2132  if (a) {
2133    a->active = a->high;
2134  }
2135
2136  a = tcr->cs_area;
2137  if (a) {
2138    a->active = a->high;
2139  }
2140}
2141   
2142void
2143free_freed_tcrs ()
2144{
2145  TCR *current, *next;
2146
2147  for (current = freed_tcrs; current; current = next) {
2148    next = current->next;
2149#ifndef HAVE_TLS
2150#ifdef WIN32
2151    free(current->allocated);
2152#else
2153    free(current);
2154#endif
2155#endif
2156  }
2157  freed_tcrs = NULL;
2158}
2159
2160void
2161suspend_other_threads(Boolean for_gc)
2162{
2163  TCR *current = get_tcr(true), *other, *next;
2164  int dead_tcr_count = 0;
2165  Boolean all_acked;
2166
2167  LOCK(lisp_global(TCR_AREA_LOCK), current);
2168  for (other = current->next; other != current; other = other->next) {
2169    if ((other->osid != 0)) {
2170      suspend_tcr(other);
2171      if (other->osid == 0) {
2172        dead_tcr_count++;
2173      }
2174    } else {
2175      dead_tcr_count++;
2176    }
2177  }
2178
2179  do {
2180    all_acked = true;
2181    for (other = current->next; other != current; other = other->next) {
2182      if ((other->osid != 0)) {
2183        if (!tcr_suspend_ack(other)) {
2184          all_acked = false;
2185        }
2186      }
2187    }
2188  } while(! all_acked);
2189
2190     
2191
2192  /* All other threads are suspended; can safely delete dead tcrs now */
2193  if (dead_tcr_count) {
2194    for (other = current->next; other != current; other = next) {
2195      next = other->next;
2196      if ((other->osid == 0))  {
2197        normalize_dead_tcr_areas(other);
2198        dequeue_tcr(other);
2199        enqueue_freed_tcr(other);
2200      }
2201    }
2202  }
2203}
2204
2205void
2206lisp_suspend_other_threads()
2207{
2208  suspend_other_threads(false);
2209}
2210
2211void
2212resume_other_threads(Boolean for_gc)
2213{
2214  TCR *current = get_tcr(true), *other;
2215  for (other = current->next; other != current; other = other->next) {
2216    if ((other->osid != 0)) {
2217      resume_tcr(other);
2218    }
2219  }
2220  free_freed_tcrs();
2221  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2222}
2223
2224void
2225lisp_resume_other_threads()
2226{
2227  resume_other_threads(false);
2228}
2229
2230
2231
2232rwlock *
2233rwlock_new()
2234{
2235  extern int cache_block_size;
2236
2237  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2238  rwlock *rw = NULL;;
2239 
2240  if (p) {
2241    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2242    rw->malloced_ptr = p;
2243#ifndef USE_FUTEX
2244    rw->reader_signal = new_semaphore(0);
2245    rw->writer_signal = new_semaphore(0);
2246    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2247      if (rw->reader_signal) {
2248        destroy_semaphore(&(rw->reader_signal));
2249      } else {
2250        destroy_semaphore(&(rw->writer_signal));
2251      }
2252      free(rw);
2253      rw = NULL;
2254    }
2255#endif
2256  }
2257  return rw;
2258}
2259
2260     
2261/*
2262  Try to get read access to a multiple-readers/single-writer lock.  If
2263  we already have read access, return success (indicating that the
2264  lock is held another time.  If we already have write access to the
2265  lock ... that won't work; return EDEADLK.  Wait until no other
2266  thread has or is waiting for write access, then indicate that we
2267  hold read access once.
2268*/
2269#ifndef USE_FUTEX
2270int
2271rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2272{
2273  int err = 0;
2274 
2275  LOCK_SPINLOCK(rw->spin, tcr);
2276
2277  if (rw->writer == tcr) {
2278    RELEASE_SPINLOCK(rw->spin);
2279    return EDEADLK;
2280  }
2281
2282  while (rw->blocked_writers || (rw->state > 0)) {
2283    rw->blocked_readers++;
2284    RELEASE_SPINLOCK(rw->spin);
2285    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2286    LOCK_SPINLOCK(rw->spin,tcr);
2287    rw->blocked_readers--;
2288    if (err == EINTR) {
2289      err = 0;
2290    }
2291    if (err) {
2292      RELEASE_SPINLOCK(rw->spin);
2293      return err;
2294    }
2295  }
2296  rw->state--;
2297  RELEASE_SPINLOCK(rw->spin);
2298  return err;
2299}
2300#else
2301int
2302rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2303{
2304  natural waitval;
2305
2306  lock_futex(&rw->spin);
2307
2308  if (rw->writer == tcr) {
2309    unlock_futex(&rw->spin);
2310    return EDEADLOCK;
2311  }
2312  while (1) {
2313    if (rw->writer == NULL) {
2314      --rw->state;
2315      unlock_futex(&rw->spin);
2316      return 0;
2317    }
2318    rw->blocked_readers++;
2319    waitval = rw->reader_signal;
2320    unlock_futex(&rw->spin);
2321    futex_wait(&rw->reader_signal,waitval);
2322    lock_futex(&rw->spin);
2323    rw->blocked_readers--;
2324  }
2325  return 0;
2326}
2327#endif   
2328
2329
2330/*
2331  Try to obtain write access to the lock.
2332  It is an error if we already have read access, but it's hard to
2333  detect that.
2334  If we already have write access, increment the count that indicates
2335  that.
2336  Otherwise, wait until the lock is not held for reading or writing,
2337  then assert write access.
2338*/
2339
2340#ifndef USE_FUTEX
2341int
2342rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2343{
2344  int err = 0;
2345
2346  LOCK_SPINLOCK(rw->spin,tcr);
2347  if (rw->writer == tcr) {
2348    rw->state++;
2349    RELEASE_SPINLOCK(rw->spin);
2350    return 0;
2351  }
2352
2353  while (rw->state != 0) {
2354    rw->blocked_writers++;
2355    RELEASE_SPINLOCK(rw->spin);
2356    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2357    LOCK_SPINLOCK(rw->spin,tcr);
2358    rw->blocked_writers--;
2359    if (err == EINTR) {
2360      err = 0;
2361    }
2362    if (err) {
2363      RELEASE_SPINLOCK(rw->spin);
2364      return err;
2365    }
2366  }
2367  rw->state = 1;
2368  rw->writer = tcr;
2369  RELEASE_SPINLOCK(rw->spin);
2370  return err;
2371}
2372
2373#else
2374int
2375rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2376{
2377  int err = 0;
2378  natural waitval;
2379
2380  lock_futex(&rw->spin);
2381  if (rw->writer == tcr) {
2382    rw->state++;
2383    unlock_futex(&rw->spin);
2384    return 0;
2385  }
2386
2387  while (rw->state != 0) {
2388    rw->blocked_writers++;
2389    waitval = rw->writer_signal;
2390    unlock_futex(&rw->spin);
2391    futex_wait(&rw->writer_signal,waitval);
2392    lock_futex(&rw->spin);
2393    rw->blocked_writers--;
2394  }
2395  rw->state = 1;
2396  rw->writer = tcr;
2397  unlock_futex(&rw->spin);
2398  return err;
2399}
2400#endif
2401
2402/*
2403  Sort of the same as above, only return EBUSY if we'd have to wait.
2404*/
2405#ifndef USE_FUTEX
2406int
2407rwlock_try_wlock(rwlock *rw, TCR *tcr)
2408{
2409  int ret = EBUSY;
2410
2411  LOCK_SPINLOCK(rw->spin,tcr);
2412  if (rw->writer == tcr) {
2413    rw->state++;
2414    ret = 0;
2415  } else {
2416    if (rw->state == 0) {
2417      rw->writer = tcr;
2418      rw->state = 1;
2419      ret = 0;
2420    }
2421  }
2422  RELEASE_SPINLOCK(rw->spin);
2423  return ret;
2424}
2425#else
2426int
2427rwlock_try_wlock(rwlock *rw, TCR *tcr)
2428{
2429  int ret = EBUSY;
2430
2431  lock_futex(&rw->spin);
2432  if (rw->writer == tcr) {
2433    rw->state++;
2434    ret = 0;
2435  } else {
2436    if (rw->state == 0) {
2437      rw->writer = tcr;
2438      rw->state = 1;
2439      ret = 0;
2440    }
2441  }
2442  unlock_futex(&rw->spin);
2443  return ret;
2444}
2445#endif
2446
2447#ifndef USE_FUTEX
2448int
2449rwlock_try_rlock(rwlock *rw, TCR *tcr)
2450{
2451  int ret = EBUSY;
2452
2453  LOCK_SPINLOCK(rw->spin,tcr);
2454  if (rw->state <= 0) {
2455    --rw->state;
2456    ret = 0;
2457  }
2458  RELEASE_SPINLOCK(rw->spin);
2459  return ret;
2460}
2461#else
2462int
2463rwlock_try_rlock(rwlock *rw, TCR *tcr)
2464{
2465  int ret = EBUSY;
2466
2467  lock_futex(&rw->spin);
2468  if (rw->state <= 0) {
2469    --rw->state;
2470    ret = 0;
2471  }
2472  unlock_futex(&rw->spin);
2473  return ret;
2474}
2475#endif
2476
2477
2478
2479#ifndef USE_FUTEX
2480int
2481rwlock_unlock(rwlock *rw, TCR *tcr)
2482{
2483
2484  int err = 0;
2485  natural blocked_readers = 0;
2486
2487  LOCK_SPINLOCK(rw->spin,tcr);
2488  if (rw->state > 0) {
2489    if (rw->writer != tcr) {
2490      err = EINVAL;
2491    } else {
2492      --rw->state;
2493      if (rw->state == 0) {
2494        rw->writer = NULL;
2495      }
2496    }
2497  } else {
2498    if (rw->state < 0) {
2499      ++rw->state;
2500    } else {
2501      err = EINVAL;
2502    }
2503  }
2504  if (err) {
2505    RELEASE_SPINLOCK(rw->spin);
2506    return err;
2507  }
2508 
2509  if (rw->state == 0) {
2510    if (rw->blocked_writers) {
2511      SEM_RAISE(rw->writer_signal);
2512    } else {
2513      blocked_readers = rw->blocked_readers;
2514      if (blocked_readers) {
2515        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2516      }
2517    }
2518  }
2519  RELEASE_SPINLOCK(rw->spin);
2520  return 0;
2521}
2522#else
2523int
2524rwlock_unlock(rwlock *rw, TCR *tcr)
2525{
2526
2527  int err = 0;
2528
2529  lock_futex(&rw->spin);
2530  if (rw->state > 0) {
2531    if (rw->writer != tcr) {
2532      err = EINVAL;
2533    } else {
2534      --rw->state;
2535      if (rw->state == 0) {
2536        rw->writer = NULL;
2537      }
2538    }
2539  } else {
2540    if (rw->state < 0) {
2541      ++rw->state;
2542    } else {
2543      err = EINVAL;
2544    }
2545  }
2546  if (err) {
2547    unlock_futex(&rw->spin);
2548    return err;
2549  }
2550 
2551  if (rw->state == 0) {
2552    if (rw->blocked_writers) {
2553      ++rw->writer_signal;
2554      unlock_futex(&rw->spin);
2555      futex_wake(&rw->writer_signal,1);
2556      return 0;
2557    }
2558    if (rw->blocked_readers) {
2559      ++rw->reader_signal;
2560      unlock_futex(&rw->spin);
2561      futex_wake(&rw->reader_signal, INT_MAX);
2562      return 0;
2563    }
2564  }
2565  unlock_futex(&rw->spin);
2566  return 0;
2567}
2568#endif
2569
2570       
2571void
2572rwlock_destroy(rwlock *rw)
2573{
2574#ifndef USE_FUTEX
2575  destroy_semaphore((void **)&rw->reader_signal);
2576  destroy_semaphore((void **)&rw->writer_signal);
2577#endif
2578  postGCfree((void *)(rw->malloced_ptr));
2579}
2580
2581
2582
Note: See TracBrowser for help on using the repository browser.