source: branches/qres/ccl/lisp-kernel/thread_manager.c @ 14049

Last change on this file since 14049 was 14049, checked in by gz, 10 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

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