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

Last change on this file since 10565 was 10565, checked in by gb, 12 years ago

Merge changes from branches/win64.

As well as the expected low-level exception/suspend/interrupt stuff,
these changes also include changes to [f]printf format strings. Note
that on win64, a 'long' is 32-bits wide, which complicates matters:

  • an address (viewed as an integer) or a natural-sized integer isn't

(portably) a long, and so can't be printed with %l.

  • an address (viewed as an integer) or a natural-sized integer isn't

(portably) a long long, and so can't be printed with %ll.

  • an address (viewed as an integer) or a natural-sized integer can be

portably printed with '%p', but implementations differ as to whether
or not '%p' prepends a gratuitous '0x' to the hex address. (Linux
does, other current platforms seem not to.)

The approach that seems to work is to cast arguments to natural, then
to u64_t, then use %ll. That approach probably isn't taken consistently
(yet), so some debugging information printed by the kernel may be
incorrect.

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