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

Last change on this file since 14233 was 14233, checked in by gb, 9 years ago

Don't use the (Linux-specific ?) MAP_GROWSDOWN mmap option when allocating
stacks; it doesn't do what we thought it did and using it seems to trigger
a bug in some 2.6.32 Linux kernels. See ticket:731, which this change might
fix.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 59.0 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)(target->osid);
77  pc where;
78  area *cs = target->cs_area, *ts = target->cs_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)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->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->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->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->suspend_context = context;
600    SEM_RAISE(tcr->suspend);
601    SEM_WAIT_FOREVER(tcr->resume);
602    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->next;
779  prev = tcr->prev;
780
781  prev->next = next;
782  next->prev = prev;
783  tcr->prev = 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 = head->prev;
797  tail->next = new;
798  head->prev = new;
799  new->prev = tail;
800  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(TCR)+15);
809  TCR *tcr = (TCR *)((((natural)p)+15)&~15);
810
811  tcr->allocated = p;
812  return tcr;
813}
814#else
815TCR *
816allocate_tcr()
817{
818  TCR *tcr, *chain = NULL, *next;
819#ifdef DARWIN
820  extern Boolean use_mach_exception_handling;
821  kern_return_t kret;
822  mach_port_t
823    thread_exception_port,
824    task_self = mach_task_self();
825#endif
826  for (;;) {
827    tcr = calloc(1, sizeof(TCR));
828#ifdef DARWIN
829#if WORD_SIZE == 64
830    if (((unsigned)((natural)tcr)) != ((natural)tcr)) {
831      tcr->next = chain;
832      chain = tcr;
833      continue;
834    }
835#endif
836    if (use_mach_exception_handling) {
837      thread_exception_port = (mach_port_t)((natural)tcr);
838      kret = mach_port_allocate_name(task_self,
839                                     MACH_PORT_RIGHT_RECEIVE,
840                                     thread_exception_port);
841    } else {
842      kret = KERN_SUCCESS;
843    }
844
845    if (kret != KERN_SUCCESS) {
846      tcr->next = chain;
847      chain = tcr;
848      continue;
849    }
850#endif
851    for (;chain;chain = next) {
852      next = chain->next;
853      free(chain);
854    }
855    return tcr;
856  }
857}
858#endif
859
860#ifdef X8664
861#ifdef LINUX
862#include <asm/prctl.h>
863#include <sys/prctl.h>
864#endif
865#ifdef FREEBSD
866#include <machine/sysarch.h>
867#endif
868
869void
870setup_tcr_extra_segment(TCR *tcr)
871{
872#ifdef FREEBSD
873  amd64_set_gsbase(tcr);
874#endif
875#ifdef LINUX
876  arch_prctl(ARCH_SET_GS, (natural)tcr);
877#endif
878#ifdef DARWIN
879  /* There's no way to do this yet.  See DARWIN_GS_HACK */
880  /* darwin_set_x8664_fs_reg(tcr); */
881#endif
882#ifdef SOLARIS
883  /* Chris Curtis found this and suggested the use of syscall here */
884  syscall(SYS_lwp_private,_LWP_SETPRIVATE, _LWP_GSBASE, tcr);
885#endif
886}
887
888#endif
889
890#ifdef X8632
891
892#ifdef DARWIN
893#include <architecture/i386/table.h>
894#include <architecture/i386/sel.h>
895#include <i386/user_ldt.h>
896
897void setup_tcr_extra_segment(TCR *tcr)
898{
899    uintptr_t addr = (uintptr_t)tcr;
900    unsigned int size = sizeof(*tcr);
901    ldt_entry_t desc;
902    sel_t sel;
903    int i;
904
905    desc.data.limit00 = (size - 1) & 0xffff;
906    desc.data.limit16 = ((size - 1) >> 16) & 0xf;
907    desc.data.base00 = addr & 0xffff;
908    desc.data.base16 = (addr >> 16) & 0xff;
909    desc.data.base24 = (addr >> 24) & 0xff;
910    desc.data.type = DESC_DATA_WRITE;
911    desc.data.dpl = USER_PRIV;
912    desc.data.present = 1;
913    desc.data.stksz = DESC_CODE_32B;
914    desc.data.granular = DESC_GRAN_BYTE;
915   
916    i = i386_set_ldt(LDT_AUTO_ALLOC, &desc, 1);
917
918    if (i < 0) {
919        perror("i386_set_ldt");
920    } else {
921        sel.index = i;
922        sel.rpl = USER_PRIV;
923        sel.ti = SEL_LDT;
924        tcr->ldt_selector = sel;
925    }
926}
927
928void free_tcr_extra_segment(TCR *tcr)
929{
930  /* load %fs with null segement selector */
931  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
932  if (i386_set_ldt(tcr->ldt_selector.index, NULL, 1) < 0)
933    perror("i386_set_ldt");
934  tcr->ldt_selector = NULL_SEL;
935}
936#endif
937
938#ifdef LINUX
939
940#include <asm/ldt.h>
941#include <sys/syscall.h>
942
943/* see desc_struct in kernel/include/asm-i386/processor.h */
944typedef struct {
945  uint32_t a;
946  uint32_t b;
947} linux_desc_struct;
948
949
950#define desc_avail(d) (((d)->a) == 0)
951
952linux_desc_struct linux_ldt_entries[LDT_ENTRIES];
953
954/* We have to ask the Linux kernel for a copy of the ldt table
955   and manage it ourselves.  It's not clear that this is
956   thread-safe in general, but we can at least ensure that
957   it's thread-safe wrt lisp threads. */
958
959pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
960
961int
962modify_ldt(int func, void *ptr, unsigned long bytecount)
963{
964  return syscall(__NR_modify_ldt, func, ptr, bytecount);
965}
966
967
968void
969setup_tcr_extra_segment(TCR *tcr)
970{
971  int i, n;
972  short sel;
973  struct user_desc u = {1, 0, 0, 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1};
974  linux_desc_struct *d = linux_ldt_entries;
975
976  pthread_mutex_lock(&ldt_lock);
977  n = modify_ldt(0,d,LDT_ENTRIES*LDT_ENTRY_SIZE)/LDT_ENTRY_SIZE;
978  for (i = 0; i < n; i++,d++) {
979    if (desc_avail(d)) {
980      break;
981    }
982  }
983  if (i == LDT_ENTRIES) {
984    pthread_mutex_unlock(&ldt_lock);
985    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
986    _exit(1);
987  }
988  u.entry_number = i;
989  u.base_addr = (uint32_t)tcr;
990  u.limit = sizeof(TCR);
991  u.limit_in_pages = 0;
992  if (modify_ldt(1,&u,sizeof(struct user_desc)) != 0) {
993    pthread_mutex_unlock(&ldt_lock);
994    fprintf(dbgout,"Can't assign LDT entry\n");
995    _exit(1);
996  }
997  sel = (i << 3) | 7;
998  tcr->ldt_selector = sel;
999  pthread_mutex_unlock(&ldt_lock);
1000}
1001
1002void
1003free_tcr_extra_segment(TCR *tcr)
1004{
1005  struct user_desc u = {0, 0, 0, 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0};
1006  short sel = tcr->ldt_selector;
1007
1008  pthread_mutex_lock(&ldt_lock);
1009  /* load %fs with null segment selector */
1010  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1011  tcr->ldt_selector = 0;
1012  u.entry_number = (sel>>3);
1013  modify_ldt(1,&u,sizeof(struct user_desc));
1014  pthread_mutex_unlock(&ldt_lock);
1015 
1016}
1017
1018#endif
1019
1020#ifdef WINDOWS
1021bitvector ldt_entries_in_use = NULL;
1022HANDLE ldt_lock;
1023
1024typedef struct {
1025  DWORD offset;
1026  DWORD size;
1027  LDT_ENTRY entry;
1028} win32_ldt_info;
1029
1030
1031int WINAPI (*NtQueryInformationProcess)(HANDLE,DWORD,VOID*,DWORD,DWORD*);
1032int WINAPI (*NtSetInformationProcess)(HANDLE,DWORD,VOID*,DWORD);
1033
1034void
1035init_win32_ldt()
1036{
1037  HANDLE hNtdll;
1038  int status = 0xc0000002;
1039  win32_ldt_info info;
1040  DWORD nret;
1041 
1042
1043  ldt_entries_in_use=malloc(8192/8);
1044  zero_bits(ldt_entries_in_use,8192);
1045  ldt_lock = CreateMutex(NULL,0,NULL);
1046
1047  hNtdll = LoadLibrary("ntdll.dll");
1048  NtQueryInformationProcess = (void*)GetProcAddress(hNtdll, "NtQueryInformationProcess");
1049  NtSetInformationProcess = (void*)GetProcAddress(hNtdll, "NtSetInformationProcess");
1050  if (NtQueryInformationProcess != NULL) {
1051    info.offset = 0;
1052    info.size = sizeof(LDT_ENTRY);
1053    status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1054  }
1055
1056  if (status) {
1057    fprintf(dbgout, "This application can't run under this OS version\n");
1058    _exit(1);
1059  }
1060}
1061
1062void
1063setup_tcr_extra_segment(TCR *tcr)
1064{
1065  int i, status;
1066  DWORD nret;
1067  win32_ldt_info info;
1068  LDT_ENTRY *entry = &(info.entry);
1069  DWORD *words = (DWORD *)entry, tcraddr = (DWORD)tcr;
1070
1071
1072  WaitForSingleObject(ldt_lock,INFINITE);
1073
1074  for (i = 0; i < 8192; i++) {
1075    if (!ref_bit(ldt_entries_in_use,i)) {
1076      info.offset = i << 3;
1077      info.size = sizeof(LDT_ENTRY);
1078      words[0] = 0;
1079      words[1] = 0;
1080      status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1081      if (status == 0) {
1082        if ((info.size == 0) ||
1083            ((words[0] == 0) && (words[1] == 0))) {
1084          break;
1085        }
1086      }
1087    }
1088  }
1089  if (i == 8192) {
1090    ReleaseMutex(ldt_lock);
1091    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
1092    _exit(1);
1093  }
1094  set_bit(ldt_entries_in_use,i);
1095  words[0] = 0;
1096  words[1] = 0;
1097  entry->LimitLow = sizeof(TCR);
1098  entry->BaseLow = tcraddr & 0xffff;
1099  entry->HighWord.Bits.BaseMid = (tcraddr >> 16) & 0xff;
1100  entry->HighWord.Bits.BaseHi = (tcraddr >> 24);
1101  entry->HighWord.Bits.Pres = 1;
1102  entry->HighWord.Bits.Default_Big = 1;
1103  entry->HighWord.Bits.Type = 16 | 2; /* read-write data */
1104  entry->HighWord.Bits.Dpl = 3; /* for use by the great unwashed */
1105  info.size = sizeof(LDT_ENTRY);
1106  status = NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info));
1107  if (status != 0) {
1108    ReleaseMutex(ldt_lock);
1109    FBug(NULL, "can't set LDT entry %d, status = 0x%x", i, status);
1110  }
1111#if 1
1112  /* Sanity check */
1113  info.offset = i << 3;
1114  info.size = sizeof(LDT_ENTRY);
1115  words[0] = 0;
1116  words[0] = 0;
1117  NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret);
1118  if (((entry->BaseLow)|((entry->HighWord.Bits.BaseMid)<<16)|((entry->HighWord.Bits.BaseHi)<<24)) != tcraddr) {
1119    Bug(NULL, "you blew it: bad address in ldt entry\n");
1120  }
1121#endif
1122  tcr->ldt_selector = (i << 3) | 7;
1123  ReleaseMutex(ldt_lock);
1124}
1125
1126void 
1127free_tcr_extra_segment(TCR *tcr)
1128{
1129  win32_ldt_info info;
1130  LDT_ENTRY *entry = &(info.entry);
1131  DWORD *words = (DWORD *)entry;
1132  int idx = tcr->ldt_selector >> 3;
1133
1134
1135  info.offset = idx << 3;
1136  info.size = sizeof(LDT_ENTRY);
1137
1138  words[0] = 0;
1139  words[1] = 0;
1140
1141  WaitForSingleObject(ldt_lock,INFINITE);
1142  NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info));
1143  clr_bit(ldt_entries_in_use,idx);
1144  ReleaseMutex(ldt_lock);
1145
1146  tcr->ldt_selector = 0;
1147}
1148
1149#endif
1150#ifdef FREEBSD
1151#include <machine/segments.h>
1152#include <machine/sysarch.h>
1153
1154/* It'd be tempting to use i386_set_fsbase() here, but there doesn't
1155   seem to be any way to free the GDT entry it creates.  Actually,
1156   it's not clear that that really sets a GDT entry; let's see */
1157
1158#define FREEBSD_USE_SET_FSBASE 1
1159void
1160setup_tcr_extra_segment(TCR *tcr)
1161{
1162#if !FREEBSD_USE_SET_FSBASE
1163  struct segment_descriptor sd;
1164  uintptr_t addr = (uintptr_t)tcr;
1165  unsigned int size = sizeof(*tcr);
1166  int i;
1167
1168  sd.sd_lolimit = (size - 1) & 0xffff;
1169  sd.sd_hilimit = ((size - 1) >> 16) & 0xf;
1170  sd.sd_lobase = addr & ((1<<24)-1);
1171  sd.sd_hibase = (addr>>24)&0xff;
1172
1173
1174
1175  sd.sd_type = 18;
1176  sd.sd_dpl = SEL_UPL;
1177  sd.sd_p = 1;
1178  sd.sd_def32 = 1;
1179  sd.sd_gran = 0;
1180
1181  i = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor *)&sd, 1);
1182
1183  if (i < 0) {
1184    perror("i386_set_ldt");
1185    exit(1);
1186  } else {
1187    tcr->ldt_selector = LSEL(i,SEL_UPL);
1188  }
1189#else
1190  extern unsigned short get_fs_register(void);
1191
1192  if (i386_set_fsbase((void*)tcr)) {
1193    perror("i386_set_fsbase");
1194    exit(1);
1195  }
1196
1197
1198  /* Once we've called i386_set_fsbase, we can't write to %fs. */
1199  tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL);
1200#endif
1201}
1202
1203void 
1204free_tcr_extra_segment(TCR *tcr)
1205{
1206#if FREEBSD_USE_SET_FSBASE
1207  /* On a 32-bit kernel, this allocates a GDT entry.  It's not clear
1208     what it would mean to deallocate that entry. */
1209  /* If we're running on a 64-bit kernel, we can't write to %fs */
1210#else
1211  int idx = tcr->ldt_selector >> 3;
1212  /* load %fs with null segment selector */
1213  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1214  if (i386_set_ldt(idx, NULL, 1) < 0)
1215    perror("i386_set_ldt");
1216#endif
1217  tcr->ldt_selector = 0;
1218}
1219#endif
1220
1221#ifdef SOLARIS
1222#include <sys/sysi86.h>
1223
1224bitvector ldt_entries_in_use = NULL;
1225pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
1226
1227void
1228solaris_ldt_init()
1229{
1230  int fd;
1231  struct ssd s;
1232
1233  ldt_entries_in_use=malloc(8192/8);
1234  zero_bits(ldt_entries_in_use,8192);
1235 
1236  fd = open("/proc/self/ldt", O_RDONLY);
1237
1238  while(read(fd,&s,sizeof(s)) == sizeof(s)) {
1239    set_bit(ldt_entries_in_use,s.sel>>3);
1240  }
1241  close(fd);
1242}
1243   
1244
1245void
1246setup_tcr_extra_segment(TCR *tcr)
1247{
1248  struct ssd s;
1249  int i;
1250
1251  pthread_mutex_lock(&ldt_lock);
1252
1253  for (i = 0; i < 8192; i++) {
1254    if (!ref_bit(ldt_entries_in_use,i)) {
1255      s.sel = (i<<3)|7;
1256      s.bo = (unsigned int)tcr;
1257      s.ls = sizeof(TCR);
1258      s.acc1 = 0xf2;
1259      s.acc2 = 4;
1260
1261      if (sysi86(SI86DSCR, &s) >= 0) {
1262        set_bit(ldt_entries_in_use,i);
1263        tcr->ldt_selector = (i<<3)|7;
1264        pthread_mutex_unlock(&ldt_lock);
1265        return;
1266      }
1267      set_bit(ldt_entries_in_use,i);
1268    }
1269  }
1270  pthread_mutex_unlock(&ldt_lock);
1271  fprintf(dbgout, "All 8192 LDT descriptors in use\n");
1272  _exit(1);
1273
1274
1275 
1276}
1277
1278void 
1279free_tcr_extra_segment(TCR *tcr)
1280{
1281  struct ssd s;
1282  int i;
1283
1284  pthread_mutex_lock(&ldt_lock);
1285  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
1286  s.sel = tcr->ldt_selector;
1287  i = s.sel>>3;
1288  tcr->ldt_selector = 0;
1289  s.bo = 0;
1290  s.ls = 0;
1291  s.acc1 = 0;
1292  s.acc2 = 0;
1293  sysi86(SI86DSCR, &s);
1294  clr_bit(ldt_entries_in_use,i);
1295  pthread_mutex_unlock(&ldt_lock);
1296}
1297
1298#endif
1299#endif
1300
1301/*
1302  Caller must hold the area_lock.
1303*/
1304TCR *
1305new_tcr(natural vstack_size, natural tstack_size)
1306{
1307  extern area
1308    *allocate_vstack_holding_area_lock(natural),
1309    *allocate_tstack_holding_area_lock(natural);
1310  area *a;
1311  int i;
1312#ifndef WINDOWS
1313  sigset_t sigmask;
1314
1315  sigemptyset(&sigmask);
1316  pthread_sigmask(SIG_SETMASK,&sigmask, NULL);
1317#endif
1318
1319#ifdef HAVE_TLS
1320  TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15));
1321  current_tcr = tcr;
1322#else /* no TLS */
1323  TCR *tcr = allocate_tcr();
1324#endif
1325
1326#ifdef X86
1327  setup_tcr_extra_segment(tcr);
1328  tcr->linear = tcr;
1329#ifdef X8632
1330  tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK;
1331#endif
1332#endif
1333
1334#if (WORD_SIZE == 64)
1335  tcr->single_float_convert.tag = subtag_single_float;
1336#endif
1337  tcr->suspend = new_semaphore(0);
1338  tcr->resume = new_semaphore(0);
1339  tcr->reset_completion = new_semaphore(0);
1340  tcr->activate = new_semaphore(0);
1341  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1342  a = allocate_vstack_holding_area_lock(vstack_size);
1343  tcr->vs_area = a;
1344  a->owner = tcr;
1345  tcr->save_vsp = (LispObj *) a->active; 
1346#ifndef ARM
1347  a = allocate_tstack_holding_area_lock(tstack_size);
1348#endif
1349  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1350#ifndef ARM
1351  tcr->ts_area = a;
1352  a->owner = tcr;
1353  tcr->save_tsp = (LispObj *) a->active;
1354#endif
1355#ifdef X86
1356  tcr->next_tsp = tcr->save_tsp;
1357#endif
1358
1359  tcr->valence = TCR_STATE_FOREIGN;
1360#ifdef PPC
1361  tcr->lisp_fpscr.words.l = 0xd0;
1362#endif
1363#ifdef X86
1364  tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | 
1365#if 1                           /* Mask underflow; too hard to
1366                                   deal with denorms if underflow is
1367                                   enabled */
1368    (1 << MXCSR_UM_BIT) | 
1369#endif
1370    (1 << MXCSR_PM_BIT);
1371#endif
1372#ifdef ARM
1373  tcr->lisp_fpscr = 
1374    (1 << FPSCR_IOE_BIT) | 
1375    (1 << FPSCR_DZE_BIT) |
1376    (1 << FPSCR_OFE_BIT);
1377#endif
1378  tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR;
1379  tcr->tlb_limit = 2048<<fixnumshift;
1380  tcr->tlb_pointer = (LispObj *)malloc(tcr->tlb_limit);
1381  for (i = 0; i < 2048; i++) {
1382    tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker;
1383  }
1384  TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<<fixnum_shift);
1385#ifndef WINDOWS
1386  tcr->shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS;
1387#else
1388  tcr->shutdown_count = 1;
1389#endif
1390  return tcr;
1391}
1392
1393void
1394shutdown_thread_tcr(void *arg)
1395{
1396  TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0);
1397
1398  area *vs, *ts, *cs;
1399 
1400  if (current == NULL) {
1401    current = tcr;
1402  }
1403
1404  if (--(tcr->shutdown_count) == 0) {
1405    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
1406      LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1407        callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1408   
1409      tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1410      ((void (*)())ptr_from_lispobj(callback_ptr))(1);
1411      tsd_set(lisp_global(TCR_KEY), NULL);
1412    }
1413#ifdef DARWIN
1414    darwin_exception_cleanup(tcr);
1415#endif
1416    LOCK(lisp_global(TCR_AREA_LOCK),current);
1417    vs = tcr->vs_area;
1418    tcr->vs_area = NULL;
1419#ifndef ARM
1420    ts = tcr->ts_area;
1421    tcr->ts_area = NULL;
1422#endif
1423    cs = tcr->cs_area;
1424    tcr->cs_area = NULL;
1425    if (vs) {
1426      condemn_area_holding_area_lock(vs);
1427    }
1428#ifndef ARM
1429    if (ts) {
1430      condemn_area_holding_area_lock(ts);
1431    }
1432#endif
1433    if (cs) {
1434      condemn_area_holding_area_lock(cs);
1435    }
1436    /* On some platforms - currently just linuxarm - we have to
1437       allocate a separate alternate signal stack (rather than just
1438       using a few pages of the thread's main stack.)  Disable and
1439       free that alternate stack here.
1440    */
1441#ifdef ARM
1442#if defined(LINUX)
1443    {
1444      stack_t new, current;
1445      new.ss_flags = SS_DISABLE;
1446      if (sigaltstack(&new, &current) == 0) {
1447        munmap(current.ss_sp, current.ss_size);
1448      }
1449    }
1450#endif
1451#endif
1452    destroy_semaphore(&tcr->suspend);
1453    destroy_semaphore(&tcr->resume);
1454    destroy_semaphore(&tcr->reset_completion);
1455    destroy_semaphore(&tcr->activate);
1456    tcr->tlb_limit = 0;
1457    free(tcr->tlb_pointer);
1458    tcr->tlb_pointer = NULL;
1459#ifdef WINDOWS
1460    if (tcr->osid != 0) {
1461      CloseHandle((HANDLE)(tcr->osid));
1462    }
1463#endif
1464    tcr->osid = 0;
1465    tcr->interrupt_pending = 0;
1466    tcr->termination_semaphore = NULL;
1467#ifdef HAVE_TLS
1468    dequeue_tcr(tcr);
1469#endif
1470#ifdef X8632
1471    free_tcr_extra_segment(tcr);
1472#endif
1473#ifdef WIN32
1474    CloseHandle((HANDLE)tcr->io_datum);
1475    tcr->io_datum = NULL;
1476    free(tcr->native_thread_info);
1477    tcr->native_thread_info = NULL;
1478#endif
1479    UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1480  } else {
1481    tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1482  }
1483}
1484
1485void
1486tcr_cleanup(void *arg)
1487{
1488  TCR *tcr = (TCR *)arg;
1489  area *a;
1490
1491  a = tcr->vs_area;
1492  if (a) {
1493    a->active = a->high;
1494  }
1495#ifndef ARM
1496  a = tcr->ts_area;
1497  if (a) {
1498    a->active = a->high;
1499  }
1500#endif
1501  a = tcr->cs_area;
1502  if (a) {
1503    a->active = a->high;
1504  }
1505  tcr->valence = TCR_STATE_FOREIGN;
1506  tcr->shutdown_count = 1;
1507  shutdown_thread_tcr(tcr);
1508  tsd_set(lisp_global(TCR_KEY), NULL);
1509}
1510
1511void *
1512current_native_thread_id()
1513{
1514  return ((void *) (natural)
1515#ifdef LINUX
1516#ifdef __NR_gettid
1517          syscall(__NR_gettid)
1518#else
1519          getpid()
1520#endif
1521#endif
1522#ifdef DARWIN
1523          mach_thread_self()
1524#endif
1525#ifdef FREEBSD
1526          pthread_self()
1527#endif
1528#ifdef SOLARIS
1529          pthread_self()
1530#endif
1531#ifdef WINDOWS
1532          GetCurrentThreadId()
1533#endif
1534          );
1535}
1536
1537
1538void
1539thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size)
1540{
1541  area *a, *register_cstack_holding_area_lock(BytePtr, natural);
1542
1543  tcr->osid = current_thread_osid();
1544  tcr->native_thread_id = current_native_thread_id();
1545  LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1546  a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size);
1547  UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
1548  tcr->cs_area = a;
1549  a->owner = tcr;
1550#ifdef ARM
1551  tcr->last_lisp_frame = (natural)(a->high);
1552#endif
1553  if (!(tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN))) {
1554    tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit);
1555  }
1556#ifdef LINUX
1557#ifdef PPC
1558#ifndef PPC64
1559  tcr->native_thread_info = current_r2;
1560#endif
1561#endif
1562#endif
1563  tcr->errno_loc = &errno;
1564  tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr));
1565#ifdef DARWIN
1566  extern Boolean use_mach_exception_handling;
1567  if (use_mach_exception_handling) {
1568    darwin_exception_init(tcr);
1569  }
1570#endif
1571#ifdef LINUX
1572  linux_exception_init(tcr);
1573#endif
1574#ifdef WINDOWS
1575  tcr->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
1576  tcr->native_thread_info = malloc(sizeof(CONTEXT));
1577#endif
1578  tcr->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
1579}
1580
1581/*
1582  Register the specified tcr as "belonging to" the current thread.
1583  Under Darwin, setup Mach exception handling for the thread.
1584  Install cleanup handlers for thread termination.
1585*/
1586void
1587register_thread_tcr(TCR *tcr)
1588{
1589  void *stack_base = NULL;
1590  natural stack_size = 0;
1591
1592  os_get_current_thread_stack_bounds(&stack_base, &stack_size);
1593  thread_init_tcr(tcr, stack_base, stack_size);
1594  enqueue_tcr(tcr);
1595}
1596
1597
1598 
1599 
1600
1601Ptr
1602create_stack(natural size)
1603{
1604  Ptr p;
1605  size=align_to_power_of_2(size, log2_page_size);
1606  p = (Ptr) MapMemoryForStack((size_t)size);
1607  if (p != (Ptr)(-1)) {
1608    *((size_t *)p) = size;
1609    return p;
1610  }
1611  allocation_failure(true, size);
1612
1613}
1614
1615void *
1616allocate_stack(natural size)
1617{
1618  return create_stack(size);
1619}
1620
1621void
1622free_stack(void *s)
1623{
1624  size_t size = *((size_t *)s);
1625  UnMapMemory(s, size);
1626}
1627
1628Boolean threads_initialized = false;
1629
1630#ifndef USE_FUTEX
1631#ifdef WINDOWS
1632void
1633count_cpus()
1634{
1635  SYSTEM_INFO si;
1636
1637  GetSystemInfo(&si);
1638  if (si.dwNumberOfProcessors > 1) {
1639    spin_lock_tries = 1024;
1640  }
1641}
1642#else
1643void
1644count_cpus()
1645{
1646  int n = sysconf(_SC_NPROCESSORS_ONLN);
1647 
1648  if (n > 1) {
1649    spin_lock_tries = 1024;
1650  }
1651}
1652#endif
1653#endif
1654
1655void
1656init_threads(void * stack_base, TCR *tcr)
1657{
1658  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1659#ifdef WINDOWS
1660  lisp_global(TCR_KEY) = TlsAlloc();
1661  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1662  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
1663#else
1664  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1665  thread_signal_setup();
1666#endif
1667
1668#ifndef USE_FUTEX
1669  count_cpus();
1670#endif
1671  threads_initialized = true;
1672}
1673
1674
1675#ifdef WINDOWS
1676unsigned CALLBACK
1677#else
1678void *
1679#endif
1680lisp_thread_entry(void *param)
1681{
1682  thread_activation *activation = (thread_activation *)param;
1683  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1684  LispObj *start_vsp;
1685#ifndef WINDOWS
1686  sigset_t mask, old_mask;
1687
1688  sigemptyset(&mask);
1689  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1690#endif
1691
1692  register_thread_tcr(tcr);
1693
1694#ifndef WINDOWS
1695  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1696#endif
1697  tcr->vs_area->active -= node_size;
1698  *(--tcr->save_vsp) = lisp_nil;
1699  start_vsp = tcr->save_vsp;
1700  enable_fp_exceptions();
1701  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1702  activation->tcr = tcr;
1703  SEM_RAISE(activation->created);
1704  do {
1705    SEM_RAISE(tcr->reset_completion);
1706    SEM_WAIT_FOREVER(tcr->activate);
1707    /* Now go run some lisp code */
1708    start_lisp(TCR_TO_TSD(tcr),0);
1709    tcr->save_vsp = start_vsp;
1710  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1711#ifndef WINDOWS
1712  pthread_cleanup_pop(true);
1713#else
1714  tcr_cleanup(tcr);
1715#endif
1716#ifdef WINDOWS
1717  return 0;
1718#else
1719  return NULL;
1720#endif
1721}
1722
1723typedef 
1724short (*suspendf)();
1725
1726
1727void
1728suspend_current_cooperative_thread()
1729{
1730  static suspendf cooperative_suspend = NULL;
1731  void *xFindSymbol(void*,char*);
1732
1733  if (cooperative_suspend == NULL) {
1734    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
1735  }
1736  if (cooperative_suspend) {
1737    cooperative_suspend(1 /* kCurrentThreadID */,
1738                        1 /* kStoppedThreadState */,
1739                        0 /* kAnyThreadID */);
1740  }
1741}
1742
1743void *
1744cooperative_thread_startup(void *arg)
1745{
1746
1747  TCR *tcr = get_tcr(0);
1748  LispObj *start_vsp;
1749
1750  if (!tcr) {
1751    return NULL;
1752  }
1753#ifndef WINDOWS
1754  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1755#endif
1756  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1757  start_vsp = tcr->save_vsp;
1758  do {
1759    SEM_RAISE(tcr->reset_completion);
1760    suspend_current_cooperative_thread();
1761     
1762    start_lisp(tcr, 0);
1763    tcr->save_vsp = start_vsp;
1764  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1765#ifndef WINDOWS
1766  pthread_cleanup_pop(true);
1767#else
1768  tcr_cleanup(tcr);
1769#endif
1770}
1771
1772void *
1773xNewThread(natural control_stack_size,
1774           natural value_stack_size,
1775           natural temp_stack_size)
1776
1777{
1778  thread_activation activation;
1779
1780
1781  activation.tsize = temp_stack_size;
1782  activation.vsize = value_stack_size;
1783  activation.tcr = 0;
1784  activation.created = new_semaphore(0);
1785  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1786                           NULL, 
1787                           lisp_thread_entry,
1788                           (void *) &activation)) {
1789   
1790    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1791  }
1792  destroy_semaphore(&activation.created); 
1793  return TCR_TO_TSD(activation.tcr);
1794}
1795
1796Boolean
1797active_tcr_p(TCR *q)
1798{
1799  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1800 
1801  do {
1802    if (p == q) {
1803      return true;
1804    }
1805    p = p->next;
1806  } while (p != head);
1807  return false;
1808}
1809
1810#ifdef WINDOWS
1811OSErr
1812xDisposeThread(TCR *tcr)
1813{
1814  return 0;                     /* I don't think that this is ever called. */
1815}
1816#else
1817OSErr
1818xDisposeThread(TCR *tcr)
1819{
1820  if (tcr != (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR))) {
1821    if (active_tcr_p(tcr) && (tcr != get_tcr(false))) {
1822      pthread_cancel((pthread_t)(tcr->osid));
1823      return 0;
1824    }
1825  }
1826  return -50;
1827}
1828#endif
1829
1830OSErr
1831xYieldToThread(TCR *target)
1832{
1833  Bug(NULL, "xYieldToThread ?");
1834  return 0;
1835}
1836 
1837OSErr
1838xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1839{
1840  Bug(NULL, "xThreadCurrentStackSpace ?");
1841  return 0;
1842}
1843
1844
1845#ifdef WINDOWS
1846Boolean
1847create_system_thread(size_t stack_size,
1848                     void* stackaddr,
1849                     unsigned CALLBACK (*start_routine)(void *),
1850                     void* param)
1851{
1852  HANDLE thread_handle;
1853  Boolean won = false;
1854
1855  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1856
1857  thread_handle = (HANDLE)_beginthreadex(NULL, 
1858                                         stack_size,
1859                                         start_routine,
1860                                         param,
1861                                         0, 
1862                                         NULL);
1863
1864  if (thread_handle == NULL) {
1865    wperror("CreateThread");
1866  } else {
1867    won = true;
1868    CloseHandle(thread_handle);
1869  }
1870  return won;
1871}
1872#else
1873Boolean
1874create_system_thread(size_t stack_size,  void *stackaddr,
1875                     void *(*start_routine)(void *), void *param)
1876{
1877  pthread_attr_t attr;
1878  pthread_t returned_thread;
1879  int err;
1880  TCR *current = get_tcr(true);
1881
1882  pthread_attr_init(&attr);
1883  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1884
1885  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1886    stack_size = PTHREAD_STACK_MIN;
1887  }
1888
1889  stack_size = ensure_stack_limit(stack_size);
1890  if (stackaddr != NULL) {
1891    /* Size must have been specified.  Sort of makes sense ... */
1892    pthread_attr_setstack(&attr, stackaddr, stack_size);
1893  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1894    pthread_attr_setstacksize(&attr,stack_size);
1895  }
1896
1897  /*
1898     I think that's just about enough ... create the thread.
1899     Well ... not quite enough.  In Leopard (at least), many
1900     pthread routines grab an internal spinlock when validating
1901     their arguments.  If we suspend a thread that owns this
1902     spinlock, we deadlock.  We can't in general keep that
1903     from happening: if arbitrary C code is suspended while
1904     it owns the spinlock, we still deadlock.  It seems that
1905     the best that we can do is to keep -this- code from
1906     getting suspended (by grabbing TCR_AREA_LOCK)
1907  */
1908  LOCK(lisp_global(TCR_AREA_LOCK),current);
1909  err = pthread_create(&returned_thread, &attr, start_routine, param);
1910  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1911  pthread_attr_destroy(&attr);
1912  return (err == 0);
1913}
1914#endif
1915
1916TCR *
1917get_tcr(Boolean create)
1918{
1919#ifdef HAVE_TLS
1920  TCR *current = current_tcr;
1921#else
1922  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1923  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1924#endif
1925
1926  if ((current == NULL) && create) {
1927    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1928      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1929    int i, nbindwords = 0;
1930    extern natural initial_stack_size;
1931   
1932    /* Make one. */
1933    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1934    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1935    register_thread_tcr(current);
1936#ifdef DEBUG_TCR_CREATION
1937#ifndef WINDOWS
1938    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
1939#endif
1940#endif
1941    current->vs_area->active -= node_size;
1942    *(--current->save_vsp) = lisp_nil;
1943#ifdef PPC
1944#define NSAVEREGS 8
1945#endif
1946#ifdef X8664
1947#define NSAVEREGS 4
1948#endif
1949#ifdef X8632
1950#define NSAVEREGS 0
1951#endif
1952#ifdef ARM
1953#define NSAVEREGS 0
1954#endif
1955    for (i = 0; i < NSAVEREGS; i++) {
1956      *(--current->save_vsp) = 0;
1957      current->vs_area->active -= node_size;
1958    }
1959    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1960    for (i = 0; i < nbindwords; i++) {
1961      *(--current->save_vsp) = 0;
1962      current->vs_area->active -= node_size;
1963    }
1964    current->shutdown_count = 1;
1965    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1966
1967  }
1968 
1969  return current;
1970}
1971
1972#ifdef WINDOWS
1973void *
1974pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
1975{
1976  /* Thread has started to return from an exception. */
1977  if (where < restore_windows_context_iret) {
1978    /* In the process of restoring registers; context still in
1979       %rcx.  Just make our suspend_context be the context
1980       we're trying to restore, so that we'll resume from
1981       the suspend in the same context that we're trying to
1982       restore */
1983#ifdef WIN_64
1984    *pcontext = * (CONTEXT *)(pcontext->Rcx);
1985#else
1986    if (where == restore_windows_context_start) {
1987      *pcontext = * (CONTEXT *)((pcontext->Esp)+4);
1988    } else {
1989      *pcontext = * (CONTEXT *)(pcontext->Ecx);
1990    }
1991#endif
1992  } else {
1993    /* Most of the context has already been restored; fix %rcx
1994       if need be, then restore ss:rsp, cs:rip, and flags. */
1995#ifdef WIN_64
1996    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
1997
1998    pcontext->Rip = iret_frame->Rip;
1999    pcontext->SegCs = (WORD) iret_frame->Cs;
2000    pcontext->EFlags = (DWORD) iret_frame->Rflags;
2001    pcontext->Rsp = iret_frame->Rsp;
2002    pcontext->SegSs = (WORD) iret_frame->Ss;
2003#else
2004    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
2005
2006    pcontext->Eip = iret_frame->Eip;
2007    pcontext->SegCs = (WORD) iret_frame->Cs;
2008    pcontext->EFlags = (DWORD) iret_frame->EFlags;
2009    pcontext->Esp += sizeof(ia32_iret_frame);
2010#endif
2011  }
2012  tcr->pending_exception_context = NULL;
2013  /* We basically never return from an exception unless we
2014     were executing lisp code when the exception returned.
2015     If that ever changes, we need to know what valence
2016     would have been restored here.*/
2017  tcr->valence = TCR_STATE_LISP;
2018}
2019
2020Boolean
2021suspend_tcr(TCR *tcr)
2022{
2023  int suspend_count = atomic_incf(&(tcr->suspend_count));
2024  DWORD rc;
2025  if (suspend_count == 1) {
2026    CONTEXT  *pcontext = (CONTEXT *)tcr->native_thread_info;
2027    HANDLE hthread = (HANDLE)(tcr->osid);
2028    pc where;
2029    area *cs = tcr->cs_area;
2030    LispObj foreign_rsp;
2031
2032    if (hthread == NULL) {
2033      return false;
2034    }
2035    rc = SuspendThread(hthread);
2036    if (rc == -1) {
2037      /* If the thread's simply dead, we should handle that here */
2038      return false;
2039    }
2040    pcontext->ContextFlags = CONTEXT_ALL;
2041    rc = GetThreadContext(hthread, pcontext);
2042    if (rc == 0) {
2043      return false;
2044    }
2045    where = (pc)(xpPC(pcontext));
2046
2047    if (tcr->valence == TCR_STATE_LISP) {
2048      if ((where >= restore_windows_context_start) &&
2049          (where < restore_windows_context_end)) {
2050        pc_luser_restore_windows_context(pcontext, tcr, where);
2051      } else {
2052        area *ts = tcr->ts_area;
2053        /* If we're in the lisp heap, or in x86-spentry??.o, or in
2054           x86-subprims??.o, or in the subprims jump table at #x15000,
2055           or on the tstack ... we're just executing lisp code.  Otherwise,
2056           we got an exception while executing lisp code, but haven't
2057           entered the handler yet (still in Windows exception glue
2058           or switching stacks or something.)  In the latter case, we
2059           basically want to get to he handler and have it notice
2060           the pending exception request, and suspend the thread at that
2061           point. */
2062        if (!((where < (pc)lisp_global(HEAP_END)) &&
2063              (where >= (pc)lisp_global(HEAP_START))) &&
2064            (!((where < (pc)(managed_static_area->active)) &&
2065              (where >= (pc)(readonly_area->low)))) &&
2066            !((where < spentry_end) && (where >= spentry_start)) &&
2067            !((where < subprims_end) && (where >= subprims_start)) &&
2068            !((where < (pc) 0x16000) &&
2069              (where >= (pc) 0x15000)) &&
2070            !((where < (pc) (ts->high)) &&
2071              (where >= (pc) (ts->low)))) {
2072          /* The thread has lisp valence, but is not executing code
2073             where we expect lisp code to be and is not exiting from
2074             an exception handler.  That pretty much means that it's
2075             on its way into an exception handler; we have to handshake
2076             until it enters an exception-wait state. */
2077          /* There are likely race conditions here */
2078          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2079          ResumeThread(hthread);
2080          SEM_WAIT_FOREVER(tcr->suspend);
2081          SuspendThread(hthread);
2082          /* The thread is either waiting for its resume semaphore to
2083             be signaled or is about to wait.  Signal it now, while
2084             the thread's suspended. */
2085          SEM_RAISE(tcr->resume);
2086          pcontext->ContextFlags = CONTEXT_ALL;
2087          GetThreadContext(hthread, pcontext);
2088        }
2089      }
2090#if 0
2091    } else {
2092      if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) {
2093        if (!tcr->pending_exception_context) {
2094          FBug(pcontext, "we're confused here.");
2095        }
2096        *pcontext = *tcr->pending_exception_context;
2097        tcr->pending_exception_context = NULL;
2098        tcr->valence = TCR_STATE_LISP;
2099      }
2100#endif
2101    }
2102    tcr->suspend_context = pcontext;
2103    return true;
2104  }
2105  return false;
2106}
2107#else
2108Boolean
2109suspend_tcr(TCR *tcr)
2110{
2111  int suspend_count = atomic_incf(&(tcr->suspend_count));
2112  pthread_t thread;
2113  if (suspend_count == 1) {
2114    thread = (pthread_t)(tcr->osid);
2115    if ((thread != (pthread_t) 0) &&
2116        (pthread_kill(thread, thread_suspend_signal) == 0)) {
2117      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2118    } else {
2119      /* A problem using pthread_kill.  On Darwin, this can happen
2120         if the thread has had its signal mask surgically removed
2121         by pthread_exit.  If the native (Mach) thread can be suspended,
2122         do that and return true; otherwise, flag the tcr as belonging
2123         to a dead thread by setting tcr->osid to 0.
2124      */
2125      tcr->osid = 0;
2126      return false;
2127    }
2128    return true;
2129  }
2130  return false;
2131}
2132#endif
2133
2134#ifdef WINDOWS
2135Boolean
2136tcr_suspend_ack(TCR *tcr)
2137{
2138  return true;
2139}
2140#else
2141Boolean
2142tcr_suspend_ack(TCR *tcr)
2143{
2144  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
2145    SEM_WAIT_FOREVER(tcr->suspend);
2146    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2147  }
2148  return true;
2149}
2150#endif
2151     
2152
2153Boolean
2154kill_tcr(TCR *tcr)
2155{
2156  TCR *current = get_tcr(true);
2157  Boolean result = false;
2158
2159  LOCK(lisp_global(TCR_AREA_LOCK),current);
2160  {
2161    LispObj osid = tcr->osid;
2162   
2163    if (osid) {
2164      result = true;
2165#ifdef WINDOWS
2166      /* What we really want to do here is (something like)
2167         forcing the thread to run quit_handler().  For now,
2168         mark the TCR as dead and kill the Windows thread. */
2169      tcr->osid = 0;
2170      if (!TerminateThread((HANDLE)osid, 0)) {
2171        CloseHandle((HANDLE)osid);
2172        result = false;
2173      } else {
2174        CloseHandle((HANDLE)osid);
2175        shutdown_thread_tcr(tcr);
2176      }
2177#else
2178      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2179        result = false;
2180      }
2181#endif
2182    }
2183  }
2184  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2185  return result;
2186}
2187
2188Boolean
2189lisp_suspend_tcr(TCR *tcr)
2190{
2191  Boolean suspended;
2192  TCR *current = get_tcr(true);
2193 
2194  LOCK(lisp_global(TCR_AREA_LOCK),current);
2195  suspended = suspend_tcr(tcr);
2196  if (suspended) {
2197    while (!tcr_suspend_ack(tcr));
2198  }
2199  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2200  return suspended;
2201}
2202         
2203#ifdef WINDOWS
2204Boolean
2205resume_tcr(TCR *tcr)
2206{
2207  int suspend_count = atomic_decf(&(tcr->suspend_count)), err;
2208  DWORD rc;
2209  if (suspend_count == 0) {
2210    CONTEXT *context = tcr->suspend_context;
2211    HANDLE hthread = (HANDLE)(tcr->osid);
2212
2213    if (context) {
2214      context->ContextFlags = CONTEXT_ALL;
2215      tcr->suspend_context = NULL;
2216      SetThreadContext(hthread,context);
2217      rc = ResumeThread(hthread);
2218      if (rc == -1) {
2219        wperror("ResumeThread");
2220        return false;
2221      }
2222      return true;
2223    }
2224  }
2225  return false;
2226}   
2227#else
2228Boolean
2229resume_tcr(TCR *tcr)
2230{
2231  int suspend_count = atomic_decf(&(tcr->suspend_count));
2232  if (suspend_count == 0) {
2233    void *s = (tcr->resume);
2234    if (s != NULL) {
2235      SEM_RAISE(s);
2236      return true;
2237    }
2238  }
2239  return false;
2240}
2241#endif
2242
2243   
2244
2245
2246Boolean
2247lisp_resume_tcr(TCR *tcr)
2248{
2249  Boolean resumed;
2250  TCR *current = get_tcr(true);
2251 
2252  LOCK(lisp_global(TCR_AREA_LOCK),current);
2253  resumed = resume_tcr(tcr);
2254  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2255  return resumed;
2256}
2257
2258
2259TCR *freed_tcrs = NULL;
2260
2261void
2262enqueue_freed_tcr (TCR *tcr)
2263{
2264#ifndef HAVE_TLS
2265  tcr->next = freed_tcrs;
2266  freed_tcrs = tcr;
2267#endif
2268}
2269
2270/* It's not clear that we can safely condemn a dead tcr's areas, since
2271   we may not be able to call free() if a suspended thread owns a
2272   malloc lock. At least make the areas appear to be empty.
2273*/
2274   
2275
2276void
2277normalize_dead_tcr_areas(TCR *tcr)
2278{
2279  area *a;
2280
2281  a = tcr->vs_area;
2282  if (a) {
2283    a->active = a->high;
2284  }
2285
2286#ifndef ARM
2287  a = tcr->ts_area;
2288  if (a) {
2289    a->active = a->high;
2290  }
2291#endif
2292
2293  a = tcr->cs_area;
2294  if (a) {
2295    a->active = a->high;
2296  }
2297}
2298   
2299void
2300free_freed_tcrs ()
2301{
2302  TCR *current, *next;
2303
2304  for (current = freed_tcrs; current; current = next) {
2305    next = current->next;
2306#ifndef HAVE_TLS
2307#ifdef WIN32
2308    free(current->allocated);
2309#else
2310    free(current);
2311#endif
2312#endif
2313  }
2314  freed_tcrs = NULL;
2315}
2316
2317void
2318suspend_other_threads(Boolean for_gc)
2319{
2320  TCR *current = get_tcr(true), *other, *next;
2321  int dead_tcr_count = 0;
2322  Boolean all_acked;
2323
2324  LOCK(lisp_global(TCR_AREA_LOCK), current);
2325  for (other = current->next; other != current; other = other->next) {
2326    if ((other->osid != 0)) {
2327      suspend_tcr(other);
2328      if (other->osid == 0) {
2329        dead_tcr_count++;
2330      }
2331    } else {
2332      dead_tcr_count++;
2333    }
2334  }
2335
2336  do {
2337    all_acked = true;
2338    for (other = current->next; other != current; other = other->next) {
2339      if ((other->osid != 0)) {
2340        if (!tcr_suspend_ack(other)) {
2341          all_acked = false;
2342        }
2343      }
2344    }
2345  } while(! all_acked);
2346
2347     
2348
2349  /* All other threads are suspended; can safely delete dead tcrs now */
2350  if (dead_tcr_count) {
2351    for (other = current->next; other != current; other = next) {
2352      next = other->next;
2353      if ((other->osid == 0))  {
2354        normalize_dead_tcr_areas(other);
2355        dequeue_tcr(other);
2356        enqueue_freed_tcr(other);
2357      }
2358    }
2359  }
2360}
2361
2362void
2363lisp_suspend_other_threads()
2364{
2365  suspend_other_threads(false);
2366}
2367
2368void
2369resume_other_threads(Boolean for_gc)
2370{
2371  TCR *current = get_tcr(true), *other;
2372  for (other = current->next; other != current; other = other->next) {
2373    if ((other->osid != 0)) {
2374      resume_tcr(other);
2375    }
2376  }
2377  free_freed_tcrs();
2378  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2379}
2380
2381void
2382lisp_resume_other_threads()
2383{
2384  resume_other_threads(false);
2385}
2386
2387
2388
2389rwlock *
2390rwlock_new()
2391{
2392  extern int cache_block_size;
2393
2394  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2395  rwlock *rw = NULL;;
2396 
2397  if (p) {
2398    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2399    rw->malloced_ptr = p;
2400#ifndef USE_FUTEX
2401    rw->reader_signal = new_semaphore(0);
2402    rw->writer_signal = new_semaphore(0);
2403    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2404      if (rw->reader_signal) {
2405        destroy_semaphore(&(rw->reader_signal));
2406      } else {
2407        destroy_semaphore(&(rw->writer_signal));
2408      }
2409      free(rw);
2410      rw = NULL;
2411    }
2412#endif
2413  }
2414  return rw;
2415}
2416
2417     
2418/*
2419  Try to get read access to a multiple-readers/single-writer lock.  If
2420  we already have read access, return success (indicating that the
2421  lock is held another time.  If we already have write access to the
2422  lock ... that won't work; return EDEADLK.  Wait until no other
2423  thread has or is waiting for write access, then indicate that we
2424  hold read access once.
2425*/
2426#ifndef USE_FUTEX
2427int
2428rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2429{
2430  int err = 0;
2431 
2432  LOCK_SPINLOCK(rw->spin, tcr);
2433
2434  if (rw->writer == tcr) {
2435    RELEASE_SPINLOCK(rw->spin);
2436    return EDEADLK;
2437  }
2438
2439  while (rw->blocked_writers || (rw->state > 0)) {
2440    rw->blocked_readers++;
2441    RELEASE_SPINLOCK(rw->spin);
2442    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2443    LOCK_SPINLOCK(rw->spin,tcr);
2444    rw->blocked_readers--;
2445    if (err == EINTR) {
2446      err = 0;
2447    }
2448    if (err) {
2449      RELEASE_SPINLOCK(rw->spin);
2450      return err;
2451    }
2452  }
2453  rw->state--;
2454  RELEASE_SPINLOCK(rw->spin);
2455  return err;
2456}
2457#else
2458int
2459rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2460{
2461  natural waitval;
2462
2463  lock_futex(&rw->spin);
2464
2465  if (rw->writer == tcr) {
2466    unlock_futex(&rw->spin);
2467    return EDEADLOCK;
2468  }
2469  while (1) {
2470    if (rw->writer == NULL) {
2471      --rw->state;
2472      unlock_futex(&rw->spin);
2473      return 0;
2474    }
2475    rw->blocked_readers++;
2476    waitval = rw->reader_signal;
2477    unlock_futex(&rw->spin);
2478    futex_wait(&rw->reader_signal,waitval);
2479    lock_futex(&rw->spin);
2480    rw->blocked_readers--;
2481  }
2482  return 0;
2483}
2484#endif   
2485
2486
2487/*
2488  Try to obtain write access to the lock.
2489  It is an error if we already have read access, but it's hard to
2490  detect that.
2491  If we already have write access, increment the count that indicates
2492  that.
2493  Otherwise, wait until the lock is not held for reading or writing,
2494  then assert write access.
2495*/
2496
2497#ifndef USE_FUTEX
2498int
2499rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2500{
2501  int err = 0;
2502
2503  LOCK_SPINLOCK(rw->spin,tcr);
2504  if (rw->writer == tcr) {
2505    rw->state++;
2506    RELEASE_SPINLOCK(rw->spin);
2507    return 0;
2508  }
2509
2510  while (rw->state != 0) {
2511    rw->blocked_writers++;
2512    RELEASE_SPINLOCK(rw->spin);
2513    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2514    LOCK_SPINLOCK(rw->spin,tcr);
2515    rw->blocked_writers--;
2516    if (err == EINTR) {
2517      err = 0;
2518    }
2519    if (err) {
2520      RELEASE_SPINLOCK(rw->spin);
2521      return err;
2522    }
2523  }
2524  rw->state = 1;
2525  rw->writer = tcr;
2526  RELEASE_SPINLOCK(rw->spin);
2527  return err;
2528}
2529
2530#else
2531int
2532rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2533{
2534  int err = 0;
2535  natural waitval;
2536
2537  lock_futex(&rw->spin);
2538  if (rw->writer == tcr) {
2539    rw->state++;
2540    unlock_futex(&rw->spin);
2541    return 0;
2542  }
2543
2544  while (rw->state != 0) {
2545    rw->blocked_writers++;
2546    waitval = rw->writer_signal;
2547    unlock_futex(&rw->spin);
2548    futex_wait(&rw->writer_signal,waitval);
2549    lock_futex(&rw->spin);
2550    rw->blocked_writers--;
2551  }
2552  rw->state = 1;
2553  rw->writer = tcr;
2554  unlock_futex(&rw->spin);
2555  return err;
2556}
2557#endif
2558
2559/*
2560  Sort of the same as above, only return EBUSY if we'd have to wait.
2561*/
2562#ifndef USE_FUTEX
2563int
2564rwlock_try_wlock(rwlock *rw, TCR *tcr)
2565{
2566  int ret = EBUSY;
2567
2568  LOCK_SPINLOCK(rw->spin,tcr);
2569  if (rw->writer == tcr) {
2570    rw->state++;
2571    ret = 0;
2572  } else {
2573    if (rw->state == 0) {
2574      rw->writer = tcr;
2575      rw->state = 1;
2576      ret = 0;
2577    }
2578  }
2579  RELEASE_SPINLOCK(rw->spin);
2580  return ret;
2581}
2582#else
2583int
2584rwlock_try_wlock(rwlock *rw, TCR *tcr)
2585{
2586  int ret = EBUSY;
2587
2588  lock_futex(&rw->spin);
2589  if (rw->writer == tcr) {
2590    rw->state++;
2591    ret = 0;
2592  } else {
2593    if (rw->state == 0) {
2594      rw->writer = tcr;
2595      rw->state = 1;
2596      ret = 0;
2597    }
2598  }
2599  unlock_futex(&rw->spin);
2600  return ret;
2601}
2602#endif
2603
2604#ifndef USE_FUTEX
2605int
2606rwlock_try_rlock(rwlock *rw, TCR *tcr)
2607{
2608  int ret = EBUSY;
2609
2610  LOCK_SPINLOCK(rw->spin,tcr);
2611  if (rw->state <= 0) {
2612    --rw->state;
2613    ret = 0;
2614  }
2615  RELEASE_SPINLOCK(rw->spin);
2616  return ret;
2617}
2618#else
2619int
2620rwlock_try_rlock(rwlock *rw, TCR *tcr)
2621{
2622  int ret = EBUSY;
2623
2624  lock_futex(&rw->spin);
2625  if (rw->state <= 0) {
2626    --rw->state;
2627    ret = 0;
2628  }
2629  unlock_futex(&rw->spin);
2630  return ret;
2631}
2632#endif
2633
2634
2635
2636#ifndef USE_FUTEX
2637int
2638rwlock_unlock(rwlock *rw, TCR *tcr)
2639{
2640
2641  int err = 0;
2642  natural blocked_readers = 0;
2643
2644  LOCK_SPINLOCK(rw->spin,tcr);
2645  if (rw->state > 0) {
2646    if (rw->writer != tcr) {
2647      err = EINVAL;
2648    } else {
2649      --rw->state;
2650      if (rw->state == 0) {
2651        rw->writer = NULL;
2652      }
2653    }
2654  } else {
2655    if (rw->state < 0) {
2656      ++rw->state;
2657    } else {
2658      err = EINVAL;
2659    }
2660  }
2661  if (err) {
2662    RELEASE_SPINLOCK(rw->spin);
2663    return err;
2664  }
2665 
2666  if (rw->state == 0) {
2667    if (rw->blocked_writers) {
2668      SEM_RAISE(rw->writer_signal);
2669    } else {
2670      blocked_readers = rw->blocked_readers;
2671      if (blocked_readers) {
2672        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2673      }
2674    }
2675  }
2676  RELEASE_SPINLOCK(rw->spin);
2677  return 0;
2678}
2679#else
2680int
2681rwlock_unlock(rwlock *rw, TCR *tcr)
2682{
2683
2684  int err = 0;
2685
2686  lock_futex(&rw->spin);
2687  if (rw->state > 0) {
2688    if (rw->writer != tcr) {
2689      err = EINVAL;
2690    } else {
2691      --rw->state;
2692      if (rw->state == 0) {
2693        rw->writer = NULL;
2694      }
2695    }
2696  } else {
2697    if (rw->state < 0) {
2698      ++rw->state;
2699    } else {
2700      err = EINVAL;
2701    }
2702  }
2703  if (err) {
2704    unlock_futex(&rw->spin);
2705    return err;
2706  }
2707 
2708  if (rw->state == 0) {
2709    if (rw->blocked_writers) {
2710      ++rw->writer_signal;
2711      unlock_futex(&rw->spin);
2712      futex_wake(&rw->writer_signal,1);
2713      return 0;
2714    }
2715    if (rw->blocked_readers) {
2716      ++rw->reader_signal;
2717      unlock_futex(&rw->spin);
2718      futex_wake(&rw->reader_signal, INT_MAX);
2719      return 0;
2720    }
2721  }
2722  unlock_futex(&rw->spin);
2723  return 0;
2724}
2725#endif
2726
2727       
2728void
2729rwlock_destroy(rwlock *rw)
2730{
2731#ifndef USE_FUTEX
2732  destroy_semaphore((void **)&rw->reader_signal);
2733  destroy_semaphore((void **)&rw->writer_signal);
2734#endif
2735  postGCfree((void *)(rw->malloced_ptr));
2736}
2737
2738
2739
Note: See TracBrowser for help on using the repository browser.