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

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

From trunk: formatting tweaks, non-linux changes, doc and error message fixes

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