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

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

Try to use new format-string constants.

CALLBACK on thread startup functions.

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