source: branches/shrink-tcr/lisp-kernel/thread_manager.c @ 14607

Last change on this file since 14607 was 14607, checked in by rme, 9 years ago

More tweaks; a cross-compiled Windows x86 lisp now bootstraps on Windows x64.

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