source: branches/arm/lisp-kernel/thread_manager.c @ 13923

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

arm-constants.h, thread_manager.c: tcr.last_lisp_frame is just a natural.

arm-exceptions.c: maintain tcr.last_lisp_frame when entering/exiting
signal handlers. Signal thread interrupts by calling back to cmain
with signal 0.

arm-spentry.s: add an entrypoint that calls to undefined functions
wind up at. Dont' really need .SPtfuncallvsp. Check for pending
interrupts on ffcall return. Box the unboxed callback index in
.SPeabi_callback, don't unbox it even more.

arm-uuo.s: closer to lisp's idea of UUO encoding, but still not there.

xfasload.lisp: build the undefined function object differently.

arm-asm.lisp, arm-disassemble.lisp: uuo-slot-unbound encodes 3 registers

arm-lapmacros.lisp: define SET-GLOBAL; needs an extra temp reg.

arm-vinsns.lisp: scale-1bit-misc-index needs another shift. 3-operand
slot-unbound UUO. EEP-unresolved UUO operand order. No more .SPtfuncallvsp.
Make sure that nargs doesn't get clobbered in UNBIND-INTERRUPT-LEVEL-INLINE.

arm-array.lisp: in @string case of %init-misc, shift value, not tag.

arm-misc.lisp: add PENDING-USER-INTERRUPT, %%SAVE-APPLICATION.

arm-callback-support.lisp, arm-error-signal.lisp,
arm-trap-support.lisp,l1-boot-3.lisp: try to get basic stuff working
well enough to enable callbacks. Enable callbacks.

arm-backtrace.lisp: a little bit of platform-specific code and some
code from the PPC port, so that backtrace sort of works.

Status: can save an image (and it's more-or-less worth doing so.)
Crashes (somewhere in the type-system) compiling db-io.lisp, so I
don't yet know what undefined things would be warned about.

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