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

Last change on this file since 12475 was 12475, checked in by gb, 10 years ago

In the Windows version of suspend_tcr(), if the suspended thread
is in TCR_STATE_EXCEPTION_RETURN (just given up the exception lock
but not yet changed the valence in restore_windows_context()), just
suspend it and let it restore its own context when it resumes.

The old behavior is at best an optimization, but letting the thread
restore its own context in this case seems to avoid (most? all?) of
the problems in ticket:571 (notably including the failure to restore
the correct selector in %es.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 58.2 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    if (lisp_global(IN_GC)) {
725      postGCfree(*s);
726    } else {
727      free(*s);
728    }
729#endif
730#ifdef USE_MACH_SEMAPHORES
731    semaphore_destroy(mach_task_self(),((semaphore_t)(natural) *s));
732#endif
733#ifdef USE_WINDOWS_SEMAPHORES
734    CloseHandle(*s);
735#endif
736    *s=NULL;
737  }
738}
739
740#ifdef WINDOWS
741void
742tsd_set(LispObj key, void *datum)
743{
744  TlsSetValue((DWORD)key, datum);
745}
746
747void *
748tsd_get(LispObj key)
749{
750  return TlsGetValue((DWORD)key);
751}
752#else
753void
754tsd_set(LispObj key, void *datum)
755{
756  pthread_setspecific((pthread_key_t)key, datum);
757}
758
759void *
760tsd_get(LispObj key)
761{
762  return pthread_getspecific((pthread_key_t)key);
763}
764#endif
765
766void
767dequeue_tcr(TCR *tcr)
768{
769  TCR *next, *prev;
770
771  next = tcr->next;
772  prev = tcr->prev;
773
774  prev->next = next;
775  next->prev = prev;
776  tcr->prev = tcr->next = NULL;
777#ifdef X8664
778  tcr->linear = NULL;
779#endif
780}
781 
782void
783enqueue_tcr(TCR *new)
784{
785  TCR *head, *tail;
786 
787  LOCK(lisp_global(TCR_AREA_LOCK),new);
788  head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR));
789  tail = head->prev;
790  tail->next = new;
791  head->prev = new;
792  new->prev = tail;
793  new->next = head;
794  UNLOCK(lisp_global(TCR_AREA_LOCK),new);
795}
796
797#ifdef WIN_32
798TCR *
799allocate_tcr()
800{
801  void *p = calloc(1,sizeof(TCR)+15);
802  TCR *tcr = (TCR *)((((natural)p)+15)&~15);
803
804  tcr->allocated = p;
805  return tcr;
806}
807#else
808TCR *
809allocate_tcr()
810{
811  TCR *tcr, *chain = NULL, *next;
812#ifdef DARWIN
813  extern Boolean use_mach_exception_handling;
814  kern_return_t kret;
815  mach_port_t
816    thread_exception_port,
817    task_self = mach_task_self();
818#endif
819  for (;;) {
820    tcr = calloc(1, sizeof(TCR));
821#ifdef DARWIN
822#if WORD_SIZE == 64
823    if (((unsigned)((natural)tcr)) != ((natural)tcr)) {
824      tcr->next = chain;
825      chain = tcr;
826      continue;
827    }
828#endif
829    if (use_mach_exception_handling) {
830      thread_exception_port = (mach_port_t)((natural)tcr);
831      kret = mach_port_allocate_name(task_self,
832                                     MACH_PORT_RIGHT_RECEIVE,
833                                     thread_exception_port);
834    } else {
835      kret = KERN_SUCCESS;
836    }
837
838    if (kret != KERN_SUCCESS) {
839      tcr->next = chain;
840      chain = tcr;
841      continue;
842    }
843#endif
844    for (;chain;chain = next) {
845      next = chain->next;
846      free(chain);
847    }
848    return tcr;
849  }
850}
851#endif
852
853#ifdef X8664
854#ifdef LINUX
855#include <asm/prctl.h>
856#include <sys/prctl.h>
857#endif
858#ifdef FREEBSD
859#include <machine/sysarch.h>
860#endif
861
862void
863setup_tcr_extra_segment(TCR *tcr)
864{
865#ifdef FREEBSD
866  amd64_set_gsbase(tcr);
867#endif
868#ifdef LINUX
869  arch_prctl(ARCH_SET_GS, (natural)tcr);
870#endif
871#ifdef DARWIN
872  /* There's no way to do this yet.  See DARWIN_GS_HACK */
873  /* darwin_set_x8664_fs_reg(tcr); */
874#endif
875#ifdef SOLARIS
876  /* Chris Curtis found this and suggested the use of syscall here */
877  syscall(SYS_lwp_private,_LWP_SETPRIVATE, _LWP_GSBASE, tcr);
878#endif
879}
880
881#endif
882
883#ifdef X8632
884
885#ifdef DARWIN
886#include <architecture/i386/table.h>
887#include <architecture/i386/sel.h>
888#include <i386/user_ldt.h>
889
890void setup_tcr_extra_segment(TCR *tcr)
891{
892    uintptr_t addr = (uintptr_t)tcr;
893    unsigned int size = sizeof(*tcr);
894    ldt_entry_t desc;
895    sel_t sel;
896    int i;
897
898    desc.data.limit00 = (size - 1) & 0xffff;
899    desc.data.limit16 = ((size - 1) >> 16) & 0xf;
900    desc.data.base00 = addr & 0xffff;
901    desc.data.base16 = (addr >> 16) & 0xff;
902    desc.data.base24 = (addr >> 24) & 0xff;
903    desc.data.type = DESC_DATA_WRITE;
904    desc.data.dpl = USER_PRIV;
905    desc.data.present = 1;
906    desc.data.stksz = DESC_CODE_32B;
907    desc.data.granular = DESC_GRAN_BYTE;
908   
909    i = i386_set_ldt(LDT_AUTO_ALLOC, &desc, 1);
910
911    if (i < 0) {
912        perror("i386_set_ldt");
913    } else {
914        sel.index = i;
915        sel.rpl = USER_PRIV;
916        sel.ti = SEL_LDT;
917        tcr->ldt_selector = sel;
918    }
919}
920
921void free_tcr_extra_segment(TCR *tcr)
922{
923  /* load %fs with null segement selector */
924  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
925  if (i386_set_ldt(tcr->ldt_selector.index, NULL, 1) < 0)
926    perror("i386_set_ldt");
927  tcr->ldt_selector = NULL_SEL;
928}
929#endif
930
931#ifdef LINUX
932
933#include <asm/ldt.h>
934#include <sys/syscall.h>
935
936/* see desc_struct in kernel/include/asm-i386/processor.h */
937typedef struct {
938  uint32_t a;
939  uint32_t b;
940} linux_desc_struct;
941
942
943#define desc_avail(d) (((d)->a) == 0)
944
945linux_desc_struct linux_ldt_entries[LDT_ENTRIES];
946
947/* We have to ask the Linux kernel for a copy of the ldt table
948   and manage it ourselves.  It's not clear that this is
949   thread-safe in general, but we can at least ensure that
950   it's thread-safe wrt lisp threads. */
951
952pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
953
954int
955modify_ldt(int func, void *ptr, unsigned long bytecount)
956{
957  return syscall(__NR_modify_ldt, func, ptr, bytecount);
958}
959
960
961void
962setup_tcr_extra_segment(TCR *tcr)
963{
964  int i, n;
965  short sel;
966  struct user_desc u = {1, 0, 0, 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1};
967  linux_desc_struct *d = linux_ldt_entries;
968
969  pthread_mutex_lock(&ldt_lock);
970  n = modify_ldt(0,d,LDT_ENTRIES*LDT_ENTRY_SIZE)/LDT_ENTRY_SIZE;
971  for (i = 0; i < n; i++,d++) {
972    if (desc_avail(d)) {
973      break;
974    }
975  }
976  if (i == LDT_ENTRIES) {
977    pthread_mutex_unlock(&ldt_lock);
978    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
979    _exit(1);
980  }
981  u.entry_number = i;
982  u.base_addr = (uint32_t)tcr;
983  u.limit = sizeof(TCR);
984  u.limit_in_pages = 0;
985  if (modify_ldt(1,&u,sizeof(struct user_desc)) != 0) {
986    pthread_mutex_unlock(&ldt_lock);
987    fprintf(dbgout,"Can't assign LDT entry\n");
988    _exit(1);
989  }
990  sel = (i << 3) | 7;
991  tcr->ldt_selector = sel;
992  pthread_mutex_unlock(&ldt_lock);
993}
994
995void
996free_tcr_extra_segment(TCR *tcr)
997{
998  struct user_desc u = {0, 0, 0, 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0};
999  short sel = tcr->ldt_selector;
1000
1001  pthread_mutex_lock(&ldt_lock);
1002  /* load %fs with null segment selector */
1003  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1004  tcr->ldt_selector = 0;
1005  u.entry_number = (sel>>3);
1006  modify_ldt(1,&u,sizeof(struct user_desc));
1007  pthread_mutex_unlock(&ldt_lock);
1008 
1009}
1010
1011#endif
1012
1013#ifdef WINDOWS
1014bitvector ldt_entries_in_use = NULL;
1015HANDLE ldt_lock;
1016
1017typedef struct {
1018  DWORD offset;
1019  DWORD size;
1020  LDT_ENTRY entry;
1021} win32_ldt_info;
1022
1023
1024int WINAPI (*NtQueryInformationProcess)(HANDLE,DWORD,VOID*,DWORD,DWORD*);
1025int WINAPI (*NtSetInformationProcess)(HANDLE,DWORD,VOID*,DWORD);
1026
1027void
1028init_win32_ldt()
1029{
1030  HANDLE hNtdll;
1031  int status = 0xc0000002;
1032  win32_ldt_info info;
1033  DWORD nret;
1034 
1035
1036  ldt_entries_in_use=malloc(8192/8);
1037  zero_bits(ldt_entries_in_use,8192);
1038  ldt_lock = CreateMutex(NULL,0,NULL);
1039
1040  hNtdll = LoadLibrary("ntdll.dll");
1041  NtQueryInformationProcess = (void*)GetProcAddress(hNtdll, "NtQueryInformationProcess");
1042  NtSetInformationProcess = (void*)GetProcAddress(hNtdll, "NtSetInformationProcess");
1043  if (NtQueryInformationProcess != NULL) {
1044    info.offset = 0;
1045    info.size = sizeof(LDT_ENTRY);
1046    status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1047  }
1048
1049  if (status) {
1050    fprintf(dbgout, "This application can't run under this OS version\n");
1051    _exit(1);
1052  }
1053}
1054
1055void
1056setup_tcr_extra_segment(TCR *tcr)
1057{
1058  int i, status;
1059  DWORD nret;
1060  win32_ldt_info info;
1061  LDT_ENTRY *entry = &(info.entry);
1062  DWORD *words = (DWORD *)entry, tcraddr = (DWORD)tcr;
1063
1064
1065  WaitForSingleObject(ldt_lock,INFINITE);
1066
1067  for (i = 0; i < 8192; i++) {
1068    if (!ref_bit(ldt_entries_in_use,i)) {
1069      info.offset = i << 3;
1070      info.size = sizeof(LDT_ENTRY);
1071      words[0] = 0;
1072      words[1] = 0;
1073      status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1074      if (status == 0) {
1075        if ((info.size == 0) ||
1076            ((words[0] == 0) && (words[1] == 0))) {
1077          break;
1078        }
1079      }
1080    }
1081  }
1082  if (i == 8192) {
1083    ReleaseMutex(ldt_lock);
1084    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
1085    _exit(1);
1086  }
1087  set_bit(ldt_entries_in_use,i);
1088  words[0] = 0;
1089  words[1] = 0;
1090  entry->LimitLow = sizeof(TCR);
1091  entry->BaseLow = tcraddr & 0xffff;
1092  entry->HighWord.Bits.BaseMid = (tcraddr >> 16) & 0xff;
1093  entry->HighWord.Bits.BaseHi = (tcraddr >> 24);
1094  entry->HighWord.Bits.Pres = 1;
1095  entry->HighWord.Bits.Default_Big = 1;
1096  entry->HighWord.Bits.Type = 16 | 2; /* read-write data */
1097  entry->HighWord.Bits.Dpl = 3; /* for use by the great unwashed */
1098  info.size = sizeof(LDT_ENTRY);
1099  status = NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info));
1100  if (status != 0) {
1101    ReleaseMutex(ldt_lock);
1102    FBug(NULL, "can't set LDT entry %d, status = 0x%x", i, status);
1103  }
1104#if 1
1105  /* Sanity check */
1106  info.offset = i << 3;
1107  info.size = sizeof(LDT_ENTRY);
1108  words[0] = 0;
1109  words[0] = 0;
1110  NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1111  if (((entry->BaseLow)|((entry->HighWord.Bits.BaseMid)<<16)|((entry->HighWord.Bits.BaseHi)<<24)) != tcraddr) {
1112    Bug(NULL, "you blew it: bad address in ldt entry\n");
1113  }
1114#endif
1115  tcr->ldt_selector = (i << 3) | 7;
1116  ReleaseMutex(ldt_lock);
1117}
1118
1119void 
1120free_tcr_extra_segment(TCR *tcr)
1121{
1122  win32_ldt_info info;
1123  LDT_ENTRY *entry = &(info.entry);
1124  DWORD *words = (DWORD *)entry;
1125  int idx = tcr->ldt_selector >> 3;
1126
1127
1128  info.offset = idx << 3;
1129  info.size = sizeof(LDT_ENTRY);
1130
1131  words[0] = 0;
1132  words[1] = 0;
1133
1134  WaitForSingleObject(ldt_lock,INFINITE);
1135  NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info));
1136  clr_bit(ldt_entries_in_use,idx);
1137  ReleaseMutex(ldt_lock);
1138
1139  tcr->ldt_selector = 0;
1140}
1141
1142#endif
1143#ifdef FREEBSD
1144#include <machine/segments.h>
1145#include <machine/sysarch.h>
1146
1147/* It'd be tempting to use i386_set_fsbase() here, but there doesn't
1148   seem to be any way to free the GDT entry it creates.  Actually,
1149   it's not clear that that really sets a GDT entry; let's see */
1150
1151#define FREEBSD_USE_SET_FSBASE 1
1152void
1153setup_tcr_extra_segment(TCR *tcr)
1154{
1155#if !FREEBSD_USE_SET_FSBASE
1156  struct segment_descriptor sd;
1157  uintptr_t addr = (uintptr_t)tcr;
1158  unsigned int size = sizeof(*tcr);
1159  int i;
1160
1161  sd.sd_lolimit = (size - 1) & 0xffff;
1162  sd.sd_hilimit = ((size - 1) >> 16) & 0xf;
1163  sd.sd_lobase = addr & ((1<<24)-1);
1164  sd.sd_hibase = (addr>>24)&0xff;
1165
1166
1167
1168  sd.sd_type = 18;
1169  sd.sd_dpl = SEL_UPL;
1170  sd.sd_p = 1;
1171  sd.sd_def32 = 1;
1172  sd.sd_gran = 0;
1173
1174  i = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor *)&sd, 1);
1175
1176  if (i < 0) {
1177    perror("i386_set_ldt");
1178    exit(1);
1179  } else {
1180    tcr->ldt_selector = LSEL(i,SEL_UPL);
1181  }
1182#else
1183  extern unsigned short get_fs_register(void);
1184
1185  if (i386_set_fsbase((void*)tcr)) {
1186    perror("i386_set_fsbase");
1187    exit(1);
1188  }
1189
1190
1191  /* Once we've called i386_set_fsbase, we can't write to %fs. */
1192  tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL);
1193#endif
1194}
1195
1196void 
1197free_tcr_extra_segment(TCR *tcr)
1198{
1199#if FREEBSD_USE_SET_FSBASE
1200  /* On a 32-bit kernel, this allocates a GDT entry.  It's not clear
1201     what it would mean to deallocate that entry. */
1202  /* If we're running on a 64-bit kernel, we can't write to %fs */
1203#else
1204  int idx = tcr->ldt_selector >> 3;
1205  /* load %fs with null segment selector */
1206  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1207  if (i386_set_ldt(idx, NULL, 1) < 0)
1208    perror("i386_set_ldt");
1209#endif
1210  tcr->ldt_selector = 0;
1211}
1212#endif
1213
1214#ifdef SOLARIS
1215#include <sys/sysi86.h>
1216
1217bitvector ldt_entries_in_use = NULL;
1218pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
1219
1220void
1221solaris_ldt_init()
1222{
1223  int fd;
1224  struct ssd s;
1225
1226  ldt_entries_in_use=malloc(8192/8);
1227  zero_bits(ldt_entries_in_use,8192);
1228 
1229  fd = open("/proc/self/ldt", O_RDONLY);
1230
1231  while(read(fd,&s,sizeof(s)) == sizeof(s)) {
1232    set_bit(ldt_entries_in_use,s.sel>>3);
1233  }
1234  close(fd);
1235}
1236   
1237
1238void
1239setup_tcr_extra_segment(TCR *tcr)
1240{
1241  struct ssd s;
1242  int i;
1243
1244  pthread_mutex_lock(&ldt_lock);
1245
1246  for (i = 0; i < 8192; i++) {
1247    if (!ref_bit(ldt_entries_in_use,i)) {
1248      s.sel = (i<<3)|7;
1249      s.bo = (unsigned int)tcr;
1250      s.ls = sizeof(TCR);
1251      s.acc1 = 0xf2;
1252      s.acc2 = 4;
1253
1254      if (sysi86(SI86DSCR, &s) >= 0) {
1255        set_bit(ldt_entries_in_use,i);
1256        tcr->ldt_selector = (i<<3)|7;
1257        pthread_mutex_unlock(&ldt_lock);
1258        return;
1259      }
1260      set_bit(ldt_entries_in_use,i);
1261    }
1262  }
1263  pthread_mutex_unlock(&ldt_lock);
1264  fprintf(dbgout, "All 8192 LDT descriptors in use\n");
1265  _exit(1);
1266
1267
1268 
1269}
1270
1271void 
1272free_tcr_extra_segment(TCR *tcr)
1273{
1274  struct ssd s;
1275  int i;
1276
1277  pthread_mutex_lock(&ldt_lock);
1278  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1279  s.sel = tcr->ldt_selector;
1280  i = s.sel>>3;
1281  tcr->ldt_selector = 0;
1282  s.bo = 0;
1283  s.ls = 0;
1284  s.acc1 = 0;
1285  s.acc2 = 0;
1286  sysi86(SI86DSCR, &s);
1287  clr_bit(ldt_entries_in_use,i);
1288  pthread_mutex_unlock(&ldt_lock);
1289}
1290
1291#endif
1292#endif
1293
1294/*
1295  Caller must hold the area_lock.
1296*/
1297TCR *
1298new_tcr(natural vstack_size, natural tstack_size)
1299{
1300  extern area
1301    *allocate_vstack_holding_area_lock(natural),
1302    *allocate_tstack_holding_area_lock(natural);
1303  area *a;
1304  int i;
1305#ifndef WINDOWS
1306  sigset_t sigmask;
1307
1308  sigemptyset(&sigmask);
1309  pthread_sigmask(SIG_SETMASK,&sigmask, NULL);
1310#endif
1311
1312#ifdef HAVE_TLS
1313  TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15));
1314  current_tcr = tcr;
1315#else /* no TLS */
1316  TCR *tcr = allocate_tcr();
1317#endif
1318
1319#ifdef X86
1320  setup_tcr_extra_segment(tcr);
1321  tcr->linear = tcr;
1322#ifdef X8632
1323  tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK;
1324#endif
1325#endif
1326
1327#if (WORD_SIZE == 64)
1328  tcr->single_float_convert.tag = subtag_single_float;
1329#endif
1330  lisp_global(TCR_COUNT) += (1<<fixnumshift);
1331  tcr->suspend = new_semaphore(0);
1332  tcr->resume = new_semaphore(0);
1333  tcr->reset_completion = new_semaphore(0);
1334  tcr->activate = new_semaphore(0);
1335  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1336  a = allocate_vstack_holding_area_lock(vstack_size);
1337  tcr->vs_area = a;
1338  a->owner = tcr;
1339  tcr->save_vsp = (LispObj *) a->active; 
1340  a = allocate_tstack_holding_area_lock(tstack_size);
1341  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1342  tcr->ts_area = a;
1343  a->owner = tcr;
1344  tcr->save_tsp = (LispObj *) a->active;
1345#ifdef X86
1346  tcr->next_tsp = tcr->save_tsp;
1347#endif
1348
1349  tcr->valence = TCR_STATE_FOREIGN;
1350#ifdef PPC
1351  tcr->lisp_fpscr.words.l = 0xd0;
1352#endif
1353#ifdef X86
1354  tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | 
1355#if 1                           /* Mask underflow; too hard to
1356                                   deal with denorms if underflow is
1357                                   enabled */
1358    (1 << MXCSR_UM_BIT) | 
1359#endif
1360    (1 << MXCSR_PM_BIT);
1361#endif
1362  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
1363  tcr->tlb_limit = 2048<<fixnumshift;
1364  tcr->tlb_pointer = (LispObj *)malloc(tcr->tlb_limit);
1365  for (i = 0; i < 2048; i++) {
1366    tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker;
1367  }
1368  TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<<fixnum_shift);
1369#ifndef WINDOWS
1370  tcr->shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS;
1371#else
1372  tcr->shutdown_count = 1;
1373#endif
1374  return tcr;
1375}
1376
1377void
1378shutdown_thread_tcr(void *arg)
1379{
1380  TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0);
1381
1382  area *vs, *ts, *cs;
1383  void *termination_semaphore;
1384 
1385  if (current == NULL) {
1386    current = tcr;
1387  }
1388
1389  if (--(tcr->shutdown_count) == 0) {
1390    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
1391      LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1392        callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1393   
1394      tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1395      ((void (*)())ptr_from_lispobj(callback_ptr))(1);
1396      tsd_set(lisp_global(TCR_KEY), NULL);
1397    }
1398#ifdef DARWIN
1399    darwin_exception_cleanup(tcr);
1400#endif
1401    LOCK(lisp_global(TCR_AREA_LOCK),current);
1402    vs = tcr->vs_area;
1403    tcr->vs_area = NULL;
1404    ts = tcr->ts_area;
1405    tcr->ts_area = NULL;
1406    cs = tcr->cs_area;
1407    tcr->cs_area = NULL;
1408    if (vs) {
1409      condemn_area_holding_area_lock(vs);
1410    }
1411    if (ts) {
1412      condemn_area_holding_area_lock(ts);
1413    }
1414    if (cs) {
1415      condemn_area_holding_area_lock(cs);
1416    }
1417    destroy_semaphore(&tcr->suspend);
1418    destroy_semaphore(&tcr->resume);
1419    destroy_semaphore(&tcr->reset_completion);
1420    destroy_semaphore(&tcr->activate);
1421    tcr->tlb_limit = 0;
1422    free(tcr->tlb_pointer);
1423    tcr->tlb_pointer = NULL;
1424    tcr->osid = 0;
1425    tcr->interrupt_pending = 0;
1426    termination_semaphore = tcr->termination_semaphore;
1427    tcr->termination_semaphore = NULL;
1428#ifdef HAVE_TLS
1429    dequeue_tcr(tcr);
1430#endif
1431#ifdef X8632
1432    free_tcr_extra_segment(tcr);
1433#endif
1434#ifdef WIN32
1435    CloseHandle((HANDLE)tcr->io_datum);
1436    tcr->io_datum = NULL;
1437    free(tcr->native_thread_info);
1438    tcr->native_thread_info = NULL;
1439#endif
1440    UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1441    if (termination_semaphore) {
1442      SEM_RAISE(termination_semaphore);
1443    }
1444  } else {
1445    tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1446  }
1447}
1448
1449void
1450tcr_cleanup(void *arg)
1451{
1452  TCR *tcr = (TCR *)arg;
1453  area *a;
1454
1455  a = tcr->vs_area;
1456  if (a) {
1457    a->active = a->high;
1458  }
1459  a = tcr->ts_area;
1460  if (a) {
1461    a->active = a->high;
1462  }
1463  a = tcr->cs_area;
1464  if (a) {
1465    a->active = a->high;
1466  }
1467  tcr->valence = TCR_STATE_FOREIGN;
1468  tcr->shutdown_count = 1;
1469  shutdown_thread_tcr(tcr);
1470  tsd_set(lisp_global(TCR_KEY), NULL);
1471}
1472
1473void *
1474current_native_thread_id()
1475{
1476  return ((void *) (natural)
1477#ifdef LINUX
1478#ifdef __NR_gettid
1479          syscall(__NR_gettid)
1480#else
1481          getpid()
1482#endif
1483#endif
1484#ifdef DARWIN
1485          mach_thread_self()
1486#endif
1487#ifdef FREEBSD
1488          pthread_self()
1489#endif
1490#ifdef SOLARIS
1491          pthread_self()
1492#endif
1493#ifdef WINDOWS
1494          GetCurrentThreadId()
1495#endif
1496          );
1497}
1498
1499
1500void
1501thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size)
1502{
1503  area *a, *register_cstack_holding_area_lock(BytePtr, natural);
1504
1505  tcr->osid = current_thread_osid();
1506  tcr->native_thread_id = current_native_thread_id();
1507  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1508  a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size);
1509  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1510  tcr->cs_area = a;
1511  a->owner = tcr;
1512  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
1513    tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1514  }
1515#ifdef LINUX
1516#ifdef PPC
1517#ifndef PPC64
1518  tcr->native_thread_info = current_r2;
1519#endif
1520#endif
1521#endif
1522  tcr->errno_loc = &errno;
1523  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1524#ifdef DARWIN
1525  extern Boolean use_mach_exception_handling;
1526  if (use_mach_exception_handling) {
1527    darwin_exception_init(tcr);
1528  }
1529#endif
1530#ifdef LINUX
1531  linux_exception_init(tcr);
1532#endif
1533#ifdef WINDOWS
1534  tcr->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
1535  tcr->native_thread_info = malloc(sizeof(CONTEXT));
1536#endif
1537  tcr->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1538}
1539
1540/*
1541  Register the specified tcr as "belonging to" the current thread.
1542  Under Darwin, setup Mach exception handling for the thread.
1543  Install cleanup handlers for thread termination.
1544*/
1545void
1546register_thread_tcr(TCR *tcr)
1547{
1548  void *stack_base = NULL;
1549  natural stack_size = 0;
1550
1551  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1552  thread_init_tcr(tcr, stack_base, stack_size);
1553  enqueue_tcr(tcr);
1554}
1555
1556
1557 
1558 
1559#ifndef MAP_GROWSDOWN
1560#define MAP_GROWSDOWN 0
1561#endif
1562
1563Ptr
1564create_stack(natural size)
1565{
1566  Ptr p;
1567  size=align_to_power_of_2(size, log2_page_size);
1568  p = (Ptr) MapMemoryForStack((size_t)size);
1569  if (p != (Ptr)(-1)) {
1570    *((size_t *)p) = size;
1571    return p;
1572  }
1573  allocation_failure(true, size);
1574
1575}
1576
1577void *
1578allocate_stack(natural size)
1579{
1580  return create_stack(size);
1581}
1582
1583void
1584free_stack(void *s)
1585{
1586  size_t size = *((size_t *)s);
1587  UnMapMemory(s, size);
1588}
1589
1590Boolean threads_initialized = false;
1591
1592#ifndef USE_FUTEX
1593#ifdef WINDOWS
1594void
1595count_cpus()
1596{
1597  SYSTEM_INFO si;
1598
1599  GetSystemInfo(&si);
1600  if (si.dwNumberOfProcessors > 1) {
1601    spin_lock_tries = 1024;
1602  }
1603}
1604#else
1605void
1606count_cpus()
1607{
1608#ifdef DARWIN
1609  /* As of OSX 10.4, Darwin doesn't define _SC_NPROCESSORS_ONLN */
1610#include <mach/host_info.h>
1611
1612  struct host_basic_info info;
1613  mach_msg_type_number_t count = HOST_BASIC_INFO_COUNT;
1614 
1615  if (KERN_SUCCESS == host_info(mach_host_self(), HOST_BASIC_INFO,(host_info_t)(&info),&count)) {
1616    if (info.max_cpus > 1) {
1617      spin_lock_tries = 1024;
1618    }
1619  }
1620#else
1621  int n = sysconf(_SC_NPROCESSORS_ONLN);
1622 
1623  if (n > 1) {
1624    spin_lock_tries = 1024;
1625  }
1626#endif
1627}
1628#endif
1629#endif
1630
1631void
1632init_threads(void * stack_base, TCR *tcr)
1633{
1634  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1635#ifdef WINDOWS
1636  lisp_global(TCR_KEY) = TlsAlloc();
1637  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1638  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
1639#else
1640  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1641  thread_signal_setup();
1642#endif
1643
1644#ifndef USE_FUTEX
1645  count_cpus();
1646#endif
1647  threads_initialized = true;
1648}
1649
1650
1651#ifdef WINDOWS
1652unsigned CALLBACK
1653#else
1654void *
1655#endif
1656lisp_thread_entry(void *param)
1657{
1658  thread_activation *activation = (thread_activation *)param;
1659  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1660  LispObj *start_vsp;
1661#ifndef WINDOWS
1662  sigset_t mask, old_mask;
1663
1664  sigemptyset(&mask);
1665  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1666#endif
1667
1668  register_thread_tcr(tcr);
1669
1670#ifndef WINDOWS
1671  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1672#endif
1673  tcr->vs_area->active -= node_size;
1674  *(--tcr->save_vsp) = lisp_nil;
1675  start_vsp = tcr->save_vsp;
1676  enable_fp_exceptions();
1677  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1678  activation->tcr = tcr;
1679  SEM_RAISE(activation->created);
1680  do {
1681    SEM_RAISE(tcr->reset_completion);
1682    SEM_WAIT_FOREVER(tcr->activate);
1683    /* Now go run some lisp code */
1684    start_lisp(TCR_TO_TSD(tcr),0);
1685    tcr->save_vsp = start_vsp;
1686  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1687#ifndef WINDOWS
1688  pthread_cleanup_pop(true);
1689#else
1690  tcr_cleanup(tcr);
1691#endif
1692#ifdef WINDOWS
1693  return 0;
1694#else
1695  return NULL;
1696#endif
1697}
1698
1699typedef 
1700short (*suspendf)();
1701
1702
1703void
1704suspend_current_cooperative_thread()
1705{
1706  static suspendf cooperative_suspend = NULL;
1707  void *xFindSymbol(void*,char*);
1708
1709  if (cooperative_suspend == NULL) {
1710    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
1711  }
1712  if (cooperative_suspend) {
1713    cooperative_suspend(1 /* kCurrentThreadID */,
1714                        1 /* kStoppedThreadState */,
1715                        0 /* kAnyThreadID */);
1716  }
1717}
1718
1719void *
1720cooperative_thread_startup(void *arg)
1721{
1722
1723  TCR *tcr = get_tcr(0);
1724  LispObj *start_vsp;
1725
1726  if (!tcr) {
1727    return NULL;
1728  }
1729#ifndef WINDOWS
1730  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1731#endif
1732  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1733  start_vsp = tcr->save_vsp;
1734  do {
1735    SEM_RAISE(tcr->reset_completion);
1736    suspend_current_cooperative_thread();
1737     
1738    start_lisp(tcr, 0);
1739    tcr->save_vsp = start_vsp;
1740  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1741#ifndef WINDOWS
1742  pthread_cleanup_pop(true);
1743#else
1744  tcr_cleanup(tcr);
1745#endif
1746}
1747
1748void *
1749xNewThread(natural control_stack_size,
1750           natural value_stack_size,
1751           natural temp_stack_size)
1752
1753{
1754  thread_activation activation;
1755
1756
1757  activation.tsize = temp_stack_size;
1758  activation.vsize = value_stack_size;
1759  activation.tcr = 0;
1760  activation.created = new_semaphore(0);
1761  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1762                           NULL, 
1763                           lisp_thread_entry,
1764                           (void *) &activation)) {
1765   
1766    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1767  }
1768  destroy_semaphore(&activation.created); 
1769  return TCR_TO_TSD(activation.tcr);
1770}
1771
1772Boolean
1773active_tcr_p(TCR *q)
1774{
1775  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1776 
1777  do {
1778    if (p == q) {
1779      return true;
1780    }
1781    p = p->next;
1782  } while (p != head);
1783  return false;
1784}
1785
1786#ifdef WINDOWS
1787OSErr
1788xDisposeThread(TCR *tcr)
1789{
1790  return 0;                     /* I don't think that this is ever called. */
1791}
1792#else
1793OSErr
1794xDisposeThread(TCR *tcr)
1795{
1796  if (tcr != (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR))) {
1797    if (active_tcr_p(tcr) && (tcr != get_tcr(false))) {
1798      pthread_cancel((pthread_t)(tcr->osid));
1799      return 0;
1800    }
1801  }
1802  return -50;
1803}
1804#endif
1805
1806OSErr
1807xYieldToThread(TCR *target)
1808{
1809  Bug(NULL, "xYieldToThread ?");
1810  return 0;
1811}
1812 
1813OSErr
1814xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1815{
1816  Bug(NULL, "xThreadCurrentStackSpace ?");
1817  return 0;
1818}
1819
1820
1821#ifdef WINDOWS
1822LispObj
1823create_system_thread(size_t stack_size,
1824                     void* stackaddr,
1825                     unsigned CALLBACK (*start_routine)(void *),
1826                     void* param)
1827{
1828  HANDLE thread_handle;
1829
1830  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1831
1832  thread_handle = (HANDLE)_beginthreadex(NULL, 
1833                                         0/*stack_size*/,
1834                                         start_routine,
1835                                         param,
1836                                         0, 
1837                                         NULL);
1838
1839  if (thread_handle == NULL) {
1840    wperror("CreateThread");
1841  }
1842  return (LispObj) ptr_to_lispobj(thread_handle);
1843}
1844#else
1845LispObj
1846create_system_thread(size_t stack_size,
1847                     void* stackaddr,
1848                     void* (*start_routine)(void *),
1849                     void* param)
1850{
1851  pthread_attr_t attr;
1852  pthread_t returned_thread = (pthread_t) 0;
1853  TCR *current = get_tcr(true);
1854
1855  pthread_attr_init(&attr);
1856  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1857
1858  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1859    stack_size = PTHREAD_STACK_MIN;
1860  }
1861
1862  stack_size = ensure_stack_limit(stack_size);
1863  if (stackaddr != NULL) {
1864    /* Size must have been specified.  Sort of makes sense ... */
1865#ifdef DARWIN
1866    Fatal("no pthread_attr_setsetstack. "," Which end of stack does address refer to?");
1867#else
1868    pthread_attr_setstack(&attr, stackaddr, stack_size);
1869#endif
1870  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1871    pthread_attr_setstacksize(&attr,stack_size);
1872  }
1873
1874  /*
1875     I think that's just about enough ... create the thread.
1876     Well ... not quite enough.  In Leopard (at least), many
1877     pthread routines grab an internal spinlock when validating
1878     their arguments.  If we suspend a thread that owns this
1879     spinlock, we deadlock.  We can't in general keep that
1880     from happening: if arbitrary C code is suspended while
1881     it owns the spinlock, we still deadlock.  It seems that
1882     the best that we can do is to keep -this- code from
1883     getting suspended (by grabbing TCR_AREA_LOCK)
1884  */
1885  LOCK(lisp_global(TCR_AREA_LOCK),current);
1886  pthread_create(&returned_thread, &attr, start_routine, param);
1887  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1888  pthread_attr_destroy(&attr);
1889  return (LispObj) ptr_to_lispobj(returned_thread);
1890}
1891#endif
1892
1893TCR *
1894get_tcr(Boolean create)
1895{
1896#ifdef HAVE_TLS
1897  TCR *current = current_tcr;
1898#else
1899  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1900  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1901#endif
1902
1903  if ((current == NULL) && create) {
1904    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1905      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1906    int i, nbindwords = 0;
1907    extern natural initial_stack_size;
1908   
1909    /* Make one. */
1910    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1911    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1912    register_thread_tcr(current);
1913#ifdef DEBUG_TCR_CREATION
1914#ifndef WINDOWS
1915    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
1916#endif
1917#endif
1918    current->vs_area->active -= node_size;
1919    *(--current->save_vsp) = lisp_nil;
1920#ifdef PPC
1921#define NSAVEREGS 8
1922#endif
1923#ifdef X8664
1924#define NSAVEREGS 4
1925#endif
1926#ifdef X8632
1927#define NSAVEREGS 0
1928#endif
1929    for (i = 0; i < NSAVEREGS; i++) {
1930      *(--current->save_vsp) = 0;
1931      current->vs_area->active -= node_size;
1932    }
1933    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1934    for (i = 0; i < nbindwords; i++) {
1935      *(--current->save_vsp) = 0;
1936      current->vs_area->active -= node_size;
1937    }
1938    current->shutdown_count = 1;
1939    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1940
1941  }
1942 
1943  return current;
1944}
1945
1946#ifdef WINDOWS
1947void *
1948pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
1949{
1950  /* Thread has started to return from an exception. */
1951  if (where < restore_windows_context_iret) {
1952    /* In the process of restoring registers; context still in
1953       %rcx.  Just make our suspend_context be the context
1954       we're trying to restore, so that we'll resume from
1955       the suspend in the same context that we're trying to
1956       restore */
1957#ifdef WIN_64
1958    *pcontext = * (CONTEXT *)(pcontext->Rcx);
1959#else
1960    *pcontext = * (CONTEXT *)(pcontext->Ecx);
1961#endif
1962  } else {
1963    /* Most of the context has already been restored; fix %rcx
1964       if need be, then restore ss:rsp, cs:rip, and flags. */
1965#ifdef WIN_64
1966    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1967
1968    pcontext->Rip = iret_frame->Rip;
1969    pcontext->SegCs = (WORD) iret_frame->Cs;
1970    pcontext->EFlags = (DWORD) iret_frame->Rflags;
1971    pcontext->Rsp = iret_frame->Rsp;
1972    pcontext->SegSs = (WORD) iret_frame->Ss;
1973#else
1974    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
1975
1976    pcontext->Eip = iret_frame->Eip;
1977    pcontext->SegCs = (WORD) iret_frame->Cs;
1978    pcontext->EFlags = (DWORD) iret_frame->EFlags;
1979    pcontext->Esp += sizeof(ia32_iret_frame);
1980#endif
1981  }
1982  tcr->pending_exception_context = NULL;
1983  tcr->interrupt_context = NULL;
1984}
1985
1986Boolean
1987suspend_tcr(TCR *tcr)
1988{
1989  int suspend_count = atomic_incf(&(tcr->suspend_count));
1990  DWORD rc;
1991  if (suspend_count == 1) {
1992    CONTEXT  *pcontext = (CONTEXT *)tcr->native_thread_info;
1993    HANDLE hthread = (HANDLE)(tcr->osid);
1994    pc where;
1995    area *cs = tcr->cs_area;
1996    LispObj foreign_rsp;
1997
1998    if (hthread == NULL) {
1999      return false;
2000    }
2001    rc = SuspendThread(hthread);
2002    if (rc == -1) {
2003      /* If the thread's simply dead, we should handle that here */
2004      return false;
2005    }
2006    pcontext->ContextFlags = CONTEXT_ALL;
2007    rc = GetThreadContext(hthread, pcontext);
2008    if (rc == 0) {
2009      return false;
2010    }
2011    where = (pc)(xpPC(pcontext));
2012
2013    if (tcr->valence == TCR_STATE_LISP) {
2014      if ((where >= restore_windows_context_start) &&
2015          (where < restore_windows_context_end)) {
2016        pc_luser_restore_windows_context(pcontext, tcr, where);
2017      } else {
2018        area *ts = tcr->ts_area;
2019        /* If we're in the lisp heap, or in x86-spentry??.o, or in
2020           x86-subprims??.o, or in the subprims jump table at #x15000,
2021           or on the tstack ... we're just executing lisp code.  Otherwise,
2022           we got an exception while executing lisp code, but haven't
2023           entered the handler yet (still in Windows exception glue
2024           or switching stacks or something.)  In the latter case, we
2025           basically want to get to he handler and have it notice
2026           the pending exception request, and suspend the thread at that
2027           point. */
2028        if (!((where < (pc)lisp_global(HEAP_END)) &&
2029              (where >= (pc)lisp_global(HEAP_START))) &&
2030            !((where < spentry_end) && (where >= spentry_start)) &&
2031            !((where < subprims_end) && (where >= subprims_start)) &&
2032            !((where < (pc) 0x16000) &&
2033              (where >= (pc) 0x15000)) &&
2034            !((where < (pc) (ts->high)) &&
2035              (where >= (pc) (ts->low)))) {
2036          /* The thread has lisp valence, but is not executing code
2037             where we expect lisp code to be and is not exiting from
2038             an exception handler.  That pretty much means that it's
2039             on its way into an exception handler; we have to handshake
2040             until it enters an exception-wait state. */
2041          /* There are likely race conditions here */
2042          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2043          ResumeThread(hthread);
2044          SEM_WAIT_FOREVER(tcr->suspend);
2045          SuspendThread(hthread);
2046          /* The thread is either waiting for its resume semaphore to
2047             be signaled or is about to wait.  Signal it now, while
2048             the thread's suspended. */
2049          SEM_RAISE(tcr->resume);
2050          pcontext->ContextFlags = CONTEXT_ALL;
2051          GetThreadContext(hthread, pcontext);
2052        }
2053      }
2054#if 0
2055    } else {
2056      if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) {
2057        if (!tcr->pending_exception_context) {
2058          FBug(pcontext, "we're confused here.");
2059        }
2060        *pcontext = *tcr->pending_exception_context;
2061        tcr->pending_exception_context = NULL;
2062        tcr->valence = TCR_STATE_LISP;
2063      }
2064#endif
2065    }
2066    tcr->suspend_context = pcontext;
2067    return true;
2068  }
2069  return false;
2070}
2071#else
2072Boolean
2073suspend_tcr(TCR *tcr)
2074{
2075  int suspend_count = atomic_incf(&(tcr->suspend_count));
2076  pthread_t thread;
2077  if (suspend_count == 1) {
2078    thread = (pthread_t)(tcr->osid);
2079    if ((thread != (pthread_t) 0) &&
2080        (pthread_kill(thread, thread_suspend_signal) == 0)) {
2081      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2082    } else {
2083      /* A problem using pthread_kill.  On Darwin, this can happen
2084         if the thread has had its signal mask surgically removed
2085         by pthread_exit.  If the native (Mach) thread can be suspended,
2086         do that and return true; otherwise, flag the tcr as belonging
2087         to a dead thread by setting tcr->osid to 0.
2088      */
2089      tcr->osid = 0;
2090      return false;
2091    }
2092    return true;
2093  }
2094  return false;
2095}
2096#endif
2097
2098#ifdef WINDOWS
2099Boolean
2100tcr_suspend_ack(TCR *tcr)
2101{
2102  return true;
2103}
2104#else
2105Boolean
2106tcr_suspend_ack(TCR *tcr)
2107{
2108  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
2109    SEM_WAIT_FOREVER(tcr->suspend);
2110    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2111  }
2112  return true;
2113}
2114#endif
2115     
2116
2117Boolean
2118kill_tcr(TCR *tcr)
2119{
2120  TCR *current = get_tcr(true);
2121  Boolean result = false;
2122
2123  LOCK(lisp_global(TCR_AREA_LOCK),current);
2124  {
2125    LispObj osid = tcr->osid;
2126   
2127    if (osid) {
2128      result = true;
2129#ifdef WINDOWS
2130      /* What we really want to de hear is (something like)
2131         forcing the thread to run quit_handler().  For now,
2132         mark the TCR as dead and kill thw Windows thread. */
2133      tcr->osid = 0;
2134      if (!TerminateThread((HANDLE)osid, 0)) {
2135        result = false;
2136      } else {
2137        shutdown_thread_tcr(tcr);
2138      }
2139#else
2140      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2141        result = false;
2142      }
2143#endif
2144    }
2145  }
2146  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2147  return result;
2148}
2149
2150Boolean
2151lisp_suspend_tcr(TCR *tcr)
2152{
2153  Boolean suspended;
2154  TCR *current = get_tcr(true);
2155 
2156  LOCK(lisp_global(TCR_AREA_LOCK),current);
2157  suspended = suspend_tcr(tcr);
2158  if (suspended) {
2159    while (!tcr_suspend_ack(tcr));
2160  }
2161  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2162  return suspended;
2163}
2164         
2165#ifdef WINDOWS
2166Boolean
2167resume_tcr(TCR *tcr)
2168{
2169  int suspend_count = atomic_decf(&(tcr->suspend_count)), err;
2170  DWORD rc;
2171  if (suspend_count == 0) {
2172    CONTEXT *context = tcr->suspend_context;
2173    HANDLE hthread = (HANDLE)(tcr->osid);
2174
2175    if (context) {
2176      context->ContextFlags = CONTEXT_ALL;
2177      tcr->suspend_context = NULL;
2178      SetThreadContext(hthread,context);
2179      rc = ResumeThread(hthread);
2180      if (rc == -1) {
2181        wperror("ResumeThread");
2182        return false;
2183      }
2184      return true;
2185    }
2186  }
2187  return false;
2188}   
2189#else
2190Boolean
2191resume_tcr(TCR *tcr)
2192{
2193  int suspend_count = atomic_decf(&(tcr->suspend_count));
2194  if (suspend_count == 0) {
2195    void *s = (tcr->resume);
2196    if (s != NULL) {
2197      SEM_RAISE(s);
2198      return true;
2199    }
2200  }
2201  return false;
2202}
2203#endif
2204
2205   
2206
2207
2208Boolean
2209lisp_resume_tcr(TCR *tcr)
2210{
2211  Boolean resumed;
2212  TCR *current = get_tcr(true);
2213 
2214  LOCK(lisp_global(TCR_AREA_LOCK),current);
2215  resumed = resume_tcr(tcr);
2216  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2217  return resumed;
2218}
2219
2220
2221TCR *freed_tcrs = NULL;
2222
2223void
2224enqueue_freed_tcr (TCR *tcr)
2225{
2226#ifndef HAVE_TLS
2227  tcr->next = freed_tcrs;
2228  freed_tcrs = tcr;
2229#endif
2230}
2231
2232/* It's not clear that we can safely condemn a dead tcr's areas, since
2233   we may not be able to call free() if a suspended thread owns a
2234   malloc lock. At least make the areas appear to be empty.
2235*/
2236   
2237
2238void
2239normalize_dead_tcr_areas(TCR *tcr)
2240{
2241  area *a;
2242
2243  a = tcr->vs_area;
2244  if (a) {
2245    a->active = a->high;
2246  }
2247
2248  a = tcr->ts_area;
2249  if (a) {
2250    a->active = a->high;
2251  }
2252
2253  a = tcr->cs_area;
2254  if (a) {
2255    a->active = a->high;
2256  }
2257}
2258   
2259void
2260free_freed_tcrs ()
2261{
2262  TCR *current, *next;
2263
2264  for (current = freed_tcrs; current; current = next) {
2265    next = current->next;
2266#ifndef HAVE_TLS
2267#ifdef WIN32
2268    free(current->allocated);
2269#else
2270    free(current);
2271#endif
2272#endif
2273  }
2274  freed_tcrs = NULL;
2275}
2276
2277void
2278suspend_other_threads(Boolean for_gc)
2279{
2280  TCR *current = get_tcr(true), *other, *next;
2281  int dead_tcr_count = 0;
2282  Boolean all_acked;
2283
2284  LOCK(lisp_global(TCR_AREA_LOCK), current);
2285  for (other = current->next; other != current; other = other->next) {
2286    if ((other->osid != 0)) {
2287      suspend_tcr(other);
2288      if (other->osid == 0) {
2289        dead_tcr_count++;
2290      }
2291    } else {
2292      dead_tcr_count++;
2293    }
2294  }
2295
2296  do {
2297    all_acked = true;
2298    for (other = current->next; other != current; other = other->next) {
2299      if ((other->osid != 0)) {
2300        if (!tcr_suspend_ack(other)) {
2301          all_acked = false;
2302        }
2303      }
2304    }
2305  } while(! all_acked);
2306
2307     
2308
2309  /* All other threads are suspended; can safely delete dead tcrs now */
2310  if (dead_tcr_count) {
2311    for (other = current->next; other != current; other = next) {
2312      next = other->next;
2313      if ((other->osid == 0))  {
2314        normalize_dead_tcr_areas(other);
2315        dequeue_tcr(other);
2316        enqueue_freed_tcr(other);
2317      }
2318    }
2319  }
2320}
2321
2322void
2323lisp_suspend_other_threads()
2324{
2325  suspend_other_threads(false);
2326}
2327
2328void
2329resume_other_threads(Boolean for_gc)
2330{
2331  TCR *current = get_tcr(true), *other;
2332  for (other = current->next; other != current; other = other->next) {
2333    if ((other->osid != 0)) {
2334      resume_tcr(other);
2335    }
2336  }
2337  free_freed_tcrs();
2338  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2339}
2340
2341void
2342lisp_resume_other_threads()
2343{
2344  resume_other_threads(false);
2345}
2346
2347
2348
2349rwlock *
2350rwlock_new()
2351{
2352  extern int cache_block_size;
2353
2354  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2355  rwlock *rw = NULL;;
2356 
2357  if (p) {
2358    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2359    rw->malloced_ptr = p;
2360#ifndef USE_FUTEX
2361    rw->reader_signal = new_semaphore(0);
2362    rw->writer_signal = new_semaphore(0);
2363    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2364      if (rw->reader_signal) {
2365        destroy_semaphore(&(rw->reader_signal));
2366      } else {
2367        destroy_semaphore(&(rw->writer_signal));
2368      }
2369      free(rw);
2370      rw = NULL;
2371    }
2372#endif
2373  }
2374  return rw;
2375}
2376
2377     
2378/*
2379  Try to get read access to a multiple-readers/single-writer lock.  If
2380  we already have read access, return success (indicating that the
2381  lock is held another time.  If we already have write access to the
2382  lock ... that won't work; return EDEADLK.  Wait until no other
2383  thread has or is waiting for write access, then indicate that we
2384  hold read access once.
2385*/
2386#ifndef USE_FUTEX
2387int
2388rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2389{
2390  int err = 0;
2391 
2392  LOCK_SPINLOCK(rw->spin, tcr);
2393
2394  if (rw->writer == tcr) {
2395    RELEASE_SPINLOCK(rw->spin);
2396    return EDEADLK;
2397  }
2398
2399  while (rw->blocked_writers || (rw->state > 0)) {
2400    rw->blocked_readers++;
2401    RELEASE_SPINLOCK(rw->spin);
2402    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2403    LOCK_SPINLOCK(rw->spin,tcr);
2404    rw->blocked_readers--;
2405    if (err == EINTR) {
2406      err = 0;
2407    }
2408    if (err) {
2409      RELEASE_SPINLOCK(rw->spin);
2410      return err;
2411    }
2412  }
2413  rw->state--;
2414  RELEASE_SPINLOCK(rw->spin);
2415  return err;
2416}
2417#else
2418int
2419rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2420{
2421  natural waitval;
2422
2423  lock_futex(&rw->spin);
2424
2425  if (rw->writer == tcr) {
2426    unlock_futex(&rw->spin);
2427    return EDEADLOCK;
2428  }
2429  while (1) {
2430    if (rw->writer == NULL) {
2431      --rw->state;
2432      unlock_futex(&rw->spin);
2433      return 0;
2434    }
2435    rw->blocked_readers++;
2436    waitval = rw->reader_signal;
2437    unlock_futex(&rw->spin);
2438    futex_wait(&rw->reader_signal,waitval);
2439    lock_futex(&rw->spin);
2440    rw->blocked_readers--;
2441  }
2442  return 0;
2443}
2444#endif   
2445
2446
2447/*
2448  Try to obtain write access to the lock.
2449  It is an error if we already have read access, but it's hard to
2450  detect that.
2451  If we already have write access, increment the count that indicates
2452  that.
2453  Otherwise, wait until the lock is not held for reading or writing,
2454  then assert write access.
2455*/
2456
2457#ifndef USE_FUTEX
2458int
2459rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2460{
2461  int err = 0;
2462
2463  LOCK_SPINLOCK(rw->spin,tcr);
2464  if (rw->writer == tcr) {
2465    rw->state++;
2466    RELEASE_SPINLOCK(rw->spin);
2467    return 0;
2468  }
2469
2470  while (rw->state != 0) {
2471    rw->blocked_writers++;
2472    RELEASE_SPINLOCK(rw->spin);
2473    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2474    LOCK_SPINLOCK(rw->spin,tcr);
2475    rw->blocked_writers--;
2476    if (err == EINTR) {
2477      err = 0;
2478    }
2479    if (err) {
2480      RELEASE_SPINLOCK(rw->spin);
2481      return err;
2482    }
2483  }
2484  rw->state = 1;
2485  rw->writer = tcr;
2486  RELEASE_SPINLOCK(rw->spin);
2487  return err;
2488}
2489
2490#else
2491int
2492rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2493{
2494  int err = 0;
2495  natural waitval;
2496
2497  lock_futex(&rw->spin);
2498  if (rw->writer == tcr) {
2499    rw->state++;
2500    unlock_futex(&rw->spin);
2501    return 0;
2502  }
2503
2504  while (rw->state != 0) {
2505    rw->blocked_writers++;
2506    waitval = rw->writer_signal;
2507    unlock_futex(&rw->spin);
2508    futex_wait(&rw->writer_signal,waitval);
2509    lock_futex(&rw->spin);
2510    rw->blocked_writers--;
2511  }
2512  rw->state = 1;
2513  rw->writer = tcr;
2514  unlock_futex(&rw->spin);
2515  return err;
2516}
2517#endif
2518
2519/*
2520  Sort of the same as above, only return EBUSY if we'd have to wait.
2521*/
2522#ifndef USE_FUTEX
2523int
2524rwlock_try_wlock(rwlock *rw, TCR *tcr)
2525{
2526  int ret = EBUSY;
2527
2528  LOCK_SPINLOCK(rw->spin,tcr);
2529  if (rw->writer == tcr) {
2530    rw->state++;
2531    ret = 0;
2532  } else {
2533    if (rw->state == 0) {
2534      rw->writer = tcr;
2535      rw->state = 1;
2536      ret = 0;
2537    }
2538  }
2539  RELEASE_SPINLOCK(rw->spin);
2540  return ret;
2541}
2542#else
2543int
2544rwlock_try_wlock(rwlock *rw, TCR *tcr)
2545{
2546  int ret = EBUSY;
2547
2548  lock_futex(&rw->spin);
2549  if (rw->writer == tcr) {
2550    rw->state++;
2551    ret = 0;
2552  } else {
2553    if (rw->state == 0) {
2554      rw->writer = tcr;
2555      rw->state = 1;
2556      ret = 0;
2557    }
2558  }
2559  unlock_futex(&rw->spin);
2560  return ret;
2561}
2562#endif
2563
2564#ifndef USE_FUTEX
2565int
2566rwlock_try_rlock(rwlock *rw, TCR *tcr)
2567{
2568  int ret = EBUSY;
2569
2570  LOCK_SPINLOCK(rw->spin,tcr);
2571  if (rw->state <= 0) {
2572    --rw->state;
2573    ret = 0;
2574  }
2575  RELEASE_SPINLOCK(rw->spin);
2576  return ret;
2577}
2578#else
2579int
2580rwlock_try_rlock(rwlock *rw, TCR *tcr)
2581{
2582  int ret = EBUSY;
2583
2584  lock_futex(&rw->spin);
2585  if (rw->state <= 0) {
2586    --rw->state;
2587    ret = 0;
2588  }
2589  unlock_futex(&rw->spin);
2590  return ret;
2591}
2592#endif
2593
2594
2595
2596#ifndef USE_FUTEX
2597int
2598rwlock_unlock(rwlock *rw, TCR *tcr)
2599{
2600
2601  int err = 0;
2602  natural blocked_readers = 0;
2603
2604  LOCK_SPINLOCK(rw->spin,tcr);
2605  if (rw->state > 0) {
2606    if (rw->writer != tcr) {
2607      err = EINVAL;
2608    } else {
2609      --rw->state;
2610      if (rw->state == 0) {
2611        rw->writer = NULL;
2612      }
2613    }
2614  } else {
2615    if (rw->state < 0) {
2616      ++rw->state;
2617    } else {
2618      err = EINVAL;
2619    }
2620  }
2621  if (err) {
2622    RELEASE_SPINLOCK(rw->spin);
2623    return err;
2624  }
2625 
2626  if (rw->state == 0) {
2627    if (rw->blocked_writers) {
2628      SEM_RAISE(rw->writer_signal);
2629    } else {
2630      blocked_readers = rw->blocked_readers;
2631      if (blocked_readers) {
2632        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2633      }
2634    }
2635  }
2636  RELEASE_SPINLOCK(rw->spin);
2637  return 0;
2638}
2639#else
2640int
2641rwlock_unlock(rwlock *rw, TCR *tcr)
2642{
2643
2644  int err = 0;
2645
2646  lock_futex(&rw->spin);
2647  if (rw->state > 0) {
2648    if (rw->writer != tcr) {
2649      err = EINVAL;
2650    } else {
2651      --rw->state;
2652      if (rw->state == 0) {
2653        rw->writer = NULL;
2654      }
2655    }
2656  } else {
2657    if (rw->state < 0) {
2658      ++rw->state;
2659    } else {
2660      err = EINVAL;
2661    }
2662  }
2663  if (err) {
2664    unlock_futex(&rw->spin);
2665    return err;
2666  }
2667 
2668  if (rw->state == 0) {
2669    if (rw->blocked_writers) {
2670      ++rw->writer_signal;
2671      unlock_futex(&rw->spin);
2672      futex_wake(&rw->writer_signal,1);
2673      return 0;
2674    }
2675    if (rw->blocked_readers) {
2676      ++rw->reader_signal;
2677      unlock_futex(&rw->spin);
2678      futex_wake(&rw->reader_signal, INT_MAX);
2679      return 0;
2680    }
2681  }
2682  unlock_futex(&rw->spin);
2683  return 0;
2684}
2685#endif
2686
2687       
2688void
2689rwlock_destroy(rwlock *rw)
2690{
2691#ifndef USE_FUTEX
2692  destroy_semaphore((void **)&rw->reader_signal);
2693  destroy_semaphore((void **)&rw->writer_signal);
2694#endif
2695  postGCfree((void *)(rw->malloced_ptr));
2696}
2697
2698
2699
Note: See TracBrowser for help on using the repository browser.