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

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

Try to handle the case of suspending a Windows thread that's in the
middle of restore_windows_context() more sanely/completely, especially
on win32.

Move the code that's concerned with this into a separate function
(pc_luser_restore_windows_context), which always overwrites some or
all of the context as of thread suspend with the context that the
suspended thread is trying to restore (e.g., whatever pc-lusering
we do always has the effect of causing the thread to resume at the
point where restore_windows_context() would have completed.

Since restore_windows_context() is only used to return from an
exception, clear tcr->pending_exception_context when we've got
things to a known point.

Define ia32_iret_frame in x86-constants32.h.

Use iret to restore flags/cs:eip on ia32.

Ensure that the last thing that win32_restore_context() does before
the iret is to reload %rcx/%ecx from the context (kept in %rcx/%ecx),
so suspending in the middle of restore_lisp_context() - before the iret -
just has to find the context being restored in %rcx/%ecx (it doesn't
matter where we are in the process of restoring it.)

If we're at the iret, just emulate the (machine-specific) effects of
the iret.

Need to make sure that this isn't grossly broken on win64, and need
to look at interrupt (vice suspend) code.

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