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

Last change on this file since 13455 was 13455, checked in by rme, 9 years ago

In count_cpus(): we can use sysconf(_SC_NPROCESSORS_ONLN) on Mac OS X
now that we require at least Mac OS X 10.5.

In create_system_thread():

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