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

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

In lisp_thread_entry(): declare start_vsp unconditionally.

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