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

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

os_get_current_thread_stack_bounds() for Windows: call current_stack_pointer,
don't take the address of the function.

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