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

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

Free the (separate) signal stack on thread exit on ARM Linux.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 59.1 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#ifndef MAP_GROWSDOWN
1601#define MAP_GROWSDOWN 0
1602#endif
1603
1604Ptr
1605create_stack(natural size)
1606{
1607  Ptr p;
1608  size=align_to_power_of_2(size, log2_page_size);
1609  p = (Ptr) MapMemoryForStack((size_t)size);
1610  if (p != (Ptr)(-1)) {
1611    *((size_t *)p) = size;
1612    return p;
1613  }
1614  allocation_failure(true, size);
1615
1616}
1617
1618void *
1619allocate_stack(natural size)
1620{
1621  return create_stack(size);
1622}
1623
1624void
1625free_stack(void *s)
1626{
1627  size_t size = *((size_t *)s);
1628  UnMapMemory(s, size);
1629}
1630
1631Boolean threads_initialized = false;
1632
1633#ifndef USE_FUTEX
1634#ifdef WINDOWS
1635void
1636count_cpus()
1637{
1638  SYSTEM_INFO si;
1639
1640  GetSystemInfo(&si);
1641  if (si.dwNumberOfProcessors > 1) {
1642    spin_lock_tries = 1024;
1643  }
1644}
1645#else
1646void
1647count_cpus()
1648{
1649  int n = sysconf(_SC_NPROCESSORS_ONLN);
1650 
1651  if (n > 1) {
1652    spin_lock_tries = 1024;
1653  }
1654}
1655#endif
1656#endif
1657
1658void
1659init_threads(void * stack_base, TCR *tcr)
1660{
1661  lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr);
1662#ifdef WINDOWS
1663  lisp_global(TCR_KEY) = TlsAlloc();
1664  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
1665  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
1666#else
1667  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
1668  thread_signal_setup();
1669#endif
1670
1671#ifndef USE_FUTEX
1672  count_cpus();
1673#endif
1674  threads_initialized = true;
1675}
1676
1677
1678#ifdef WINDOWS
1679unsigned CALLBACK
1680#else
1681void *
1682#endif
1683lisp_thread_entry(void *param)
1684{
1685  thread_activation *activation = (thread_activation *)param;
1686  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
1687  LispObj *start_vsp;
1688#ifndef WINDOWS
1689  sigset_t mask, old_mask;
1690
1691  sigemptyset(&mask);
1692  pthread_sigmask(SIG_SETMASK, &mask, &old_mask);
1693#endif
1694
1695  register_thread_tcr(tcr);
1696
1697#ifndef WINDOWS
1698  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1699#endif
1700  tcr->vs_area->active -= node_size;
1701  *(--tcr->save_vsp) = lisp_nil;
1702  start_vsp = tcr->save_vsp;
1703  enable_fp_exceptions();
1704  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1705  activation->tcr = tcr;
1706  SEM_RAISE(activation->created);
1707  do {
1708    SEM_RAISE(tcr->reset_completion);
1709    SEM_WAIT_FOREVER(tcr->activate);
1710    /* Now go run some lisp code */
1711    start_lisp(TCR_TO_TSD(tcr),0);
1712    tcr->save_vsp = start_vsp;
1713  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1714#ifndef WINDOWS
1715  pthread_cleanup_pop(true);
1716#else
1717  tcr_cleanup(tcr);
1718#endif
1719#ifdef WINDOWS
1720  return 0;
1721#else
1722  return NULL;
1723#endif
1724}
1725
1726typedef 
1727short (*suspendf)();
1728
1729
1730void
1731suspend_current_cooperative_thread()
1732{
1733  static suspendf cooperative_suspend = NULL;
1734  void *xFindSymbol(void*,char*);
1735
1736  if (cooperative_suspend == NULL) {
1737    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
1738  }
1739  if (cooperative_suspend) {
1740    cooperative_suspend(1 /* kCurrentThreadID */,
1741                        1 /* kStoppedThreadState */,
1742                        0 /* kAnyThreadID */);
1743  }
1744}
1745
1746void *
1747cooperative_thread_startup(void *arg)
1748{
1749
1750  TCR *tcr = get_tcr(0);
1751  LispObj *start_vsp;
1752
1753  if (!tcr) {
1754    return NULL;
1755  }
1756#ifndef WINDOWS
1757  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
1758#endif
1759  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
1760  start_vsp = tcr->save_vsp;
1761  do {
1762    SEM_RAISE(tcr->reset_completion);
1763    suspend_current_cooperative_thread();
1764     
1765    start_lisp(tcr, 0);
1766    tcr->save_vsp = start_vsp;
1767  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
1768#ifndef WINDOWS
1769  pthread_cleanup_pop(true);
1770#else
1771  tcr_cleanup(tcr);
1772#endif
1773}
1774
1775void *
1776xNewThread(natural control_stack_size,
1777           natural value_stack_size,
1778           natural temp_stack_size)
1779
1780{
1781  thread_activation activation;
1782
1783
1784  activation.tsize = temp_stack_size;
1785  activation.vsize = value_stack_size;
1786  activation.tcr = 0;
1787  activation.created = new_semaphore(0);
1788  if (create_system_thread(control_stack_size +(CSTACK_HARDPROT+CSTACK_SOFTPROT), 
1789                           NULL, 
1790                           lisp_thread_entry,
1791                           (void *) &activation)) {
1792   
1793    SEM_WAIT_FOREVER(activation.created);       /* Wait until thread's entered its initial function */
1794  }
1795  destroy_semaphore(&activation.created); 
1796  return TCR_TO_TSD(activation.tcr);
1797}
1798
1799Boolean
1800active_tcr_p(TCR *q)
1801{
1802  TCR *head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)), *p = head;
1803 
1804  do {
1805    if (p == q) {
1806      return true;
1807    }
1808    p = p->next;
1809  } while (p != head);
1810  return false;
1811}
1812
1813#ifdef WINDOWS
1814OSErr
1815xDisposeThread(TCR *tcr)
1816{
1817  return 0;                     /* I don't think that this is ever called. */
1818}
1819#else
1820OSErr
1821xDisposeThread(TCR *tcr)
1822{
1823  if (tcr != (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR))) {
1824    if (active_tcr_p(tcr) && (tcr != get_tcr(false))) {
1825      pthread_cancel((pthread_t)(tcr->osid));
1826      return 0;
1827    }
1828  }
1829  return -50;
1830}
1831#endif
1832
1833OSErr
1834xYieldToThread(TCR *target)
1835{
1836  Bug(NULL, "xYieldToThread ?");
1837  return 0;
1838}
1839 
1840OSErr
1841xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP)
1842{
1843  Bug(NULL, "xThreadCurrentStackSpace ?");
1844  return 0;
1845}
1846
1847
1848#ifdef WINDOWS
1849Boolean
1850create_system_thread(size_t stack_size,
1851                     void* stackaddr,
1852                     unsigned CALLBACK (*start_routine)(void *),
1853                     void* param)
1854{
1855  HANDLE thread_handle;
1856  Boolean won = false;
1857
1858  stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1));
1859
1860  thread_handle = (HANDLE)_beginthreadex(NULL, 
1861                                         stack_size,
1862                                         start_routine,
1863                                         param,
1864                                         0, 
1865                                         NULL);
1866
1867  if (thread_handle == NULL) {
1868    wperror("CreateThread");
1869  } else {
1870    won = true;
1871    CloseHandle(thread_handle);
1872  }
1873  return won;
1874}
1875#else
1876Boolean
1877create_system_thread(size_t stack_size,  void *stackaddr,
1878                     void *(*start_routine)(void *), void *param)
1879{
1880  pthread_attr_t attr;
1881  pthread_t returned_thread;
1882  int err;
1883  TCR *current = get_tcr(true);
1884
1885  pthread_attr_init(&attr);
1886  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); 
1887
1888  if (stack_size == MINIMAL_THREAD_STACK_SIZE) {
1889    stack_size = PTHREAD_STACK_MIN;
1890  }
1891
1892  stack_size = ensure_stack_limit(stack_size);
1893  if (stackaddr != NULL) {
1894    /* Size must have been specified.  Sort of makes sense ... */
1895    pthread_attr_setstack(&attr, stackaddr, stack_size);
1896  } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) {
1897    pthread_attr_setstacksize(&attr,stack_size);
1898  }
1899
1900  /*
1901     I think that's just about enough ... create the thread.
1902     Well ... not quite enough.  In Leopard (at least), many
1903     pthread routines grab an internal spinlock when validating
1904     their arguments.  If we suspend a thread that owns this
1905     spinlock, we deadlock.  We can't in general keep that
1906     from happening: if arbitrary C code is suspended while
1907     it owns the spinlock, we still deadlock.  It seems that
1908     the best that we can do is to keep -this- code from
1909     getting suspended (by grabbing TCR_AREA_LOCK)
1910  */
1911  LOCK(lisp_global(TCR_AREA_LOCK),current);
1912  err = pthread_create(&returned_thread, &attr, start_routine, param);
1913  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
1914  pthread_attr_destroy(&attr);
1915  return (err == 0);
1916}
1917#endif
1918
1919TCR *
1920get_tcr(Boolean create)
1921{
1922#ifdef HAVE_TLS
1923  TCR *current = current_tcr;
1924#else
1925  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
1926  TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd);
1927#endif
1928
1929  if ((current == NULL) && create) {
1930    LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell,
1931      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
1932    int i, nbindwords = 0;
1933    extern natural initial_stack_size;
1934   
1935    /* Make one. */
1936    current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1937    SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN);
1938    register_thread_tcr(current);
1939#ifdef DEBUG_TCR_CREATION
1940#ifndef WINDOWS
1941    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
1942#endif
1943#endif
1944    current->vs_area->active -= node_size;
1945    *(--current->save_vsp) = lisp_nil;
1946#ifdef PPC
1947#define NSAVEREGS 8
1948#endif
1949#ifdef X8664
1950#define NSAVEREGS 4
1951#endif
1952#ifdef X8632
1953#define NSAVEREGS 0
1954#endif
1955#ifdef ARM
1956#define NSAVEREGS 0
1957#endif
1958    for (i = 0; i < NSAVEREGS; i++) {
1959      *(--current->save_vsp) = 0;
1960      current->vs_area->active -= node_size;
1961    }
1962    nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1);
1963    for (i = 0; i < nbindwords; i++) {
1964      *(--current->save_vsp) = 0;
1965      current->vs_area->active -= node_size;
1966    }
1967    current->shutdown_count = 1;
1968    ((void (*)())ptr_from_lispobj(callback_ptr))(0);
1969
1970  }
1971 
1972  return current;
1973}
1974
1975#ifdef WINDOWS
1976void *
1977pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
1978{
1979  /* Thread has started to return from an exception. */
1980  if (where < restore_windows_context_iret) {
1981    /* In the process of restoring registers; context still in
1982       %rcx.  Just make our suspend_context be the context
1983       we're trying to restore, so that we'll resume from
1984       the suspend in the same context that we're trying to
1985       restore */
1986#ifdef WIN_64
1987    *pcontext = * (CONTEXT *)(pcontext->Rcx);
1988#else
1989    if (where == restore_windows_context_start) {
1990      *pcontext = * (CONTEXT *)((pcontext->Esp)+4);
1991    } else {
1992      *pcontext = * (CONTEXT *)(pcontext->Ecx);
1993    }
1994#endif
1995  } else {
1996    /* Most of the context has already been restored; fix %rcx
1997       if need be, then restore ss:rsp, cs:rip, and flags. */
1998#ifdef WIN_64
1999    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
2000
2001    pcontext->Rip = iret_frame->Rip;
2002    pcontext->SegCs = (WORD) iret_frame->Cs;
2003    pcontext->EFlags = (DWORD) iret_frame->Rflags;
2004    pcontext->Rsp = iret_frame->Rsp;
2005    pcontext->SegSs = (WORD) iret_frame->Ss;
2006#else
2007    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
2008
2009    pcontext->Eip = iret_frame->Eip;
2010    pcontext->SegCs = (WORD) iret_frame->Cs;
2011    pcontext->EFlags = (DWORD) iret_frame->EFlags;
2012    pcontext->Esp += sizeof(ia32_iret_frame);
2013#endif
2014  }
2015  tcr->pending_exception_context = NULL;
2016  /* We basically never return from an exception unless we
2017     were executing lisp code when the exception returned.
2018     If that ever changes, we need to know what valence
2019     would have been restored here.*/
2020  tcr->valence = TCR_STATE_LISP;
2021}
2022
2023Boolean
2024suspend_tcr(TCR *tcr)
2025{
2026  int suspend_count = atomic_incf(&(tcr->suspend_count));
2027  DWORD rc;
2028  if (suspend_count == 1) {
2029    CONTEXT  *pcontext = (CONTEXT *)tcr->native_thread_info;
2030    HANDLE hthread = (HANDLE)(tcr->osid);
2031    pc where;
2032    area *cs = tcr->cs_area;
2033    LispObj foreign_rsp;
2034
2035    if (hthread == NULL) {
2036      return false;
2037    }
2038    rc = SuspendThread(hthread);
2039    if (rc == -1) {
2040      /* If the thread's simply dead, we should handle that here */
2041      return false;
2042    }
2043    pcontext->ContextFlags = CONTEXT_ALL;
2044    rc = GetThreadContext(hthread, pcontext);
2045    if (rc == 0) {
2046      return false;
2047    }
2048    where = (pc)(xpPC(pcontext));
2049
2050    if (tcr->valence == TCR_STATE_LISP) {
2051      if ((where >= restore_windows_context_start) &&
2052          (where < restore_windows_context_end)) {
2053        pc_luser_restore_windows_context(pcontext, tcr, where);
2054      } else {
2055        area *ts = tcr->ts_area;
2056        /* If we're in the lisp heap, or in x86-spentry??.o, or in
2057           x86-subprims??.o, or in the subprims jump table at #x15000,
2058           or on the tstack ... we're just executing lisp code.  Otherwise,
2059           we got an exception while executing lisp code, but haven't
2060           entered the handler yet (still in Windows exception glue
2061           or switching stacks or something.)  In the latter case, we
2062           basically want to get to he handler and have it notice
2063           the pending exception request, and suspend the thread at that
2064           point. */
2065        if (!((where < (pc)lisp_global(HEAP_END)) &&
2066              (where >= (pc)lisp_global(HEAP_START))) &&
2067            (!((where < (pc)(managed_static_area->active)) &&
2068              (where >= (pc)(readonly_area->low)))) &&
2069            !((where < spentry_end) && (where >= spentry_start)) &&
2070            !((where < subprims_end) && (where >= subprims_start)) &&
2071            !((where < (pc) 0x16000) &&
2072              (where >= (pc) 0x15000)) &&
2073            !((where < (pc) (ts->high)) &&
2074              (where >= (pc) (ts->low)))) {
2075          /* The thread has lisp valence, but is not executing code
2076             where we expect lisp code to be and is not exiting from
2077             an exception handler.  That pretty much means that it's
2078             on its way into an exception handler; we have to handshake
2079             until it enters an exception-wait state. */
2080          /* There are likely race conditions here */
2081          SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
2082          ResumeThread(hthread);
2083          SEM_WAIT_FOREVER(tcr->suspend);
2084          SuspendThread(hthread);
2085          /* The thread is either waiting for its resume semaphore to
2086             be signaled or is about to wait.  Signal it now, while
2087             the thread's suspended. */
2088          SEM_RAISE(tcr->resume);
2089          pcontext->ContextFlags = CONTEXT_ALL;
2090          GetThreadContext(hthread, pcontext);
2091        }
2092      }
2093#if 0
2094    } else {
2095      if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) {
2096        if (!tcr->pending_exception_context) {
2097          FBug(pcontext, "we're confused here.");
2098        }
2099        *pcontext = *tcr->pending_exception_context;
2100        tcr->pending_exception_context = NULL;
2101        tcr->valence = TCR_STATE_LISP;
2102      }
2103#endif
2104    }
2105    tcr->suspend_context = pcontext;
2106    return true;
2107  }
2108  return false;
2109}
2110#else
2111Boolean
2112suspend_tcr(TCR *tcr)
2113{
2114  int suspend_count = atomic_incf(&(tcr->suspend_count));
2115  pthread_t thread;
2116  if (suspend_count == 1) {
2117    thread = (pthread_t)(tcr->osid);
2118    if ((thread != (pthread_t) 0) &&
2119        (pthread_kill(thread, thread_suspend_signal) == 0)) {
2120      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2121    } else {
2122      /* A problem using pthread_kill.  On Darwin, this can happen
2123         if the thread has had its signal mask surgically removed
2124         by pthread_exit.  If the native (Mach) thread can be suspended,
2125         do that and return true; otherwise, flag the tcr as belonging
2126         to a dead thread by setting tcr->osid to 0.
2127      */
2128      tcr->osid = 0;
2129      return false;
2130    }
2131    return true;
2132  }
2133  return false;
2134}
2135#endif
2136
2137#ifdef WINDOWS
2138Boolean
2139tcr_suspend_ack(TCR *tcr)
2140{
2141  return true;
2142}
2143#else
2144Boolean
2145tcr_suspend_ack(TCR *tcr)
2146{
2147  if (tcr->flags & (1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING)) {
2148    SEM_WAIT_FOREVER(tcr->suspend);
2149    tcr->flags &= ~(1<<TCR_FLAG_BIT_SUSPEND_ACK_PENDING);
2150  }
2151  return true;
2152}
2153#endif
2154     
2155
2156Boolean
2157kill_tcr(TCR *tcr)
2158{
2159  TCR *current = get_tcr(true);
2160  Boolean result = false;
2161
2162  LOCK(lisp_global(TCR_AREA_LOCK),current);
2163  {
2164    LispObj osid = tcr->osid;
2165   
2166    if (osid) {
2167      result = true;
2168#ifdef WINDOWS
2169      /* What we really want to do here is (something like)
2170         forcing the thread to run quit_handler().  For now,
2171         mark the TCR as dead and kill the Windows thread. */
2172      tcr->osid = 0;
2173      if (!TerminateThread((HANDLE)osid, 0)) {
2174        CloseHandle((HANDLE)osid);
2175        result = false;
2176      } else {
2177        CloseHandle((HANDLE)osid);
2178        shutdown_thread_tcr(tcr);
2179      }
2180#else
2181      if (pthread_kill((pthread_t)osid,thread_kill_signal)) {
2182        result = false;
2183      }
2184#endif
2185    }
2186  }
2187  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2188  return result;
2189}
2190
2191Boolean
2192lisp_suspend_tcr(TCR *tcr)
2193{
2194  Boolean suspended;
2195  TCR *current = get_tcr(true);
2196 
2197  LOCK(lisp_global(TCR_AREA_LOCK),current);
2198  suspended = suspend_tcr(tcr);
2199  if (suspended) {
2200    while (!tcr_suspend_ack(tcr));
2201  }
2202  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
2203  return suspended;
2204}
2205         
2206#ifdef WINDOWS
2207Boolean
2208resume_tcr(TCR *tcr)
2209{
2210  int suspend_count = atomic_decf(&(tcr->suspend_count)), err;
2211  DWORD rc;
2212  if (suspend_count == 0) {
2213    CONTEXT *context = tcr->suspend_context;
2214    HANDLE hthread = (HANDLE)(tcr->osid);
2215
2216    if (context) {
2217      context->ContextFlags = CONTEXT_ALL;
2218      tcr->suspend_context = NULL;
2219      SetThreadContext(hthread,context);
2220      rc = ResumeThread(hthread);
2221      if (rc == -1) {
2222        wperror("ResumeThread");
2223        return false;
2224      }
2225      return true;
2226    }
2227  }
2228  return false;
2229}   
2230#else
2231Boolean
2232resume_tcr(TCR *tcr)
2233{
2234  int suspend_count = atomic_decf(&(tcr->suspend_count));
2235  if (suspend_count == 0) {
2236    void *s = (tcr->resume);
2237    if (s != NULL) {
2238      SEM_RAISE(s);
2239      return true;
2240    }
2241  }
2242  return false;
2243}
2244#endif
2245
2246   
2247
2248
2249Boolean
2250lisp_resume_tcr(TCR *tcr)
2251{
2252  Boolean resumed;
2253  TCR *current = get_tcr(true);
2254 
2255  LOCK(lisp_global(TCR_AREA_LOCK),current);
2256  resumed = resume_tcr(tcr);
2257  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2258  return resumed;
2259}
2260
2261
2262TCR *freed_tcrs = NULL;
2263
2264void
2265enqueue_freed_tcr (TCR *tcr)
2266{
2267#ifndef HAVE_TLS
2268  tcr->next = freed_tcrs;
2269  freed_tcrs = tcr;
2270#endif
2271}
2272
2273/* It's not clear that we can safely condemn a dead tcr's areas, since
2274   we may not be able to call free() if a suspended thread owns a
2275   malloc lock. At least make the areas appear to be empty.
2276*/
2277   
2278
2279void
2280normalize_dead_tcr_areas(TCR *tcr)
2281{
2282  area *a;
2283
2284  a = tcr->vs_area;
2285  if (a) {
2286    a->active = a->high;
2287  }
2288
2289#ifndef ARM
2290  a = tcr->ts_area;
2291  if (a) {
2292    a->active = a->high;
2293  }
2294#endif
2295
2296  a = tcr->cs_area;
2297  if (a) {
2298    a->active = a->high;
2299  }
2300}
2301   
2302void
2303free_freed_tcrs ()
2304{
2305  TCR *current, *next;
2306
2307  for (current = freed_tcrs; current; current = next) {
2308    next = current->next;
2309#ifndef HAVE_TLS
2310#ifdef WIN32
2311    free(current->allocated);
2312#else
2313    free(current);
2314#endif
2315#endif
2316  }
2317  freed_tcrs = NULL;
2318}
2319
2320void
2321suspend_other_threads(Boolean for_gc)
2322{
2323  TCR *current = get_tcr(true), *other, *next;
2324  int dead_tcr_count = 0;
2325  Boolean all_acked;
2326
2327  LOCK(lisp_global(TCR_AREA_LOCK), current);
2328  for (other = current->next; other != current; other = other->next) {
2329    if ((other->osid != 0)) {
2330      suspend_tcr(other);
2331      if (other->osid == 0) {
2332        dead_tcr_count++;
2333      }
2334    } else {
2335      dead_tcr_count++;
2336    }
2337  }
2338
2339  do {
2340    all_acked = true;
2341    for (other = current->next; other != current; other = other->next) {
2342      if ((other->osid != 0)) {
2343        if (!tcr_suspend_ack(other)) {
2344          all_acked = false;
2345        }
2346      }
2347    }
2348  } while(! all_acked);
2349
2350     
2351
2352  /* All other threads are suspended; can safely delete dead tcrs now */
2353  if (dead_tcr_count) {
2354    for (other = current->next; other != current; other = next) {
2355      next = other->next;
2356      if ((other->osid == 0))  {
2357        normalize_dead_tcr_areas(other);
2358        dequeue_tcr(other);
2359        enqueue_freed_tcr(other);
2360      }
2361    }
2362  }
2363}
2364
2365void
2366lisp_suspend_other_threads()
2367{
2368  suspend_other_threads(false);
2369}
2370
2371void
2372resume_other_threads(Boolean for_gc)
2373{
2374  TCR *current = get_tcr(true), *other;
2375  for (other = current->next; other != current; other = other->next) {
2376    if ((other->osid != 0)) {
2377      resume_tcr(other);
2378    }
2379  }
2380  free_freed_tcrs();
2381  UNLOCK(lisp_global(TCR_AREA_LOCK), current);
2382}
2383
2384void
2385lisp_resume_other_threads()
2386{
2387  resume_other_threads(false);
2388}
2389
2390
2391
2392rwlock *
2393rwlock_new()
2394{
2395  extern int cache_block_size;
2396
2397  void *p = calloc(1,sizeof(rwlock)+cache_block_size-1);
2398  rwlock *rw = NULL;;
2399 
2400  if (p) {
2401    rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1)));
2402    rw->malloced_ptr = p;
2403#ifndef USE_FUTEX
2404    rw->reader_signal = new_semaphore(0);
2405    rw->writer_signal = new_semaphore(0);
2406    if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) {
2407      if (rw->reader_signal) {
2408        destroy_semaphore(&(rw->reader_signal));
2409      } else {
2410        destroy_semaphore(&(rw->writer_signal));
2411      }
2412      free(rw);
2413      rw = NULL;
2414    }
2415#endif
2416  }
2417  return rw;
2418}
2419
2420     
2421/*
2422  Try to get read access to a multiple-readers/single-writer lock.  If
2423  we already have read access, return success (indicating that the
2424  lock is held another time.  If we already have write access to the
2425  lock ... that won't work; return EDEADLK.  Wait until no other
2426  thread has or is waiting for write access, then indicate that we
2427  hold read access once.
2428*/
2429#ifndef USE_FUTEX
2430int
2431rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2432{
2433  int err = 0;
2434 
2435  LOCK_SPINLOCK(rw->spin, tcr);
2436
2437  if (rw->writer == tcr) {
2438    RELEASE_SPINLOCK(rw->spin);
2439    return EDEADLK;
2440  }
2441
2442  while (rw->blocked_writers || (rw->state > 0)) {
2443    rw->blocked_readers++;
2444    RELEASE_SPINLOCK(rw->spin);
2445    err = semaphore_maybe_timedwait(rw->reader_signal,waitfor);
2446    LOCK_SPINLOCK(rw->spin,tcr);
2447    rw->blocked_readers--;
2448    if (err == EINTR) {
2449      err = 0;
2450    }
2451    if (err) {
2452      RELEASE_SPINLOCK(rw->spin);
2453      return err;
2454    }
2455  }
2456  rw->state--;
2457  RELEASE_SPINLOCK(rw->spin);
2458  return err;
2459}
2460#else
2461int
2462rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2463{
2464  natural waitval;
2465
2466  lock_futex(&rw->spin);
2467
2468  if (rw->writer == tcr) {
2469    unlock_futex(&rw->spin);
2470    return EDEADLOCK;
2471  }
2472  while (1) {
2473    if (rw->writer == NULL) {
2474      --rw->state;
2475      unlock_futex(&rw->spin);
2476      return 0;
2477    }
2478    rw->blocked_readers++;
2479    waitval = rw->reader_signal;
2480    unlock_futex(&rw->spin);
2481    futex_wait(&rw->reader_signal,waitval);
2482    lock_futex(&rw->spin);
2483    rw->blocked_readers--;
2484  }
2485  return 0;
2486}
2487#endif   
2488
2489
2490/*
2491  Try to obtain write access to the lock.
2492  It is an error if we already have read access, but it's hard to
2493  detect that.
2494  If we already have write access, increment the count that indicates
2495  that.
2496  Otherwise, wait until the lock is not held for reading or writing,
2497  then assert write access.
2498*/
2499
2500#ifndef USE_FUTEX
2501int
2502rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2503{
2504  int err = 0;
2505
2506  LOCK_SPINLOCK(rw->spin,tcr);
2507  if (rw->writer == tcr) {
2508    rw->state++;
2509    RELEASE_SPINLOCK(rw->spin);
2510    return 0;
2511  }
2512
2513  while (rw->state != 0) {
2514    rw->blocked_writers++;
2515    RELEASE_SPINLOCK(rw->spin);
2516    err = semaphore_maybe_timedwait(rw->writer_signal, waitfor);
2517    LOCK_SPINLOCK(rw->spin,tcr);
2518    rw->blocked_writers--;
2519    if (err == EINTR) {
2520      err = 0;
2521    }
2522    if (err) {
2523      RELEASE_SPINLOCK(rw->spin);
2524      return err;
2525    }
2526  }
2527  rw->state = 1;
2528  rw->writer = tcr;
2529  RELEASE_SPINLOCK(rw->spin);
2530  return err;
2531}
2532
2533#else
2534int
2535rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor)
2536{
2537  int err = 0;
2538  natural waitval;
2539
2540  lock_futex(&rw->spin);
2541  if (rw->writer == tcr) {
2542    rw->state++;
2543    unlock_futex(&rw->spin);
2544    return 0;
2545  }
2546
2547  while (rw->state != 0) {
2548    rw->blocked_writers++;
2549    waitval = rw->writer_signal;
2550    unlock_futex(&rw->spin);
2551    futex_wait(&rw->writer_signal,waitval);
2552    lock_futex(&rw->spin);
2553    rw->blocked_writers--;
2554  }
2555  rw->state = 1;
2556  rw->writer = tcr;
2557  unlock_futex(&rw->spin);
2558  return err;
2559}
2560#endif
2561
2562/*
2563  Sort of the same as above, only return EBUSY if we'd have to wait.
2564*/
2565#ifndef USE_FUTEX
2566int
2567rwlock_try_wlock(rwlock *rw, TCR *tcr)
2568{
2569  int ret = EBUSY;
2570
2571  LOCK_SPINLOCK(rw->spin,tcr);
2572  if (rw->writer == tcr) {
2573    rw->state++;
2574    ret = 0;
2575  } else {
2576    if (rw->state == 0) {
2577      rw->writer = tcr;
2578      rw->state = 1;
2579      ret = 0;
2580    }
2581  }
2582  RELEASE_SPINLOCK(rw->spin);
2583  return ret;
2584}
2585#else
2586int
2587rwlock_try_wlock(rwlock *rw, TCR *tcr)
2588{
2589  int ret = EBUSY;
2590
2591  lock_futex(&rw->spin);
2592  if (rw->writer == tcr) {
2593    rw->state++;
2594    ret = 0;
2595  } else {
2596    if (rw->state == 0) {
2597      rw->writer = tcr;
2598      rw->state = 1;
2599      ret = 0;
2600    }
2601  }
2602  unlock_futex(&rw->spin);
2603  return ret;
2604}
2605#endif
2606
2607#ifndef USE_FUTEX
2608int
2609rwlock_try_rlock(rwlock *rw, TCR *tcr)
2610{
2611  int ret = EBUSY;
2612
2613  LOCK_SPINLOCK(rw->spin,tcr);
2614  if (rw->state <= 0) {
2615    --rw->state;
2616    ret = 0;
2617  }
2618  RELEASE_SPINLOCK(rw->spin);
2619  return ret;
2620}
2621#else
2622int
2623rwlock_try_rlock(rwlock *rw, TCR *tcr)
2624{
2625  int ret = EBUSY;
2626
2627  lock_futex(&rw->spin);
2628  if (rw->state <= 0) {
2629    --rw->state;
2630    ret = 0;
2631  }
2632  unlock_futex(&rw->spin);
2633  return ret;
2634}
2635#endif
2636
2637
2638
2639#ifndef USE_FUTEX
2640int
2641rwlock_unlock(rwlock *rw, TCR *tcr)
2642{
2643
2644  int err = 0;
2645  natural blocked_readers = 0;
2646
2647  LOCK_SPINLOCK(rw->spin,tcr);
2648  if (rw->state > 0) {
2649    if (rw->writer != tcr) {
2650      err = EINVAL;
2651    } else {
2652      --rw->state;
2653      if (rw->state == 0) {
2654        rw->writer = NULL;
2655      }
2656    }
2657  } else {
2658    if (rw->state < 0) {
2659      ++rw->state;
2660    } else {
2661      err = EINVAL;
2662    }
2663  }
2664  if (err) {
2665    RELEASE_SPINLOCK(rw->spin);
2666    return err;
2667  }
2668 
2669  if (rw->state == 0) {
2670    if (rw->blocked_writers) {
2671      SEM_RAISE(rw->writer_signal);
2672    } else {
2673      blocked_readers = rw->blocked_readers;
2674      if (blocked_readers) {
2675        SEM_BROADCAST(rw->reader_signal, blocked_readers);
2676      }
2677    }
2678  }
2679  RELEASE_SPINLOCK(rw->spin);
2680  return 0;
2681}
2682#else
2683int
2684rwlock_unlock(rwlock *rw, TCR *tcr)
2685{
2686
2687  int err = 0;
2688
2689  lock_futex(&rw->spin);
2690  if (rw->state > 0) {
2691    if (rw->writer != tcr) {
2692      err = EINVAL;
2693    } else {
2694      --rw->state;
2695      if (rw->state == 0) {
2696        rw->writer = NULL;
2697      }
2698    }
2699  } else {
2700    if (rw->state < 0) {
2701      ++rw->state;
2702    } else {
2703      err = EINVAL;
2704    }
2705  }
2706  if (err) {
2707    unlock_futex(&rw->spin);
2708    return err;
2709  }
2710 
2711  if (rw->state == 0) {
2712    if (rw->blocked_writers) {
2713      ++rw->writer_signal;
2714      unlock_futex(&rw->spin);
2715      futex_wake(&rw->writer_signal,1);
2716      return 0;
2717    }
2718    if (rw->blocked_readers) {
2719      ++rw->reader_signal;
2720      unlock_futex(&rw->spin);
2721      futex_wake(&rw->reader_signal, INT_MAX);
2722      return 0;
2723    }
2724  }
2725  unlock_futex(&rw->spin);
2726  return 0;
2727}
2728#endif
2729
2730       
2731void
2732rwlock_destroy(rwlock *rw)
2733{
2734#ifndef USE_FUTEX
2735  destroy_semaphore((void **)&rw->reader_signal);
2736  destroy_semaphore((void **)&rw->writer_signal);
2737#endif
2738  postGCfree((void *)(rw->malloced_ptr));
2739}
2740
2741
2742
Note: See TracBrowser for help on using the repository browser.