source: release/1.3/source/lisp-kernel/thread_manager.c @ 11714

Last change on this file since 11714 was 11714, checked in by gb, 11 years ago

Propagate r11710, r11712 to 1.3.

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