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

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

windows raise_thread_interrupt: if the interrupted thread is obviously
blocked on input, cancel the pending I/O as best we can. (There are
lots of other things that we might be blocked on, and Windows sucks
too much to offer a general way of cancelling blocking syscalls.)

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