source: trunk/source/lisp-kernel/thread_manager.c @ 11623

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

Write debugging/diagnostic output to the FILE* "dbgout", which is
initialized to stderr.

Add a function that re-opens "dbgout" on a specified fd, add
that function to the imports table. (This is intended to allow I/O
redirection mechanisms - like AltConsole? in the IDE - to persuade
the kernel to do output to a specified FILE*/fd without having
that mechanism capture random diagnostic output to stderr, which
would still go to syslog.)

Lisp code needs to update the import table definitions and the
IDE startup code has to use the new 'open_debug_output()' mechanism.

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