source: release/1.5/source/lisp-kernel/thread_manager.c @ 13898

Last change on this file since 13898 was 13898, checked in by gb, 9 years ago

Propagate r13869 from trunk to 1.5.

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