source: branches/win64/lisp-kernel/thread_manager.c @ 9557

Last change on this file since 9557 was 9557, checked in by gb, 13 years ago

Comparison of foreign_rsp to csarea bounds in suspend_tcr() was backward.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 46.6 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/*
21   If we suspend via signals - and if the "suspend" signal is maked
22   in the handler for that signal - then it's not possible to suspend
23   a thread that's still waiting to be resumed (which is what
24   WAIT_FOR_RESUME_ACK is all about.)
25*/
26#define WAIT_FOR_RESUME_ACK 0
27#define RESUME_VIA_RESUME_SEMAPHORE 1
28#define SUSPEND_RESUME_VERBOSE 0
29
30typedef struct {
31  TCR *tcr;
32  natural vsize, tsize;
33  void *created;
34} thread_activation;
35
36#ifdef HAVE_TLS
37__thread TCR current_tcr;
38#endif
39
40extern natural
41store_conditional(natural*, natural, natural);
42
43extern signed_natural
44atomic_swap(signed_natural*, signed_natural);
45
46#ifdef USE_FUTEX
47#define futex_wait(futex,val) syscall(SYS_futex,futex,FUTEX_WAIT,val)
48#define futex_wake(futex,n) syscall(SYS_futex,futex,FUTEX_WAKE,n)
49#define FUTEX_AVAIL (0)
50#define FUTEX_LOCKED (1)
51#define FUTEX_CONTENDED (2)
52#endif
53
54#ifdef WINDOWS
55extern pc spentry_start, spentry_end,subprims_start,subprims_end;
56extern pc restore_win64_context_start, restore_win64_context_end,
57  restore_win64_context_load_rcx, restore_win64_context_iret;
58
59extern void interrupt_handler(int, siginfo_t *, ExceptionInformation *);
60
61int
62raise_thread_interrupt(TCR *target)
63{
64  /* GCC doesn't align CONTEXT corrcectly */
65  char _contextbuf[sizeof(CONTEXT)+__alignof(CONTEXT)];
66  CONTEXT  *pcontext;
67  HANDLE hthread = (HANDLE)(target->osid);
68  pc where;
69  area *cs = target->cs_area, *ts = target->cs_area;
70  DWORD rc;
71
72  pcontext = (CONTEXT *)((((natural)&_contextbuf)+15)&~15);
73  rc = SuspendThread(hthread);
74  if (rc == -1) {
75    return -1;
76  }
77  /* What if the suspend count is > 1 at this point ?  I don't think
78     that that matters, but I'm not sure */
79  pcontext->ContextFlags = CONTEXT_ALL;
80  rc = GetThreadContext(hthread, pcontext);
81  if (rc == 0) {
82    wperror("GetThreadContext");
83  }
84  where = (pc)(xpPC(pcontext));
85 
86  if ((target->valence != TCR_STATE_LISP) ||
87      (TCR_INTERRUPT_LEVEL(target) < 0) ||
88      (target->unwinding != 0) ||
89      (!((where < (pc)lisp_global(HEAP_END)) &&
90         (where >= (pc)lisp_global(HEAP_START))) &&
91       !((where < spentry_end) && (where >= spentry_start)) &&
92       !((where < subprims_end) && (where >= subprims_start)) &&
93       !((where < (pc) 0x16000) &&
94         (where >= (pc) 0x15000)) &&
95       !((where < (pc) (ts->high)) &&
96         (where >= (pc) (ts->low))))) {
97    /* If the thread's in a blocking syscall, it'd be nice to
98       get it out of that state here. */
99    target->interrupt_pending = (1LL << (nbits_in_word - 1LL));
100    ResumeThread(hthread);
101    return 0;
102  } else {
103    /* Thread is running lisp code with interupts enabled.  Set it
104       so that it calls out and then returns to the context,
105       handling any necessary pc-lusering. */
106    LispObj foreign_rsp = (((LispObj)(target->foreign_sp))-128)&~15;
107    CONTEXT *icontext = ((CONTEXT *) foreign_rsp) -1;
108    icontext = (CONTEXT *)(((LispObj)icontext)&~15);
109   
110    *icontext = *pcontext;
111   
112    xpGPR(pcontext,REG_RCX) = SIGNAL_FOR_PROCESS_INTERRUPT;
113    xpGPR(pcontext,REG_RDX) = 0;
114    xpGPR(pcontext,REG_R8) = (LispObj) icontext;
115    xpGPR(pcontext,REG_RSP) = ((LispObj *)icontext)-1;
116    *(((LispObj *)icontext)-1) = (LispObj)raise_thread_interrupt;
117    xpPC(pcontext) = (pc)interrupt_handler;
118    SetThreadContext(hthread,pcontext);
119    ResumeThread(hthread);
120    return 0;
121  }
122}
123
124#else
125int
126raise_thread_interrupt(TCR *target)
127{
128#ifdef DARWIN_not_yet
129  if (use_mach_exception_handling) {
130    return mach_raise_thread_interrupt(target);
131  }
132#endif
133 return pthread_kill((pthread_t)target->osid, SIGNAL_FOR_PROCESS_INTERRUPT);
134}
135#endif
136
137signed_natural
138atomic_incf_by(signed_natural *ptr, signed_natural by)
139{
140  signed_natural old, new;
141  do {
142    old = *ptr;
143    new = old+by;
144  } while (store_conditional((natural *)ptr, (natural) old, (natural) new) !=
145           (natural) old);
146  return new;
147}
148
149signed_natural
150atomic_incf(signed_natural *ptr)
151{
152  return atomic_incf_by(ptr, 1);
153}
154
155signed_natural
156atomic_decf(signed_natural *ptr)
157{
158  signed_natural old, new;
159  do {
160    old = *ptr;
161    new = old == 0 ? old : old-1;
162  } while (store_conditional((natural *)ptr, (natural) old, (natural) new) !=
163           (natural) old);
164  return old-1;
165}
166
167
168#ifndef USE_FUTEX
169int spin_lock_tries = 1;
170
171void
172get_spin_lock(signed_natural *p, TCR *tcr)
173{
174  int i, n = spin_lock_tries;
175 
176  while (1) {
177    for (i = 0; i < n; i++) {
178      if (atomic_swap(p,(signed_natural)tcr) == 0) {
179        return;
180      }
181    }
182#ifndef WINDOWS
183    sched_yield();
184#else
185    SwitchToThread();
186#endif
187  }
188}
189#endif
190
191#ifndef USE_FUTEX
192int
193lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
194{
195
196  if (tcr == NULL) {
197    tcr = get_tcr(true);
198  }
199  if (m->owner == tcr) {
200    m->count++;
201    return 0;
202  }
203  while (1) {
204    LOCK_SPINLOCK(m->spinlock,tcr);
205    ++m->avail;
206    if (m->avail == 1) {
207      m->owner = tcr;
208      m->count = 1;
209      RELEASE_SPINLOCK(m->spinlock);
210      break;
211    }
212    RELEASE_SPINLOCK(m->spinlock);
213    SEM_WAIT_FOREVER(m->signal);
214  }
215  return 0;
216}
217
218#else /* USE_FUTEX */
219
220static void inline
221lock_futex(natural *p)
222{
223 
224  while (1) {
225    if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) {
226      return;
227    }
228    while (1) {
229      if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) {
230        return;
231      }
232      futex_wait(p,FUTEX_CONTENDED);
233    }
234  }
235}
236
237static void inline
238unlock_futex(natural *p)
239{
240  if (atomic_decf(p) != FUTEX_AVAIL) {
241    *p = FUTEX_AVAIL;
242    futex_wake(p,INT_MAX);
243  }
244}
245   
246int
247lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
248{
249  natural val;
250  if (tcr == NULL) {
251    tcr = get_tcr(true);
252  }
253  if (m->owner == tcr) {
254    m->count++;
255    return 0;
256  }
257  lock_futex(&m->avail);
258  m->owner = tcr;
259  m->count = 1;
260  return 0;
261}
262#endif /* USE_FUTEX */
263
264
265#ifndef USE_FUTEX 
266int
267unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
268{
269  int ret = EPERM, pending;
270
271  if (tcr == NULL) {
272    tcr = get_tcr(true);
273  }
274
275  if (m->owner == tcr) {
276    --m->count;
277    if (m->count == 0) {
278      LOCK_SPINLOCK(m->spinlock,tcr);
279      m->owner = NULL;
280      pending = m->avail-1 + m->waiting;     /* Don't count us */
281      m->avail = 0;
282      --pending;
283      if (pending > 0) {
284        m->waiting = pending;
285      } else {
286        m->waiting = 0;
287      }
288      RELEASE_SPINLOCK(m->spinlock);
289      if (pending >= 0) {
290        SEM_RAISE(m->signal);
291      }
292    }
293    ret = 0;
294  }
295  return ret;
296}
297#else /* USE_FUTEX */
298int
299unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr)
300{
301  int ret = EPERM, pending;
302
303   if (tcr == NULL) {
304    tcr = get_tcr(true);
305  }
306
307  if (m->owner == tcr) {
308    --m->count;
309    if (m->count == 0) {
310      m->owner = NULL;
311      unlock_futex(&m->avail);
312    }
313    ret = 0;
314  }
315  return ret;
316}
317#endif /* USE_FUTEX */
318
319void
320destroy_recursive_lock(RECURSIVE_LOCK m)
321{
322#ifndef USE_FUTEX
323  destroy_semaphore((void **)&m->signal);
324#endif
325  postGCfree((void *)(m->malloced_ptr));
326}
327
328/*
329  If we're already the owner (or if the lock is free), lock it
330  and increment the lock count; otherwise, return EBUSY without
331  waiting.
332*/
333
334#ifndef USE_FUTEX
335int
336recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free)
337{
338  TCR *owner = m->owner;
339
340  LOCK_SPINLOCK(m->spinlock,tcr);
341  if (owner == tcr) {
342    m->count++;
343    if (was_free) {
344      *was_free = 0;
345      RELEASE_SPINLOCK(m->spinlock);
346      return 0;
347    }
348  }
349  if (store_conditional((natural*)&(m->avail), 0, 1) == 0) {
350    m->owner = tcr;
351    m->count = 1;
352    if (was_free) {
353      *was_free = 1;
354    }
355    RELEASE_SPINLOCK(m->spinlock);
356    return 0;
357  }
358
359  RELEASE_SPINLOCK(m->spinlock);
360  return EBUSY;
361}
362#else
363int
364recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free)
365{
366  TCR *owner = m->owner;
367
368  if (owner == tcr) {
369    m->count++;
370    if (was_free) {
371      *was_free = 0;
372      return 0;
373    }
374  }
375  if (store_conditional((natural*)&(m->avail), 0, 1) == 0) {
376    m->owner = tcr;
377    m->count = 1;
378    if (was_free) {
379      *was_free = 1;
380    }
381    return 0;
382  }
383
384  return EBUSY;
385}
386#endif
387
388void
389sem_wait_forever(SEMAPHORE s)
390{
391  int status;
392
393  do {
394#ifdef USE_MACH_SEMAPHORES
395    mach_timespec_t q = {1,0};
396    status = SEM_TIMEDWAIT(s,q);
397#endif
398#ifdef USE_POSIX_SEMAPHORES
399    struct timespec q;
400    gettimeofday((struct timeval *)&q, NULL);
401    q.tv_sec += 1;
402    status = SEM_TIMEDWAIT(s,&q);
403#endif
404#ifdef USE_WINDOWS_SEMAPHORES
405    status = (WaitForSingleObject(s,1000L) == WAIT_TIMEOUT) ? 1 : 0;
406#endif
407  } while (status != 0);
408}
409
410int
411wait_on_semaphore(void *s, int seconds, int millis)
412{
413#ifdef USE_POSIX_SEMAPHORES
414  int nanos = (millis % 1000) * 1000000;
415  int status;
416
417  struct timespec q;
418  gettimeofday((struct timeval *)&q, NULL);
419  q.tv_nsec *= 1000L;  /* microseconds -> nanoseconds */
420   
421  q.tv_nsec += nanos;
422  if (q.tv_nsec >= 1000000000L) {
423    q.tv_nsec -= 1000000000L;
424    seconds += 1;
425  }
426  q.tv_sec += seconds;
427  status = SEM_TIMEDWAIT(s, &q);
428  if (status < 0) {
429    return errno;
430  }
431  return status;
432#endif
433#ifdef USE_MACH_SEMAPHORES
434  int nanos = (millis % 1000) * 1000000;
435  mach_timespec_t q = {seconds, nanos};
436  int status = SEM_TIMEDWAIT(s, q);
437
438 
439  switch (status) {
440  case 0: return 0;
441  case KERN_OPERATION_TIMED_OUT: return ETIMEDOUT;
442  case KERN_ABORTED: return EINTR;
443  default: return EINVAL;
444  }
445#endif
446#ifdef USE_WINDOWS_SEMAPHORES
447  switch (WaitForSingleObject(s, seconds*1000L+(DWORD)millis)) {
448  case WAIT_OBJECT_0:
449    return 0;
450  case WAIT_TIMEOUT:
451    return WAIT_TIMEOUT;
452  default:
453    break;
454  }
455  return EINVAL;
456
457#endif
458}
459
460
461int
462semaphore_maybe_timedwait(void *s, struct timespec *t)
463{
464  if (t) {
465    return wait_on_semaphore(s, t->tv_sec, t->tv_nsec/1000000L);
466  }
467  SEM_WAIT_FOREVER(s);
468  return 0;
469}
470
471void
472signal_semaphore(SEMAPHORE s)
473{
474  SEM_RAISE(s);
475}
476
477 
478#ifdef WINDOWS
479LispObj
480current_thread_osid()
481{
482  TCR *tcr = get_tcr(false);
483  LispObj current = 0;
484
485  if (tcr) {
486    current = tcr->osid;
487  }
488  if (current == 0) {
489    DuplicateHandle(GetCurrentProcess(),
490                    GetCurrentThread(),
491                    GetCurrentProcess(),
492                    &current,
493                    0,
494                    FALSE,
495                    DUPLICATE_SAME_ACCESS);
496    if (tcr) {
497      tcr->osid = current;
498    }
499  }
500  return current;
501}
502#else
503LispObj
504current_thread_osid()
505{
506  return (LispObj)ptr_to_lispobj(pthread_self());
507}
508#endif
509
510
511int thread_suspend_signal = 0, thread_resume_signal = 0;
512
513
514
515void
516linux_exception_init(TCR *tcr)
517{
518}
519
520
521TCR *
522get_interrupt_tcr(Boolean create)
523{
524  return get_tcr(create);
525}
526 
527  void
528suspend_resume_handler(int signo, siginfo_t *info, ExceptionInformation *context)
529{
530#ifdef DARWIN_GS_HACK
531  Boolean gs_was_tcr = ensure_gs_pthread();
532#endif
533  TCR *tcr = get_interrupt_tcr(false);
534
535  if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<<fixnumshift)) {
536    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
537  } else {
538    if (signo == thread_suspend_signal) {
539#if 0
540      sigset_t wait_for;
541#endif
542
543      tcr->suspend_context = context;
544#if 0
545      sigfillset(&wait_for);
546#endif
547      SEM_RAISE(tcr->suspend);
548#if 0
549      sigdelset(&wait_for, thread_resume_signal);
550#endif
551#if 1
552#if RESUME_VIA_RESUME_SEMAPHORE
553      SEM_WAIT_FOREVER(tcr->resume);
554#if SUSPEND_RESUME_VERBOSE
555      fprintf(stderr, "got  resume in 0x%x\n",tcr);
556#endif
557      tcr->suspend_context = NULL;
558#else
559      sigsuspend(&wait_for);
560#endif
561#else
562    do {
563      sigsuspend(&wait_for);
564    } while (tcr->suspend_context);
565#endif 
566    } else {
567      tcr->suspend_context = NULL;
568#if SUSEPEND_RESUME_VERBOSE
569      fprintf(stderr,"got  resume in in 0x%x\n",tcr);
570#endif
571    }
572#if WAIT_FOR_RESUME_ACK
573    SEM_RAISE(tcr->suspend);
574#endif
575  }
576#ifdef DARWIN_GS_HACK
577  if (gs_was_tcr) {
578    set_gs_address(tcr);
579  }
580#endif
581#ifdef DARWIN
582  DarwinSigReturn(context);
583#endif
584#ifdef FREEBSD
585  freebsd_sigreturn(context);
586#endif
587}
588
589 
590
591/*
592  'base' should be set to the bottom (origin) of the stack, e.g., the
593  end from which it grows.
594*/
595 
596#ifdef WINDOWS
597void
598os_get_current_thread_stack_bounds(void **base, natural *size)
599{
600  natural natbase;
601  MEMORY_BASIC_INFORMATION info;
602  void *addr = (void *)current_stack_pointer();
603 
604  VirtualQuery(addr, &info, sizeof(info));
605  natbase = (natural)info.BaseAddress+info.RegionSize;
606  *size = natbase - (natural)(info.AllocationBase);
607  *base = (void *)natbase;
608}
609#else
610void
611os_get_current_thread_stack_bounds(void **base, natural *size)
612{
613  pthread_t p = pthread_self();
614#ifdef DARWIN
615  *base = pthread_get_stackaddr_np(p);
616  *size = pthread_get_stacksize_np(p);
617#endif
618#ifdef LINUX
619  pthread_attr_t attr;
620
621  pthread_getattr_np(p,&attr);
622  pthread_attr_getstack(&attr, base, size);
623  *(natural *)base += *size;
624#endif
625#ifdef FREEBSD
626  pthread_attr_t attr;
627  void * temp_base;
628  size_t temp_size;
629 
630
631  pthread_attr_init(&attr); 
632  pthread_attr_get_np(p, &attr);
633  pthread_attr_getstackaddr(&attr,&temp_base);
634  pthread_attr_getstacksize(&attr,&temp_size);
635  *base = (void *)((natural)temp_base + temp_size);
636  *size = temp_size;
637#endif
638
639}
640#endif
641
642void *
643new_semaphore(int count)
644{
645#ifdef USE_POSIX_SEMAPHORES
646  sem_t *s = malloc(sizeof(sem_t));
647  sem_init(s, 0, count);
648  return s;
649#endif
650#ifdef USE_MACH_SEMAPHORES
651  semaphore_t s = (semaphore_t)0;
652  semaphore_create(mach_task_self(),&s, SYNC_POLICY_FIFO, count);
653  return (void *)(natural)s;
654#endif
655#ifdef USE_WINDOWS_SEMAPHORES
656  return CreateSemaphore(NULL, count, 0x7fffL, NULL);
657#endif
658}
659
660RECURSIVE_LOCK
661new_recursive_lock()
662{
663  extern int cache_block_size;
664  void *p = calloc(1,sizeof(_recursive_lock)+cache_block_size-1);
665  RECURSIVE_LOCK m = NULL;
666#ifndef USE_FUTEX
667  void *signal = new_semaphore(0);
668#endif
669
670  if (p) {
671    m = (RECURSIVE_LOCK) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
672    m->malloced_ptr = p;
673  }
674
675#ifdef USE_FUTEX
676  if (m) {
677    return m;
678  }
679#else
680  if (m && signal) {
681    m->signal = signal;
682    return m;
683  }
684  if (m) {
685    free(p);
686  }
687  if (signal) {
688    destroy_semaphore(&signal);
689  }
690#endif
691  return NULL;
692}
693
694void
695destroy_semaphore(void **s)
696{
697  if (*s) {
698#ifdef USE_POSIX_SEMAPHORES
699    sem_destroy((sem_t *)*s);
700#endif
701#ifdef USE_MACH_SEMAPHORES
702    semaphore_destroy(mach_task_self(),((semaphore_t)(natural) *s));
703#endif
704#ifdef USE_WINDOWS_SEMAPHORES
705    CloseHandle(*s);
706#endif
707    *s=NULL;
708  }
709}
710
711#ifdef WINDOWS
712void
713tsd_set(LispObj key, void *datum)
714{
715  TlsSetValue((DWORD)key, datum);
716}
717
718void *
719tsd_get(LispObj key)
720{
721  return TlsGetValue((DWORD)key);
722}
723#else
724void
725tsd_set(LispObj key, void *datum)
726{
727  pthread_setspecific((pthread_key_t)key, datum);
728}
729
730void *
731tsd_get(LispObj key)
732{
733  return pthread_getspecific((pthread_key_t)key);
734}
735#endif
736
737void
738dequeue_tcr(TCR *tcr)
739{
740  TCR *next, *prev;
741
742  next = tcr->next;
743  prev = tcr->prev;
744
745  prev->next = next;
746  next->prev = prev;
747  tcr->prev = tcr->next = NULL;
748#ifdef X8664
749  tcr->linear = NULL;
750#endif
751}
752 
753void
754enqueue_tcr(TCR *new)
755{
756  TCR *head, *tail;
757 
758  LOCK(lisp_global(TCR_AREA_LOCK),new);
759  head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR));
760  tail = head->prev;
761  tail->next = new;
762  head->prev = new;
763  new->prev = tail;
764  new->next = head;
765  UNLOCK(lisp_global(TCR_AREA_LOCK),new);
766}
767
768TCR *
769allocate_tcr()
770{
771  TCR *tcr, *chain = NULL, *next;
772#ifdef DARWIN
773  extern Boolean use_mach_exception_handling;
774  kern_return_t kret;
775  mach_port_t
776    thread_exception_port,
777    task_self = mach_task_self();
778#endif
779  for (;;) {
780    tcr = calloc(1, sizeof(TCR));
781#ifdef DARWIN
782#if WORD_SIZE == 64
783    if (((unsigned)((natural)tcr)) != ((natural)tcr)) {
784      tcr->next = chain;
785      chain = tcr;
786      continue;
787    }
788#endif
789    if (use_mach_exception_handling) {
790      thread_exception_port = (mach_port_t)((natural)tcr);
791      kret = mach_port_allocate_name(task_self,
792                                     MACH_PORT_RIGHT_RECEIVE,
793                                     thread_exception_port);
794    } else {
795      kret = KERN_SUCCESS;
796    }
797
798    if (kret != KERN_SUCCESS) {
799      tcr->next = chain;
800      chain = tcr;
801      continue;
802    }
803#endif
804    for (next = chain; next;) {
805      next = next->next;
806      free(chain);
807    }
808    return tcr;
809  }
810}
811
812#ifdef X8664
813#ifdef LINUX
814#include <asm/prctl.h>
815#include <sys/prctl.h>
816#endif
817#ifdef FREEBSD
818#include <machine/sysarch.h>
819#endif
820
821void
822setup_tcr_extra_segment(TCR *tcr)
823{
824#ifdef FREEBSD
825  amd64_set_gsbase(tcr);
826#endif
827#ifdef LINUX
828  arch_prctl(ARCH_SET_GS, (natural)tcr);
829#endif
830#ifdef DARWIN
831  /* There's no way to do this yet.  See DARWIN_GS_HACK */
832  /* darwin_set_x8664_fs_reg(tcr); */
833#endif
834}
835
836#endif
837
838
839
840/*
841  Caller must hold the area_lock.
842*/
843TCR *
844new_tcr(natural vstack_size, natural tstack_size)
845{
846  extern area
847    *allocate_vstack_holding_area_lock(unsigned),
848    *allocate_tstack_holding_area_lock(unsigned);
849  area *a;
850  int i;
851#ifndef WINDOWS
852  sigset_t sigmask;
853
854  sigemptyset(&sigmask);
855  pthread_sigmask(SIG_SETMASK,&sigmask, NULL);
856#endif
857
858#ifdef HAVE_TLS
859  TCR *tcr = &current_tcr;
860#else
861  TCR *tcr = allocate_tcr();
862#endif
863
864#ifdef X8664
865  setup_tcr_extra_segment(tcr);
866  tcr->linear = tcr;
867#endif
868
869#if (WORD_SIZE == 64)
870  tcr->single_float_convert.tag = subtag_single_float;
871#endif
872  lisp_global(TCR_COUNT) += (1<<fixnumshift);
873  tcr->suspend = new_semaphore(0);
874  tcr->resume = new_semaphore(0);
875  tcr->reset_completion = new_semaphore(0);
876  tcr->activate = new_semaphore(0);
877  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
878  a = allocate_vstack_holding_area_lock(vstack_size);
879  tcr->vs_area = a;
880  a->owner = tcr;
881  tcr->save_vsp = (LispObj *) a->active; 
882  a = allocate_tstack_holding_area_lock(tstack_size);
883  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
884  tcr->ts_area = a;
885  a->owner = tcr;
886  tcr->save_tsp = (LispObj *) a->active;
887#ifdef X86
888  tcr->next_tsp = tcr->save_tsp;
889#endif
890
891  tcr->valence = TCR_STATE_FOREIGN;
892#ifdef PPC
893  tcr->lisp_fpscr.words.l = 0xd0;
894#endif
895#ifdef X86
896  tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | 
897#if 1                           /* Mask underflow; too hard to
898                                   deal with denorms if underflow is
899                                   enabled */
900    (1 << MXCSR_UM_BIT) | 
901#endif
902    (1 << MXCSR_PM_BIT);
903#endif
904  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
905  tcr->tlb_limit = 2048<<fixnumshift;
906  tcr->tlb_pointer = (LispObj *)malloc(tcr->tlb_limit);
907  for (i = 0; i < 2048; i++) {
908    tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker;
909  }
910  TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<<fixnum_shift);
911#ifndef WINDOWS
912  tcr->shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS;
913#endif
914  return tcr;
915}
916
917void
918shutdown_thread_tcr(void *arg)
919{
920  TCR *tcr = TCR_FROM_TSD(arg);
921
922  area *vs, *ts, *cs;
923  void *termination_semaphore;
924 
925  if (--(tcr->shutdown_count) == 0) {
926    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
927      LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
928        callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
929   
930      tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
931      ((void (*)())ptr_from_lispobj(callback_ptr))(1);
932      tsd_set(lisp_global(TCR_KEY), NULL);
933    }
934#ifdef DARWIN
935    darwin_exception_cleanup(tcr);
936#endif
937    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
938    vs = tcr->vs_area;
939    tcr->vs_area = NULL;
940    ts = tcr->ts_area;
941    tcr->ts_area = NULL;
942    cs = tcr->cs_area;
943    tcr->cs_area = NULL;
944    if (vs) {
945      condemn_area_holding_area_lock(vs);
946    }
947    if (ts) {
948      condemn_area_holding_area_lock(ts);
949    }
950    if (cs) {
951      condemn_area_holding_area_lock(cs);
952    }
953    destroy_semaphore(&tcr->suspend);
954    destroy_semaphore(&tcr->resume);
955    destroy_semaphore(&tcr->reset_completion);
956    destroy_semaphore(&tcr->activate);
957    free(tcr->tlb_pointer);
958    tcr->tlb_pointer = NULL;
959    tcr->tlb_limit = 0;
960    tcr->osid = 0;
961    tcr->interrupt_pending = 0;
962    termination_semaphore = tcr->termination_semaphore;
963    tcr->termination_semaphore = NULL;
964#ifdef HAVE_TLS
965    dequeue_tcr(tcr);
966#endif
967    UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
968    if (termination_semaphore) {
969      SEM_RAISE(termination_semaphore);
970    }
971  } else {
972    tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
973  }
974}
975
976void
977tcr_cleanup(void *arg)
978{
979  TCR *tcr = (TCR *)arg;
980  area *a;
981
982  a = tcr->vs_area;
983  if (a) {
984    a->active = a->high;
985  }
986  a = tcr->ts_area;
987  if (a) {
988    a->active = a->high;
989  }
990  a = tcr->cs_area;
991  if (a) {
992    a->active = a->high;
993  }
994  tcr->valence = TCR_STATE_FOREIGN;
995  tcr->shutdown_count = 1;
996  shutdown_thread_tcr(tcr);
997  tsd_set(lisp_global(TCR_KEY), NULL);
998}
999
1000void *
1001current_native_thread_id()
1002{
1003  return ((void *) (natural)
1004#ifdef LINUX
1005          getpid()
1006#endif
1007#ifdef DARWIN
1008          mach_thread_self()
1009#endif
1010#ifdef FREEBSD
1011          pthread_self()
1012#endif
1013#ifdef SOLARIS
1014          pthread_self()
1015#endif
1016#ifdef WINDOWS
1017          GetCurrentThreadId()
1018#endif
1019          );
1020}
1021
1022
1023void
1024thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size)
1025{
1026  area *a, *register_cstack_holding_area_lock(BytePtr, natural);
1027
1028  tcr->osid = current_thread_osid();
1029  tcr->native_thread_id = current_native_thread_id();
1030  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1031  a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size);
1032  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1033  tcr->cs_area = a;
1034  a->owner = tcr;
1035  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
1036    tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1037  }
1038#ifdef LINUX
1039#ifdef PPC
1040#ifndef PPC64
1041  tcr->native_thread_info = current_r2;
1042#endif
1043#endif
1044#endif
1045  tcr->errno_loc = &errno;
1046  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1047#ifdef DARWIN
1048  extern Boolean use_mach_exception_handling;
1049  if (use_mach_exception_handling) {
1050    darwin_exception_init(tcr);
1051  }
1052#endif
1053#ifdef LINUX
1054  linux_exception_init(tcr);
1055#endif
1056  tcr->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1057}
1058
1059/*
1060  Register the specified tcr as "belonging to" the current thread.
1061  Under Darwin, setup Mach exception handling for the thread.
1062  Install cleanup handlers for thread termination.
1063*/
1064void
1065register_thread_tcr(TCR *tcr)
1066{
1067  void *stack_base = NULL;
1068  natural stack_size = 0;
1069
1070  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1071  thread_init_tcr(tcr, stack_base, stack_size);
1072  enqueue_tcr(tcr);
1073}
1074
1075
1076 
1077 
1078#ifndef MAP_GROWSDOWN
1079#define MAP_GROWSDOWN 0
1080#endif
1081
1082Ptr
1083create_stack(int size)
1084{
1085  Ptr p;
1086  size=align_to_power_of_2(size, log2_page_size);
1087  p = (Ptr) MapMemoryForStack((size_t)size);
1088  if (p != (Ptr)(-1)) {
1089    *((size_t *)p) = size;
1090    return p;
1091  }
1092  allocation_failure(true, size);
1093
1094}
1095
1096void *
1097allocate_stack(unsigned size)
1098{
1099  return create_stack(size);
1100}
1101
1102void
1103free_stack(void *s)
1104{
1105  size_t size = *((size_t *)s);
1106  UnMapMemory(s, size);
1107}
1108
1109Boolean threads_initialized = false;
1110
1111#ifndef USE_FUTEX
1112#ifdef WINDOWS
1113void
1114count_cpus()
1115{
1116  SYSTEM_INFO si;
1117
1118  GetSystemInfo(&si);
1119  if (si.dwNumberOfProcessors > 1) {
1120    spin_lock_tries = 1024;
1121  }
1122}
1123#else
1124void
1125count_cpus()
1126{
1127#ifdef DARWIN
1128  /* As of OSX 10.4, Darwin doesn't define _SC_NPROCESSORS_ONLN */
1129#include <mach/host_info.h>
1130
1131  struct host_basic_info info;
1132  mach_msg_type_number_t count = HOST_BASIC_INFO_COUNT;
1133 
1134  if (KERN_SUCCESS == host_info(mach_host_self(), HOST_BASIC_INFO,(host_info_t)(&info),&count)) {
1135    if (info.max_cpus > 1) {
1136      spin_lock_tries = 1024;
1137    }
1138  }
1139#else
1140  int n = sysconf(_SC_NPROCESSORS_ONLN);
1141 
1142  if (n > 1) {
1143    spin_lock_tries = 1024;
1144  }
1145#endif
1146}
1147#endif
1148#endif
1149
1150void
1151init_threads(void * stack_base, TCR *tcr)
1152{
1153  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1154#ifdef WINDOWS
1155  lisp_global(TCR_KEY) = TlsAlloc();
1156#else
1157  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1158  thread_signal_setup();
1159#endif
1160 
1161#ifndef USE_FUTEX
1162  count_cpus();
1163#endif
1164  threads_initialized = true;
1165}
1166
1167
1168void *
1169lisp_thread_entry(void *param)
1170{
1171  thread_activation *activation = (thread_activation *)param;
1172  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1173#ifndef WINDOWS
1174  sigset_t mask, old_mask;
1175
1176  sigemptyset(&mask);
1177  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1178#endif
1179
1180  register_thread_tcr(tcr);
1181
1182#ifndef WINDOWS
1183  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1184#endif
1185  tcr->vs_area->active -= node_size;
1186  *(--tcr->save_vsp) = lisp_nil;
1187  enable_fp_exceptions();
1188  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1189  activation->tcr = tcr;
1190  SEM_RAISE(activation->created);
1191  do {
1192    SEM_RAISE(tcr->reset_completion);
1193    SEM_WAIT_FOREVER(tcr->activate);
1194    /* Now go run some lisp code */
1195    start_lisp(TCR_TO_TSD(tcr),0);
1196  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1197#ifndef WINDOWS
1198  pthread_cleanup_pop(true);
1199#else
1200  tcr_cleanup(tcr);
1201#endif
1202  return NULL;
1203}
1204
1205void *
1206xNewThread(natural control_stack_size,
1207           natural value_stack_size,
1208           natural temp_stack_size)
1209
1210{
1211  thread_activation activation;
1212  TCR *current = get_tcr(false);
1213
1214
1215  activation.tsize = temp_stack_size;
1216  activation.vsize = value_stack_size;
1217  activation.tcr = 0;
1218  activation.created = new_semaphore(0);
1219  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1220                           NULL, 
1221                           lisp_thread_entry,
1222                           (void *) &activation)) {
1223   
1224    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1225  }
1226  destroy_semaphore(&activation.created); 
1227  return TCR_TO_TSD(activation.tcr);
1228}
1229
1230Boolean
1231active_tcr_p(TCR *q)
1232{
1233  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1234 
1235  do {
1236    if (p == q) {
1237      return true;
1238    }
1239    p = p->next;
1240  } while (p != head);
1241  return false;
1242}
1243
1244#ifdef WINDOWS
1245OSErr
1246xDisposeThread(TCR *tcr)
1247{
1248  return 0;                     /* I don't think that this is ever called. */
1249}
1250#else
1251OSErr
1252xDisposeThread(TCR *tcr)
1253{
1254  if (tcr != (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR))) {
1255    if (active_tcr_p(tcr) && (tcr != get_tcr(false))) {
1256      pthread_cancel((pthread_t)(tcr->osid));
1257      return 0;
1258    }
1259  }
1260  return -50;
1261}
1262#endif
1263
1264OSErr
1265xYieldToThread(TCR *target)
1266{
1267  Bug(NULL, "xYieldToThread ?");
1268  return 0;
1269}
1270 
1271OSErr
1272xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1273{
1274  Bug(NULL, "xThreadCurrentStackSpace ?");
1275  return 0;
1276}
1277
1278
1279#ifdef WINDOWS
1280LispObj
1281create_system_thread(size_t stack_size,
1282                     void* stackaddr,
1283                     void* (*start_routine)(void *),
1284                     void* param)
1285{
1286  HANDLE thread_handle;
1287
1288  thread_handle = (HANDLE)_beginthreadex(NULL, 
1289                                         stack_size,
1290                                         start_routine,
1291                                         param,
1292                                         0, 
1293                                         NULL);
1294
1295  if (thread_handle == NULL) {
1296    wperror("CreateThread");
1297  }
1298  return (LispObj) ptr_to_lispobj(thread_handle);
1299}
1300#else
1301LispObj
1302create_system_thread(size_t stack_size,
1303                     void* stackaddr,
1304                     void* (*start_routine)(void *),
1305                     void* param)
1306{
1307  pthread_attr_t attr;
1308  pthread_t returned_thread = (pthread_t) 0;
1309
1310  pthread_attr_init(&attr);
1311  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1312
1313  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1314    stack_size = PTHREAD_STACK_MIN;
1315  }
1316
1317  stack_size = ensure_stack_limit(stack_size);
1318  if (stackaddr != NULL) {
1319    /* Size must have been specified.  Sort of makes sense ... */
1320#ifdef DARWIN
1321    Fatal("no pthread_attr_setsetstack. "," Which end of stack does address refer to?");
1322#else
1323    pthread_attr_setstack(&attr, stackaddr, stack_size);
1324#endif
1325  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1326    pthread_attr_setstacksize(&attr,stack_size);
1327  }
1328
1329  /*
1330     I think that's just about enough ... create the thread.
1331  */
1332  pthread_create(&returned_thread, &attr, start_routine, param);
1333  return (LispObj) ptr_to_lispobj(returned_thread);
1334}
1335#endif
1336
1337TCR *
1338get_tcr(Boolean create)
1339{
1340#ifdef HAVE_TLS
1341  TCR *current = current_tcr.linear;
1342#else
1343  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1344  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1345#endif
1346
1347  if ((current == NULL) && create) {
1348    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1349      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1350    int i, nbindwords = 0;
1351    extern unsigned initial_stack_size;
1352   
1353    /* Make one. */
1354    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1355    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1356    register_thread_tcr(current);
1357#ifdef DEBUG_TCR_CREATION
1358#ifndef WINDOWS
1359    fprintf(stderr, "\ncreating TCR for pthread 0x%x", pthread_self());
1360#endif
1361#endif
1362    current->vs_area->active -= node_size;
1363    *(--current->save_vsp) = lisp_nil;
1364#ifdef PPC
1365#define NSAVEREGS 8
1366#endif
1367#ifdef X8664
1368#define NSAVEREGS 4
1369#endif
1370    for (i = 0; i < NSAVEREGS; i++) {
1371      *(--current->save_vsp) = 0;
1372      current->vs_area->active -= node_size;
1373    }
1374    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1375    for (i = 0; i < nbindwords; i++) {
1376      *(--current->save_vsp) = 0;
1377      current->vs_area->active -= node_size;
1378    }
1379    current->shutdown_count = 1;
1380    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1381
1382  }
1383 
1384  return current;
1385}
1386
1387#ifdef WINDOWS
1388
1389Boolean
1390suspend_tcr(TCR *tcr)
1391{
1392  int suspend_count = atomic_incf(&(tcr->suspend_count));
1393  DWORD rc;
1394  if (suspend_count == 1) {
1395    /* Can't seem to get gcc to align a CONTEXT structure correctly */
1396    char _contextbuf[sizeof(CONTEXT)+__alignof(CONTEXT)];
1397
1398    CONTEXT *suspend_context, *pcontext;
1399    HANDLE hthread = (HANDLE)(tcr->osid);
1400    pc where;
1401    area *cs = tcr->cs_area;
1402    LispObj foreign_rsp;
1403
1404    pcontext = (CONTEXT *)((((natural)&_contextbuf)+15)&~15);
1405
1406#if SUSPEND_RESUME_VERBOSE
1407    fprintf(stderr,"Suspending 0x%x\n", tcr);
1408#endif
1409    rc = SuspendThread(hthread);
1410    if (rc == -1) {
1411      /* If the thread's simply dead, we should handle that here */
1412      wperror("SuspendThread");
1413      return false;
1414    }
1415    pcontext->ContextFlags = CONTEXT_ALL;
1416    rc = GetThreadContext(hthread, pcontext);
1417    if (rc == 0) {
1418      wperror("GetThreadContext");
1419    }
1420    where = (pc)(xpPC(pcontext));
1421
1422    if (tcr->valence == TCR_STATE_LISP) {
1423      if ((where >= restore_win64_context_start) &&
1424          (where < restore_win64_context_end)) {
1425        /* Thread has started to return from an exception. */
1426        if (where < restore_win64_context_load_rcx) {
1427          /* In the process of restoring registers; context still in
1428             %rcx.  Just make our suspend_context be the context
1429             we're trying to restore, so that we'll resume from
1430             the suspend in the same context that we're trying to
1431             restore */
1432          *pcontext = * (CONTEXT *)(pcontext->Rcx);
1433        } else {
1434          /* Most of the context has already been restored; fix %rcx
1435             if need be, then restore ss:rsp, cs:rip, and flags. */
1436          x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1437          if (where == restore_win64_context_load_rcx) {
1438            pcontext->Rcx = ((CONTEXT*)(pcontext->Rcx))->Rcx;
1439          }
1440          pcontext->Rip = iret_frame->Rip;
1441          pcontext->SegCs = (WORD) iret_frame->Cs;
1442          pcontext->EFlags = (DWORD) iret_frame->Rflags;
1443          pcontext->Rsp = iret_frame->Rsp;
1444          pcontext->SegSs = (WORD) iret_frame->Ss;
1445        }
1446        tcr->suspend_context = NULL;
1447      } else {
1448        area *ts = tcr->ts_area;
1449        /* If we're in the lisp heap, or in x86-spentry64.o, or in
1450           x86-subprims64.o, or in the subprims jump table at #x15000,
1451           or on the tstack ... we're just executing lisp code.  Otherwise,
1452           we got an exception while executing lisp code, but haven't
1453           yet entered the handler yet (still in Windows exception glue
1454           or switching stacks or something.)  In the latter case, we
1455           basically want to get to he handler and have it notice
1456           the pending exception request, and suspend the thread at that
1457           point. */
1458        if (!((where < (pc)lisp_global(HEAP_END)) &&
1459              (where >= (pc)lisp_global(HEAP_START))) &&
1460            !((where < spentry_end) && (where >= spentry_start)) &&
1461            !((where < subprims_end) && (where >= subprims_start)) &&
1462            !((where < (pc) 0x16000) &&
1463              (where >= (pc) 0x15000)) &&
1464            !((where < (pc) (ts->high)) &&
1465              (where >= (pc) (ts->low)))) {
1466          /* The thread has lisp valence, but is not executing code
1467             where we expect lisp code to be and is not exiting from
1468             an exception handler.  That pretty much means that it's
1469             on its way into an exception handler; we have to handshake
1470             until it enters an exception-wait state. */
1471          /* There are likely race conditions here */
1472          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
1473          ResumeThread(hthread);
1474          SEM_WAIT_FOREVER(tcr->suspend);
1475          SuspendThread(hthread);
1476          /* The thread is either waiting for its resume semaphore to
1477             be signaled or is about to wait.  Signal it now, while
1478             the thread's suspended. */
1479          SEM_RAISE(tcr->resume);
1480          pcontext->ContextFlags = CONTEXT_ALL;
1481          GetThreadContext(hthread, pcontext);
1482        }
1483      }
1484    } else {
1485      if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) {
1486        *pcontext = *tcr->pending_exception_context;
1487        tcr->pending_exception_context = NULL;
1488        tcr->valence = TCR_STATE_LISP;
1489      }
1490    }
1491
1492    /* If the context's stack pointer is pointing into the cs_area,
1493       copy the context below the stack pointer. else copy it
1494       below tcr->foreign_rsp. */
1495    foreign_rsp = xpGPR(pcontext,Isp);
1496
1497    if ((foreign_rsp < (LispObj)(cs->low)) ||
1498        (foreign_rsp >= (LispObj)(cs->high))) {
1499      foreign_rsp = (LispObj)(tcr->foreign_sp);
1500    }
1501    foreign_rsp -= 0x200;
1502    foreign_rsp &= ~15;
1503    suspend_context = (CONTEXT *)(foreign_rsp)-1;
1504    *suspend_context = *pcontext;
1505    tcr->suspend_context = suspend_context;
1506    return true;
1507  }
1508  return false;
1509}
1510#else
1511Boolean
1512suspend_tcr(TCR *tcr)
1513{
1514  int suspend_count = atomic_incf(&(tcr->suspend_count));
1515  if (suspend_count == 1) {
1516#if SUSPEND_RESUME_VERBOSE
1517    fprintf(stderr,"Suspending 0x%x\n", tcr);
1518#endif
1519#ifdef DARWIN_nope
1520    if (mach_suspend_tcr(tcr)) {
1521      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_ALT_SUSPEND);
1522      return true;
1523    }
1524#endif
1525    if (pthread_kill((pthread_t)(tcr->osid), thread_suspend_signal) == 0) {
1526      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
1527    } else {
1528      /* A problem using pthread_kill.  On Darwin, this can happen
1529         if the thread has had its signal mask surgically removed
1530         by pthread_exit.  If the native (Mach) thread can be suspended,
1531         do that and return true; otherwise, flag the tcr as belonging
1532         to a dead thread by setting tcr->osid to 0.
1533      */
1534      tcr->osid = 0;
1535      return false;
1536    }
1537    return true;
1538  }
1539  return false;
1540}
1541#endif
1542
1543#ifdef WINDOWS
1544Boolean
1545tcr_suspend_ack(TCR *tcr)
1546{
1547  return true;
1548}
1549#else
1550Boolean
1551tcr_suspend_ack(TCR *tcr)
1552{
1553  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
1554    SEM_WAIT_FOREVER(tcr->suspend);
1555    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
1556#if SUSPEND_RESUME_VERBOSE
1557    fprintf(stderr,"Suspend ack from 0x%x\n", tcr);
1558#endif
1559
1560  }
1561  return true;
1562}
1563#endif
1564     
1565
1566
1567Boolean
1568lisp_suspend_tcr(TCR *tcr)
1569{
1570  Boolean suspended;
1571  TCR *current = get_tcr(true);
1572 
1573  LOCK(lisp_global(TCR_AREA_LOCK),current);
1574#ifdef DARWIN
1575#if USE_MACH_EXCEPTION_LOCK
1576  if (use_mach_exception_handling) {
1577    pthread_mutex_lock(mach_exception_lock);
1578  }
1579#endif
1580#endif
1581  suspended = suspend_tcr(tcr);
1582  if (suspended) {
1583    while (!tcr_suspend_ack(tcr));
1584  }
1585#ifdef DARWIN
1586#if USE_MACH_EXCEPTION_LOCK
1587  if (use_mach_exception_handling) {
1588    pthread_mutex_unlock(mach_exception_lock);
1589  }
1590#endif
1591#endif
1592  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1593  return suspended;
1594}
1595         
1596#ifdef WINDOWS
1597Boolean
1598resume_tcr(TCR *tcr)
1599{
1600  int suspend_count = atomic_decf(&(tcr->suspend_count)), err;
1601  DWORD rc;
1602  if (suspend_count == 0) {
1603    CONTEXT *context = tcr->suspend_context;
1604    HANDLE hthread = (HANDLE)(tcr->osid);
1605
1606    if (context == NULL) {
1607      Bug(NULL, "no suspend_context for TCR = 0x%Ix", (natural)tcr);
1608    }
1609    tcr->suspend_context = NULL;
1610    SetThreadContext(hthread,context);
1611    rc = ResumeThread(hthread);
1612    if (rc == -1) {
1613      wperror("ResumeThread");
1614      return false;
1615    }
1616    return true;
1617  }
1618  return false;
1619}   
1620#else
1621Boolean
1622resume_tcr(TCR *tcr)
1623{
1624  int suspend_count = atomic_decf(&(tcr->suspend_count)), err;
1625  if (suspend_count == 0) {
1626#ifdef DARWIN
1627    if (tcr->flags & (1<<TCR_FLAG_BIT_ALT_SUSPEND)) {
1628#if SUSPEND_RESUME_VERBOSE
1629    fprintf(stderr,"Mach resume to 0x%x\n", tcr);
1630#endif
1631      mach_resume_tcr(tcr);
1632      return true;
1633    }
1634#endif
1635#if RESUME_VIA_RESUME_SEMAPHORE
1636    SEM_RAISE(tcr->resume);
1637#else
1638    if ((err = (pthread_kill((pthread_t)(tcr->osid), thread_resume_signal))) != 0) {
1639      Bug(NULL, "pthread_kill returned %d on thread #x%x", err, tcr->osid);
1640    }
1641#endif
1642#if SUSPEND_RESUME_VERBOSE
1643    fprintf(stderr, "Sent resume to 0x%x\n", tcr);
1644#endif
1645    return true;
1646  }
1647  return false;
1648}
1649#endif
1650
1651void
1652wait_for_resumption(TCR *tcr)
1653{
1654  if (tcr->suspend_count == 0) {
1655#ifdef DARWIN
1656    if (tcr->flags & (1<<TCR_FLAG_BIT_ALT_SUSPEND)) {
1657      tcr->flags &= ~(1<<TCR_FLAG_BIT_ALT_SUSPEND);
1658      return;
1659  }
1660#endif
1661#if WAIT_FOR_RESUME_ACK
1662#if SUSPEND_RESUME_VERBOSE
1663    fprintf(stderr, "waiting for resume in 0x%x\n",tcr);
1664#endif
1665    SEM_WAIT_FOREVER(tcr->suspend);
1666#endif
1667  }
1668}
1669   
1670
1671
1672Boolean
1673lisp_resume_tcr(TCR *tcr)
1674{
1675  Boolean resumed;
1676  TCR *current = get_tcr(true);
1677 
1678  LOCK(lisp_global(TCR_AREA_LOCK),current);
1679  resumed = resume_tcr(tcr);
1680#ifndef WINDOWS
1681  wait_for_resumption(tcr);
1682#endif
1683  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
1684  return resumed;
1685}
1686
1687
1688TCR *freed_tcrs = NULL;
1689
1690void
1691enqueue_freed_tcr (TCR *tcr)
1692{
1693#ifndef HAVE_TLS
1694  tcr->next = freed_tcrs;
1695  freed_tcrs = tcr;
1696#endif
1697}
1698
1699/* It's not clear that we can safely condemn a dead tcr's areas, since
1700   we may not be able to call free() if a suspended thread owns a
1701   malloc lock. At least make the areas appear to be empty.
1702*/
1703   
1704
1705void
1706normalize_dead_tcr_areas(TCR *tcr)
1707{
1708  area *a;
1709
1710  a = tcr->vs_area;
1711  if (a) {
1712    a->active = a->high;
1713  }
1714
1715  a = tcr->ts_area;
1716  if (a) {
1717    a->active = a->high;
1718  }
1719
1720  a = tcr->cs_area;
1721  if (a) {
1722    a->active = a->high;
1723  }
1724}
1725   
1726void
1727free_freed_tcrs ()
1728{
1729  TCR *current, *next;
1730
1731  for (current = freed_tcrs; current; current = next) {
1732    next = current->next;
1733#ifndef HAVE_TLS
1734    free(current);
1735#endif
1736  }
1737  freed_tcrs = NULL;
1738}
1739
1740void
1741suspend_other_threads(Boolean for_gc)
1742{
1743  TCR *current = get_tcr(true), *other, *next;
1744  int dead_tcr_count = 0;
1745  Boolean all_acked;
1746
1747  LOCK(lisp_global(TCR_AREA_LOCK), current);
1748#ifdef DARWIN
1749#if USE_MACH_EXCEPTION_LOCK
1750  if (for_gc && use_mach_exception_handling) {
1751#if SUSPEND_RESUME_VERBOSE
1752    fprintf(stderr, "obtaining Mach exception lock in GC thread 0x%x\n", current);
1753#endif
1754    pthread_mutex_lock(mach_exception_lock);
1755  }
1756#endif
1757#endif
1758  for (other = current->next; other != current; other = other->next) {
1759    if ((other->osid != 0)) {
1760      suspend_tcr(other);
1761      if (other->osid == 0) {
1762        dead_tcr_count++;
1763      }
1764    } else {
1765      dead_tcr_count++;
1766    }
1767  }
1768
1769  do {
1770    all_acked = true;
1771    for (other = current->next; other != current; other = other->next) {
1772      if ((other->osid != 0)) {
1773        if (!tcr_suspend_ack(other)) {
1774          all_acked = false;
1775        }
1776      }
1777    }
1778  } while(! all_acked);
1779
1780     
1781
1782  /* All other threads are suspended; can safely delete dead tcrs now */
1783  if (dead_tcr_count) {
1784    for (other = current->next; other != current; other = next) {
1785      next = other->next;
1786      if ((other->osid == 0))  {
1787        normalize_dead_tcr_areas(other);
1788        dequeue_tcr(other);
1789        enqueue_freed_tcr(other);
1790      }
1791    }
1792  }
1793}
1794
1795void
1796lisp_suspend_other_threads()
1797{
1798  suspend_other_threads(false);
1799}
1800
1801void
1802resume_other_threads(Boolean for_gc)
1803{
1804  TCR *current = get_tcr(true), *other;
1805  for (other = current->next; other != current; other = other->next) {
1806    if ((other->osid != 0)) {
1807      resume_tcr(other);
1808    }
1809  }
1810  for (other = current->next; other != current; other = other->next) {
1811    if ((other->osid != 0)) {
1812      wait_for_resumption(other);
1813    }
1814  }
1815  free_freed_tcrs();
1816#ifdef DARWIN
1817#if USE_MACH_EXCEPTION_LOCK
1818  if (for_gc && use_mach_exception_handling) {
1819#if SUSPEND_RESUME_VERBOSE
1820    fprintf(stderr, "releasing Mach exception lock in GC thread 0x%x\n", current);
1821#endif
1822    pthread_mutex_unlock(mach_exception_lock);
1823  }
1824#endif
1825#endif
1826
1827  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
1828}
1829
1830void
1831lisp_resume_other_threads()
1832{
1833  resume_other_threads(false);
1834}
1835
1836
1837
1838rwlock *
1839rwlock_new()
1840{
1841  extern int cache_block_size;
1842
1843  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
1844  rwlock *rw;
1845 
1846  if (p) {
1847    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
1848    rw->malloced_ptr = p;
1849#ifndef USE_FUTEX
1850    rw->reader_signal = new_semaphore(0);
1851    rw->writer_signal = new_semaphore(0);
1852    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
1853      if (rw->reader_signal) {
1854        destroy_semaphore(&(rw->reader_signal));
1855      } else {
1856        destroy_semaphore(&(rw->writer_signal));
1857      }
1858      free(rw);
1859      rw = NULL;
1860    }
1861#endif
1862  }
1863  return rw;
1864}
1865
1866     
1867/*
1868  Try to get read access to a multiple-readers/single-writer lock.  If
1869  we already have read access, return success (indicating that the
1870  lock is held another time.  If we already have write access to the
1871  lock ... that won't work; return EDEADLK.  Wait until no other
1872  thread has or is waiting for write access, then indicate that we
1873  hold read access once.
1874*/
1875#ifndef USE_FUTEX
1876int
1877rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
1878{
1879  int err = 0;
1880 
1881  LOCK_SPINLOCK(rw->spin, tcr);
1882
1883  if (rw->writer == tcr) {
1884    RELEASE_SPINLOCK(rw->spin);
1885    return EDEADLK;
1886  }
1887
1888  while (rw->blocked_writers || (rw->state > 0)) {
1889    rw->blocked_readers++;
1890    RELEASE_SPINLOCK(rw->spin);
1891    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
1892    LOCK_SPINLOCK(rw->spin,tcr);
1893    rw->blocked_readers--;
1894    if (err == EINTR) {
1895      err = 0;
1896    }
1897    if (err) {
1898      RELEASE_SPINLOCK(rw->spin);
1899      return err;
1900    }
1901  }
1902  rw->state--;
1903  RELEASE_SPINLOCK(rw->spin);
1904  return err;
1905}
1906#else
1907int
1908rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
1909{
1910  natural waitval;
1911
1912  lock_futex(&rw->spin);
1913
1914  if (rw->writer == tcr) {
1915    unlock_futex(&rw->spin);
1916    return EDEADLOCK;
1917  }
1918  while (1) {
1919    if (rw->writer == NULL) {
1920      --rw->state;
1921      unlock_futex(&rw->spin);
1922      return 0;
1923    }
1924    rw->blocked_readers++;
1925    waitval = rw->reader_signal;
1926    unlock_futex(&rw->spin);
1927    futex_wait(&rw->reader_signal,waitval);
1928    lock_futex(&rw->spin);
1929    rw->blocked_readers--;
1930  }
1931  return 0;
1932}
1933#endif   
1934
1935
1936/*
1937  Try to obtain write access to the lock.
1938  It is an error if we already have read access, but it's hard to
1939  detect that.
1940  If we already have write access, increment the count that indicates
1941  that.
1942  Otherwise, wait until the lock is not held for reading or writing,
1943  then assert write access.
1944*/
1945
1946#ifndef USE_FUTEX
1947int
1948rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
1949{
1950  int err = 0;
1951
1952  LOCK_SPINLOCK(rw->spin,tcr);
1953  if (rw->writer == tcr) {
1954    rw->state++;
1955    RELEASE_SPINLOCK(rw->spin);
1956    return 0;
1957  }
1958
1959  while (rw->state != 0) {
1960    rw->blocked_writers++;
1961    RELEASE_SPINLOCK(rw->spin);
1962    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
1963    LOCK_SPINLOCK(rw->spin,tcr);
1964    rw->blocked_writers--;
1965    if (err == EINTR) {
1966      err = 0;
1967    }
1968    if (err) {
1969      RELEASE_SPINLOCK(rw->spin);
1970      return err;
1971    }
1972  }
1973  rw->state = 1;
1974  rw->writer = tcr;
1975  RELEASE_SPINLOCK(rw->spin);
1976  return err;
1977}
1978
1979#else
1980int
1981rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
1982{
1983  int err = 0;
1984  natural waitval;
1985
1986  lock_futex(&rw->spin);
1987  if (rw->writer == tcr) {
1988    rw->state++;
1989    unlock_futex(&rw->spin);
1990    return 0;
1991  }
1992
1993  while (rw->state != 0) {
1994    rw->blocked_writers++;
1995    waitval = rw->writer_signal;
1996    unlock_futex(&rw->spin);
1997    futex_wait(&rw->writer_signal,waitval);
1998    lock_futex(&rw->spin);
1999    rw->blocked_writers--;
2000  }
2001  rw->state = 1;
2002  rw->writer = tcr;
2003  unlock_futex(&rw->spin);
2004  return err;
2005}
2006#endif
2007
2008/*
2009  Sort of the same as above, only return EBUSY if we'd have to wait.
2010*/
2011#ifndef USE_FUTEX
2012int
2013rwlock_try_wlock(rwlock *rw, TCR *tcr)
2014{
2015  int ret = EBUSY;
2016
2017  LOCK_SPINLOCK(rw->spin,tcr);
2018  if (rw->writer == tcr) {
2019    rw->state++;
2020    ret = 0;
2021  } else {
2022    if (rw->state == 0) {
2023      rw->writer = tcr;
2024      rw->state = 1;
2025      ret = 0;
2026    }
2027  }
2028  RELEASE_SPINLOCK(rw->spin);
2029  return ret;
2030}
2031#else
2032int
2033rwlock_try_wlock(rwlock *rw, TCR *tcr)
2034{
2035  int ret = EBUSY;
2036
2037  lock_futex(&rw->spin);
2038  if (rw->writer == tcr) {
2039    rw->state++;
2040    ret = 0;
2041  } else {
2042    if (rw->state == 0) {
2043      rw->writer = tcr;
2044      rw->state = 1;
2045      ret = 0;
2046    }
2047  }
2048  unlock_futex(&rw->spin);
2049  return ret;
2050}
2051#endif
2052
2053#ifndef USE_FUTEX
2054int
2055rwlock_try_rlock(rwlock *rw, TCR *tcr)
2056{
2057  int ret = EBUSY;
2058
2059  LOCK_SPINLOCK(rw->spin,tcr);
2060  if (rw->state <= 0) {
2061    --rw->state;
2062    ret = 0;
2063  }
2064  RELEASE_SPINLOCK(rw->spin);
2065  return ret;
2066}
2067#else
2068int
2069rwlock_try_rlock(rwlock *rw, TCR *tcr)
2070{
2071  int ret = EBUSY;
2072
2073  lock_futex(&rw->spin);
2074  if (rw->state <= 0) {
2075    --rw->state;
2076    ret = 0;
2077  }
2078  unlock_futex(&rw->spin);
2079  return ret;
2080}
2081#endif
2082
2083
2084
2085#ifndef USE_FUTEX
2086int
2087rwlock_unlock(rwlock *rw, TCR *tcr)
2088{
2089
2090  int err = 0;
2091  natural blocked_readers = 0;
2092
2093  LOCK_SPINLOCK(rw->spin,tcr);
2094  if (rw->state > 0) {
2095    if (rw->writer != tcr) {
2096      err = EINVAL;
2097    } else {
2098      --rw->state;
2099      if (rw->state == 0) {
2100        rw->writer = NULL;
2101      }
2102    }
2103  } else {
2104    if (rw->state < 0) {
2105      ++rw->state;
2106    } else {
2107      err = EINVAL;
2108    }
2109  }
2110  if (err) {
2111    RELEASE_SPINLOCK(rw->spin);
2112    return err;
2113  }
2114 
2115  if (rw->state == 0) {
2116    if (rw->blocked_writers) {
2117      SEM_RAISE(rw->writer_signal);
2118    } else {
2119      blocked_readers = rw->blocked_readers;
2120      if (blocked_readers) {
2121        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2122      }
2123    }
2124  }
2125  RELEASE_SPINLOCK(rw->spin);
2126  return 0;
2127}
2128#else
2129int
2130rwlock_unlock(rwlock *rw, TCR *tcr)
2131{
2132
2133  int err = 0;
2134
2135  lock_futex(&rw->spin);
2136  if (rw->state > 0) {
2137    if (rw->writer != tcr) {
2138      err = EINVAL;
2139    } else {
2140      --rw->state;
2141      if (rw->state == 0) {
2142        rw->writer = NULL;
2143      }
2144    }
2145  } else {
2146    if (rw->state < 0) {
2147      ++rw->state;
2148    } else {
2149      err = EINVAL;
2150    }
2151  }
2152  if (err) {
2153    unlock_futex(&rw->spin);
2154    return err;
2155  }
2156 
2157  if (rw->state == 0) {
2158    if (rw->blocked_writers) {
2159      ++rw->writer_signal;
2160      unlock_futex(&rw->spin);
2161      futex_wake(&rw->writer_signal,1);
2162      return 0;
2163    }
2164    if (rw->blocked_readers) {
2165      ++rw->reader_signal;
2166      unlock_futex(&rw->spin);
2167      futex_wake(&rw->reader_signal, INT_MAX);
2168      return 0;
2169    }
2170  }
2171  unlock_futex(&rw->spin);
2172  return 0;
2173}
2174#endif
2175
2176       
2177void
2178rwlock_destroy(rwlock *rw)
2179{
2180#ifndef USE_FUTEX
2181  destroy_semaphore((void **)&rw->reader_signal);
2182  destroy_semaphore((void **)&rw->writer_signal);
2183#endif
2184  postGCfree((void *)(rw->malloced_ptr));
2185}
2186
2187
2188
Note: See TracBrowser for help on using the repository browser.