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

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

In count_cpus(), use _SC_NPROCESSORS_CONF . (Power management may
change the number of online CPUs dynamically.)

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