source: branches/working-0711/ccl/lisp-kernel/thread_manager.c @ 13144

Last change on this file since 13144 was 13144, checked in by gz, 11 years ago

Merge windows-only changes (r13102, r13121)

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