source: branches/working-0710/ccl/lisp-kernel/x86-exceptions.c @ 7521

Last change on this file since 7521 was 7521, checked in by gb, 14 years ago

Check to ensure that both rsp and rbp are somewhere in the vstack area
before taking an interrupt.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 77.0 KB
Line 
1/*
2   Copyright (C) 2005 Clozure Associates
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#include "lisp.h"
18#include "lisp-exceptions.h"
19#include "lisp_globals.h"
20#include "Threads.h"
21#include <ctype.h>
22#include <stdio.h>
23#include <stddef.h>
24#include <string.h>
25#include <stdarg.h>
26#include <errno.h>
27#include <stdio.h>
28#ifdef LINUX
29#include <strings.h>
30#include <sys/mman.h>
31#include <fpu_control.h>
32#include <linux/prctl.h>
33#endif
34#ifdef DARWIN
35#include <sysexits.h>
36#endif
37#include <sys/syslog.h>
38
39
40int
41page_size = 4096;
42
43int
44log2_page_size = 12;
45
46
47void
48update_bytes_allocated(TCR* tcr, void *cur_allocptr)
49{
50  BytePtr
51    last = (BytePtr) tcr->last_allocptr, 
52    current = (BytePtr) cur_allocptr;
53  if (last && (tcr->save_allocbase != ((void *)VOID_ALLOCPTR))) {
54    tcr->bytes_allocated += last-current;
55  }
56  tcr->last_allocptr = 0;
57}
58
59
60
61//  This doesn't GC; it returns true if it made enough room, false
62//  otherwise.
63//  If "extend" is true, it can try to extend the dynamic area to
64//  satisfy the request.
65
66
67Boolean
68new_heap_segment(ExceptionInformation *xp, natural need, Boolean extend, TCR *tcr)
69{
70  area *a;
71  natural newlimit, oldlimit;
72  natural log2_allocation_quantum = tcr->log2_allocation_quantum;
73
74  a  = active_dynamic_area;
75  oldlimit = (natural) a->active;
76  newlimit = (align_to_power_of_2(oldlimit, log2_allocation_quantum) +
77              align_to_power_of_2(need, log2_allocation_quantum));
78  if (newlimit > (natural) (a->high)) {
79    if (extend) {
80      signed_natural inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
81      natural extend_by = inhibit ? 0 : lisp_heap_gc_threshold;
82      do {
83        if (resize_dynamic_heap(a->active, (newlimit-oldlimit)+extend_by)) {
84          break;
85        }
86        extend_by = align_to_power_of_2(extend_by>>1,log2_allocation_quantum);
87        if (extend_by < 4<<20) {
88          return false;
89        }
90      } while (1);
91    } else {
92      return false;
93    }
94  }
95  a->active = (BytePtr) newlimit;
96  tcr->last_allocptr = (void *)newlimit;
97  tcr->save_allocptr = (void *)newlimit;
98  xpGPR(xp,Iallocptr) = (LispObj) newlimit;
99  tcr->save_allocbase = (void *) oldlimit;
100
101  return true;
102}
103
104Boolean
105allocate_object(ExceptionInformation *xp,
106                natural bytes_needed, 
107                signed_natural disp_from_allocptr,
108                TCR *tcr)
109{
110  area *a = active_dynamic_area;
111
112  /* Maybe do an EGC */
113  if (a->older && lisp_global(OLDEST_EPHEMERAL)) {
114    if (((a->active)-(a->low)) >= a->threshold) {
115      gc_from_xp(xp, 0L);
116    }
117  }
118
119  /* Life is pretty simple if we can simply grab a segment
120     without extending the heap.
121  */
122  if (new_heap_segment(xp, bytes_needed, false, tcr)) {
123    xpGPR(xp, Iallocptr) -= disp_from_allocptr;
124    tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr));
125    return true;
126  }
127 
128  /* It doesn't make sense to try a full GC if the object
129     we're trying to allocate is larger than everything
130     allocated so far.
131  */
132  if ((lisp_global(HEAP_END)-lisp_global(HEAP_START)) > bytes_needed) {
133    untenure_from_area(tenured_area); /* force a full GC */
134    gc_from_xp(xp, 0L);
135  }
136 
137  /* Try again, growing the heap if necessary */
138  if (new_heap_segment(xp, bytes_needed, true, tcr)) {
139    xpGPR(xp, Iallocptr) -= disp_from_allocptr;
140    tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr));
141    return true;
142  }
143 
144  return false;
145}
146
147natural gc_deferred = 0, full_gc_deferred = 0;
148
149Boolean
150handle_gc_trap(ExceptionInformation *xp, TCR *tcr)
151{
152  LispObj
153    selector = xpGPR(xp,Iimm0), 
154    arg = xpGPR(xp,Iimm1);
155  area *a = active_dynamic_area;
156  Boolean egc_was_enabled = (a->older != NULL);
157  natural gc_previously_deferred = gc_deferred;
158
159  switch (selector) {
160  case GC_TRAP_FUNCTION_EGC_CONTROL:
161    egc_control(arg != 0, a->active);
162    xpGPR(xp,Iarg_z) = lisp_nil + (egc_was_enabled ? t_offset : 0);
163    break;
164
165  case GC_TRAP_FUNCTION_CONFIGURE_EGC:
166    a->threshold = unbox_fixnum(xpGPR(xp, Iarg_x));
167    g1_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_y));
168    g2_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_z));
169    xpGPR(xp,Iarg_z) = lisp_nil+t_offset;
170    break;
171
172  case GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD:
173    if (((signed_natural) arg) > 0) {
174      lisp_heap_gc_threshold = 
175        align_to_power_of_2((arg-1) +
176                            (heap_segment_size - 1),
177                            log2_heap_segment_size);
178    }
179    /* fall through */
180  case GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD:
181    xpGPR(xp, Iimm0) = lisp_heap_gc_threshold;
182    break;
183
184  case GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD:
185    /*  Try to put the current threshold in effect.  This may
186        need to disable/reenable the EGC. */
187    untenure_from_area(tenured_area);
188    resize_dynamic_heap(a->active,lisp_heap_gc_threshold);
189    if (egc_was_enabled) {
190      if ((a->high - a->active) >= a->threshold) {
191        tenure_to_area(tenured_area);
192      }
193    }
194    xpGPR(xp, Iimm0) = lisp_heap_gc_threshold;
195    break;
196
197  default:
198    update_bytes_allocated(tcr, (void *) tcr->save_allocptr);
199
200    if (selector == GC_TRAP_FUNCTION_IMMEDIATE_GC) {
201      if (!full_gc_deferred) {
202        gc_from_xp(xp, 0L);
203        break;
204      }
205      /* Tried to do a full GC when gc was disabled.  That failed,
206         so try full GC now */
207      selector = GC_TRAP_FUNCTION_GC;
208    }
209   
210    if (egc_was_enabled) {
211      egc_control(false, (BytePtr) a->active);
212    }
213    gc_from_xp(xp, 0L);
214    if (gc_deferred > gc_previously_deferred) {
215      full_gc_deferred = 1;
216    } else {
217      full_gc_deferred = 0;
218    }
219    if (selector & GC_TRAP_FUNCTION_PURIFY) {
220      purify_from_xp(xp, 0L);
221      gc_from_xp(xp, 0L);
222    }
223    if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) {
224      OSErr err;
225      extern OSErr save_application(unsigned);
226      area *vsarea = tcr->vs_area;
227       
228      nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1);
229      err = save_application(arg);
230      if (err == noErr) {
231        _exit(0);
232      }
233      fatal_oserr(": save_application", err);
234    }
235    switch (selector) {
236    case GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE:
237      xpGPR(xp, Iimm0) = 0;
238      break;
239    case GC_TRAP_FUNCTION_FREEZE:
240      a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size);
241      tenured_area->static_dnodes = area_dnode(a->active, a->low);
242      xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift;
243      break;
244    default:
245      break;
246    }
247    if (egc_was_enabled) {
248      egc_control(true, NULL);
249    }
250    break;
251  }
252  return true;
253}
254
255 
256
257
258
259void
260push_on_lisp_stack(ExceptionInformation *xp, LispObj value)
261{
262  LispObj *vsp = (LispObj *)xpGPR(xp,Isp);
263  *--vsp = value;
264  xpGPR(xp,Isp) = (LispObj)vsp;
265}
266
267
268/* Hard to know if or whether this is necessary in general.  For now,
269   do it when we get a "wrong number of arguments" trap.
270*/
271void
272finish_function_entry(ExceptionInformation *xp)
273{
274  natural nargs = (xpGPR(xp,Inargs)&0xffff)>> fixnumshift;
275  signed_natural disp = nargs-3;
276  LispObj *vsp =  (LispObj *) xpGPR(xp,Isp), ra = *vsp++;
277   
278 
279  if (disp > 0) {               /* implies that nargs > 3 */
280    vsp[disp] = xpGPR(xp,Irbp);
281    vsp[disp+1] = ra;
282    xpGPR(xp,Irbp) = (LispObj)(vsp+disp);
283    xpGPR(xp,Isp) = (LispObj)vsp;
284    push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
285    push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
286    push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
287  } else {
288    push_on_lisp_stack(xp,ra);
289    push_on_lisp_stack(xp,xpGPR(xp,Irbp));
290    xpGPR(xp,Irbp) = xpGPR(xp,Isp);
291    if (nargs == 3) {
292      push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
293    }
294    if (nargs >= 2) {
295      push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
296    }
297    if (nargs >= 1) {
298      push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
299    }
300  }
301}
302
303Boolean
304object_contains_pc(LispObj container, LispObj addr)
305{
306  if (fulltag_of(container) >= fulltag_misc) {
307    natural elements = header_element_count(header_of(container));
308    if ((addr >= container) &&
309        (addr < ((LispObj)&(deref(container,1+elements))))) {
310      return true;
311    }
312  }
313  return false;
314}
315
316LispObj
317create_exception_callback_frame(ExceptionInformation *xp)
318{
319  LispObj containing_uvector = 0, 
320    relative_pc, 
321    nominal_function = lisp_nil, 
322    f, tra, tra_f = 0, abs_pc;
323
324  f = xpGPR(xp,Ifn);
325  tra = *(LispObj*)(xpGPR(xp,Isp));
326  if (tag_of(tra) == tag_tra) {
327    if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) &&
328        (*((unsigned char *)(tra+2)) == RECOVER_FN_FROM_RIP_BYTE2)) {
329      int sdisp = (*(int *) (tra+3));
330      tra_f = RECOVER_FN_FROM_RIP_LENGTH+tra+sdisp;
331    }
332    if (fulltag_of(tra_f) != fulltag_function) {
333      tra_f = 0;
334    }
335  } else {
336    tra = 0;
337  }
338
339  abs_pc = (LispObj)xpPC(xp);
340
341  if (fulltag_of(f) == fulltag_function) {
342    nominal_function = f;
343  } else {
344    if (tra_f) {
345      nominal_function = tra_f;
346    }
347  }
348 
349  f = xpGPR(xp,Ifn);
350  if (object_contains_pc(f, abs_pc)) {
351    containing_uvector = untag(f)+fulltag_misc;
352  } else {
353    f = xpGPR(xp,Ixfn);
354    if (object_contains_pc(f, abs_pc)) {
355      containing_uvector = untag(f)+fulltag_misc;
356    } else {
357      if (tra_f) {
358        f = tra_f;
359        if (object_contains_pc(f, abs_pc)) {
360          containing_uvector = untag(f)+fulltag_misc;
361          relative_pc = (abs_pc - f) << fixnumshift;
362        }
363      }
364    }
365  }
366  if (containing_uvector) {
367    relative_pc = (abs_pc - (LispObj)&(deref(containing_uvector,1))) << fixnumshift;
368  } else {
369    containing_uvector = lisp_nil;
370    relative_pc = abs_pc << fixnumshift;
371  }
372 
373  push_on_lisp_stack(xp,tra);
374  push_on_lisp_stack(xp,(LispObj)xp);
375  push_on_lisp_stack(xp,containing_uvector); 
376  push_on_lisp_stack(xp,relative_pc);
377  push_on_lisp_stack(xp,nominal_function);
378  push_on_lisp_stack(xp,0);
379  push_on_lisp_stack(xp,xpGPR(xp,Irbp));
380  xpGPR(xp,Irbp) = xpGPR(xp,Isp);
381  return xpGPR(xp,Isp);
382}
383
384#ifndef XMEMFULL
385#define XMEMFULL (76)
386#endif
387
388Boolean
389handle_alloc_trap(ExceptionInformation *xp, TCR *tcr)
390{
391  natural cur_allocptr, bytes_needed;
392  unsigned allocptr_tag;
393  signed_natural disp;
394 
395  cur_allocptr = xpGPR(xp,Iallocptr);
396  allocptr_tag = fulltag_of(cur_allocptr);
397  if (allocptr_tag == fulltag_misc) {
398    disp = xpGPR(xp,Iimm1);
399  } else {
400    disp = dnode_size-fulltag_cons;
401  }
402  bytes_needed = disp+allocptr_tag;
403
404  update_bytes_allocated(tcr,((BytePtr)(cur_allocptr+disp)));
405  if (allocate_object(xp, bytes_needed, disp, tcr)) {
406    return true;
407  }
408 
409  {
410    LispObj xcf = create_exception_callback_frame(xp),
411      cmain = nrs_CMAIN.vcell;
412    int skip;
413   
414    tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR;
415    xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
416
417    skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0);
418    xpPC(xp) += skip;
419  }
420
421  return true;
422}
423
424extern unsigned get_mxcsr();
425extern void set_mxcsr(unsigned);
426 
427int
428callback_to_lisp (TCR * tcr, LispObj callback_macptr, ExceptionInformation *xp,
429                  natural arg1, natural arg2, natural arg3, natural arg4, natural arg5)
430{
431  sigset_t mask;
432  natural  callback_ptr, i;
433  int delta;
434  unsigned old_mxcsr = get_mxcsr();
435
436  set_mxcsr(0x1f80);
437
438  /* Put the active stack pointers where .SPcallback expects them */
439  tcr->save_vsp = (LispObj *) xpGPR(xp, Isp);
440  tcr->save_rbp = (LispObj *) xpGPR(xp, Irbp);
441
442
443  /* Call back.  The caller of this function may have modified stack/frame
444     pointers (and at least should have called prepare_for_callback()).
445  */
446  callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
447  UNLOCK(lisp_global(EXCEPTION_LOCK), tcr);
448  delta = ((int (*)())callback_ptr) (xp, arg1, arg2, arg3, arg4, arg5);
449  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
450  set_mxcsr(old_mxcsr);
451  return delta;
452}
453
454void
455callback_for_interrupt(TCR *tcr, ExceptionInformation *xp)
456{
457  LispObj save_rbp = xpGPR(xp,Irbp),
458    *save_vsp = (LispObj *)xpGPR(xp,Isp),
459    word_beyond_vsp = save_vsp[-1],
460    xcf = create_exception_callback_frame(xp);
461  int save_errno = errno;
462 
463  callback_to_lisp(tcr, nrs_CMAIN.vcell,xp, xcf, 0, 0, 0, 0);
464  xpGPR(xp,Irbp) = save_rbp;
465  xpGPR(xp,Isp) = (LispObj)save_vsp;
466  save_vsp[-1] = word_beyond_vsp;
467  errno = save_errno;
468}
469
470Boolean
471handle_error(TCR *tcr, ExceptionInformation *xp)
472{
473  pc program_counter = (pc)xpPC(xp);
474  unsigned char op0 = program_counter[0], op1 = program_counter[1];
475  LispObj rpc = (LispObj) program_counter, errdisp = nrs_ERRDISP.vcell,
476    save_rbp = xpGPR(xp,Irbp), save_vsp = xpGPR(xp,Isp), xcf;
477  int skip;
478
479  if ((fulltag_of(errdisp) == fulltag_misc) &&
480      (header_subtag(header_of(errdisp)) == subtag_macptr)) {
481
482    if ((op0 == 0xcd) && (op1 >= 0xc0) && (op1 <= 0xc2)) {
483      finish_function_entry(xp);
484    }
485    xcf = create_exception_callback_frame(xp);
486    skip = callback_to_lisp(tcr, errdisp, xp, xcf, 0, 0, 0, 0);
487    xpGPR(xp,Irbp) = save_rbp;
488    xpGPR(xp,Isp) = save_vsp;
489    if ((op0 == 0xcd) && (op1 == 0xc7)) {
490      /* Continue after an undefined function call. The function
491         that had been undefined has already been called (in the
492         break loop), and a list of the values that it returned
493         in in the xp's %arg_z.  A function that returns those
494         values in in the xp's %fn; we just have to adjust the
495         stack (keeping the return address in the right place
496         and discarding any stack args/reserved stack frame),
497         then set nargs and the PC so that that function's
498         called when we resume.
499      */
500      LispObj *vsp =(LispObj *)save_vsp, ra = *vsp;
501      int nargs = (xpGPR(xp, Inargs) & 0xffff)>>fixnumshift;
502     
503      if (nargs > 3) {
504        xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3)));
505        push_on_lisp_stack(xp,ra);
506      }
507      xpPC(xp) = xpGPR(xp,Ifn);
508      xpGPR(xp,Inargs) = 1<<fixnumshift;
509    } else {
510      xpPC(xp) += skip;
511    }
512    return true;
513  } else {
514    return false;
515  }
516}
517
518
519protection_handler
520* protection_handlers[] = {
521  do_spurious_wp_fault,
522  do_soft_stack_overflow,
523  do_soft_stack_overflow,
524  do_soft_stack_overflow,
525  do_hard_stack_overflow,   
526  do_hard_stack_overflow,
527  do_hard_stack_overflow,
528};
529
530
531/* Maybe this'll work someday.  We may have to do something to
532   make the thread look like it's not handling an exception */
533void
534reset_lisp_process(ExceptionInformation *xp)
535{
536}
537
538Boolean
539do_hard_stack_overflow(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr)
540{
541  reset_lisp_process(xp);
542  return false;
543}
544
545
546Boolean
547do_spurious_wp_fault(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr)
548{
549
550  return false;
551}
552
553Boolean
554do_soft_stack_overflow(ExceptionInformation *xp, protected_area_ptr prot_area, BytePtr addr)
555{
556  /* Trying to write into a guard page on the vstack or tstack.
557     Allocate a new stack segment, emulate stwu and stwux for the TSP, and
558     signal an error_stack_overflow condition.
559      */
560  lisp_protection_kind which = prot_area->why;
561  Boolean on_TSP = (which == kTSPsoftguard);
562  LispObj save_rbp = xpGPR(xp,Irbp), 
563    save_vsp = xpGPR(xp,Isp), 
564    xcf,
565    cmain = nrs_CMAIN.vcell;
566  area *a;
567  protected_area_ptr soft;
568  TCR *tcr = get_tcr(false);
569  int skip;
570
571  if ((fulltag_of(cmain) == fulltag_misc) &&
572      (header_subtag(header_of(cmain)) == subtag_macptr)) {
573    if (on_TSP) {
574      a = tcr->ts_area;
575    } else {
576      a = tcr->vs_area;
577    }
578    soft = a->softprot;
579    unprotect_area(soft);
580    xcf = create_exception_callback_frame(xp);
581    skip = callback_to_lisp(tcr, nrs_CMAIN.vcell, xp, xcf, SIGSEGV, on_TSP, 0, 0);
582    xpGPR(xp,Irbp) = save_rbp;
583    xpGPR(xp,Isp) = save_vsp;
584    xpPC(xp) += skip;
585    return true;
586  }
587  return false;
588}
589
590Boolean
591is_write_fault(ExceptionInformation *xp, siginfo_t *info)
592{
593#ifdef DARWIN
594  return (UC_MCONTEXT(xp)->__es.__err & 0x2) != 0;
595#endif
596#ifdef LINUX
597  return (xpGPR(xp,REG_ERR) & 0x2) != 0;
598#endif
599#ifdef FREEBSD
600  return (xp->uc_mcontext.mc_err & 0x2) != 0;
601#endif
602}
603
604Boolean
605handle_fault(TCR *tcr, ExceptionInformation *xp, siginfo_t *info, int old_valence)
606{
607#ifdef FREEBSD
608  BytePtr addr = (BytePtr) xp->uc_mcontext.mc_addr;
609#else
610  BytePtr addr = (BytePtr) info->si_addr;
611#endif
612
613  if (addr && (addr == tcr->safe_ref_address)) {
614    xpGPR(xp,Iimm0) = 0;
615    xpPC(xp) = xpGPR(xp,Ira0);
616    return true;
617  } else {
618    protected_area *a = find_protected_area(addr);
619    protection_handler *handler;
620
621    if (a) {
622      handler = protection_handlers[a->why];
623      return handler(xp, a, addr);
624    }
625  }
626  if (old_valence == TCR_STATE_LISP) {
627    LispObj cmain = nrs_CMAIN.vcell,
628      xcf;
629    if ((fulltag_of(cmain) == fulltag_misc) &&
630      (header_subtag(header_of(cmain)) == subtag_macptr)) {
631      xcf = create_exception_callback_frame(xp);
632      callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, is_write_fault(xp,info), (natural)addr, 0);
633    }
634  }
635  return false;
636}
637
638Boolean
639handle_floating_point_exception(TCR *tcr, ExceptionInformation *xp, siginfo_t *info)
640{
641  int code = info->si_code, rfn = 0, skip;
642  pc program_counter = (pc)xpPC(xp);
643  LispObj rpc = (LispObj) program_counter, xcf, cmain = nrs_CMAIN.vcell,
644
645    save_rbp = xpGPR(xp,Irbp), save_vsp = xpGPR(xp,Isp);
646
647  if ((fulltag_of(cmain) == fulltag_misc) &&
648      (header_subtag(header_of(cmain)) == subtag_macptr)) {
649    xcf = create_exception_callback_frame(xp);
650    skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0);
651    xpPC(xp) += skip;
652    xpGPR(xp,Irbp) = save_rbp;
653    xpGPR(xp,Isp) = save_vsp;
654    return true;
655  } else {
656    return false;
657  }
658}
659
660Boolean
661extend_tcr_tlb(TCR *tcr, ExceptionInformation *xp)
662{
663  LispObj index, old_limit = tcr->tlb_limit, new_limit, new_bytes;
664  LispObj *old_tlb = tcr->tlb_pointer, *new_tlb, *work, *tos;
665
666  tos = (LispObj*)(xpGPR(xp,Isp));
667  index = *tos++;
668  (xpGPR(xp,Isp))=(LispObj)tos;
669 
670  new_limit = align_to_power_of_2(index+1,12);
671  new_bytes = new_limit-old_limit;
672  new_tlb = realloc(old_tlb, new_limit);
673
674  if (new_tlb == NULL) {
675    return false;
676  }
677  work = (LispObj *) ((BytePtr)new_tlb+old_limit);
678
679  while (new_bytes) {
680    *work++ = no_thread_local_binding_marker;
681    new_bytes -= sizeof(LispObj);
682  }
683  tcr->tlb_pointer = new_tlb;
684  tcr->tlb_limit = new_limit;
685  return true;
686}
687
688
689#if defined(FREEBSD) || defined(DARWIN)
690static
691char mxcsr_bit_to_fpe_code[] = {
692  FPE_FLTINV,                   /* ie */
693  0,                            /* de */
694  FPE_FLTDIV,                   /* ze */
695  FPE_FLTOVF,                   /* oe */
696  FPE_FLTUND,                   /* ue */
697  FPE_FLTRES                    /* pe */
698};
699
700void
701decode_vector_fp_exception(siginfo_t *info, uint32_t mxcsr)
702{
703  /* If the exception appears to be an XMM FP exception, try to
704     determine what it was by looking at bits in the mxcsr.
705  */
706  int xbit, maskbit;
707 
708  for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
709    if ((mxcsr & (1 << xbit)) &&
710        !(mxcsr & (1 << maskbit))) {
711      info->si_code = mxcsr_bit_to_fpe_code[xbit];
712      return;
713    }
714  }
715}
716
717#ifdef FREEBSD
718void
719freebsd_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp)
720{
721  if (info->si_code == 0) {
722    struct savefpu *fpu = (struct savefpu *) &(xp->uc_mcontext.mc_fpstate);
723    uint32_t mxcsr = fpu->sv_env.en_mxcsr;
724
725    decode_vector_fp_exception(info, mxcsr);
726  }
727}
728#endif
729
730#ifdef DARWIN
731void
732darwin_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp)
733{
734  if (info->si_code == EXC_I386_SSEEXTERR) {
735    uint32_t mxcsr = UC_MCONTEXT(xp)->__fs.__fpu_mxcsr;
736
737    decode_vector_fp_exception(info, mxcsr);
738  }
739}
740
741#endif
742
743#endif
744
745void
746get_lisp_string(LispObj lisp_string, char *c_string, natural max)
747{
748  lisp_char_code *src = (lisp_char_code *)  (ptr_from_lispobj(lisp_string + misc_data_offset));
749  natural i, n = header_element_count(header_of(lisp_string));
750
751  if (n > max) {
752    n = max;
753  }
754
755  for (i = 0; i < n; i++) {
756    c_string[i] = 0xff & (src[i]);
757  }
758  c_string[n] = 0;
759}
760
761Boolean
762handle_exception(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
763{
764  pc program_counter = (pc)xpPC(context);
765
766  switch (signum) {
767  case SIGNUM_FOR_INTN_TRAP:
768    if (IS_MAYBE_INT_TRAP(info,context)) {
769      /* Something mapped to SIGSEGV/SIGBUS that has nothing to do with
770         a memory fault.  On x86, an "int n" instruction that's
771         not otherwise implemented causes a "protecton fault".  Of
772         course that has nothing to do with accessing protected
773         memory; of course, most Unices act as if it did.*/
774      if (*program_counter == INTN_OPCODE) {
775        program_counter++;
776        switch (*program_counter) {
777        case UUO_ALLOC_TRAP:
778          if (handle_alloc_trap(context, tcr)) {
779            xpPC(context) += 2; /* we might have GCed. */
780            return true;
781          }
782          break;
783        case UUO_GC_TRAP:
784          if (handle_gc_trap(context, tcr)) {
785            xpPC(context) += 2;
786            return true;
787          }
788          break;
789         
790        case UUO_DEBUG_TRAP:
791          xpPC(context) = (natural) (program_counter+1);
792          lisp_Debugger(context, info, debug_entry_dbg, "Lisp Breakpoint");
793          return true;
794
795        case UUO_DEBUG_TRAP_WITH_STRING:
796          xpPC(context) = (natural) (program_counter+1);
797          {
798            char msg[512];
799
800            get_lisp_string(xpGPR(context,Iarg_z),msg, sizeof(msg)-1);
801            lisp_Debugger(context, info, debug_entry_dbg, msg);
802          }
803          return true;
804         
805        default:
806          return handle_error(tcr, context);
807        }
808      } else {
809        return false;
810      }
811
812    } else {
813      return handle_fault(tcr, context, info, old_valence);
814    }
815    break;
816
817  case SIGNAL_FOR_PROCESS_INTERRUPT:
818    tcr->interrupt_pending = 0;
819    callback_for_interrupt(tcr, context);
820    return true;
821    break;
822
823
824  case SIGILL:
825    if ((program_counter[0] == XUUO_OPCODE_0) &&
826        (program_counter[1] == XUUO_OPCODE_1)) {
827      switch (program_counter[2]) {
828      case XUUO_TLB_TOO_SMALL:
829        if (extend_tcr_tlb(tcr,context)) {
830          xpPC(context)+=3;
831          return true;
832        }
833        break;
834       
835      case XUUO_INTERRUPT_NOW:
836        callback_for_interrupt(tcr,context);
837        xpPC(context)+=3;
838        return true;
839       
840      default:
841        return false;
842      }
843    } else {
844      return false;
845    }
846    break;
847   
848  case SIGFPE:
849#ifdef FREEBSD
850    /* As of 6.1, FreeBSD/AMD64 doesn't seem real comfortable
851       with this newfangled XMM business (and therefore info->si_code
852       is often 0 on an XMM FP exception.
853       Try to figure out what really happened by decoding mxcsr
854       bits.
855    */
856    freebsd_decode_vector_fp_exception(info,context);
857#endif
858#ifdef DARWIN
859    /* Same general problem with Darwin as of 8.7.2 */
860    darwin_decode_vector_fp_exception(info,context);
861#endif
862
863    return handle_floating_point_exception(tcr, context, info);
864
865#if SIGBUS != SIGNUM_FOR_INTN_TRAP
866  case SIGBUS:
867    return handle_fault(tcr, context, info, old_valence);
868#endif
869   
870#if SIGSEGV != SIGNUM_FOR_INTN_TRAP
871  case SIGSEGV:
872    return handle_fault(tcr, context, info, old_valence);
873#endif   
874   
875  default:
876    return false;
877  }
878}
879
880
881/*
882   Current thread has all signals masked.  Before unmasking them,
883   make it appear that the current thread has been suspended.
884   (This is to handle the case where another thread is trying
885   to GC before this thread is able to seize the exception lock.)
886*/
887int
888prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context)
889{
890  int old_valence = tcr->valence;
891
892  tcr->pending_exception_context = context;
893  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
894
895  ALLOW_EXCEPTIONS(context);
896  return old_valence;
897} 
898
899void
900wait_for_exception_lock_in_handler(TCR *tcr, 
901                                   ExceptionInformation *context,
902                                   xframe_list *xf)
903{
904
905  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
906#if 0
907  fprintf(stderr, "0x%x has exception lock\n", tcr);
908#endif
909  xf->curr = context;
910  xf->prev = tcr->xframe;
911  tcr->xframe =  xf;
912  tcr->pending_exception_context = NULL;
913  tcr->valence = TCR_STATE_FOREIGN; 
914}
915
916void
917unlock_exception_lock_in_handler(TCR *tcr)
918{
919  tcr->pending_exception_context = tcr->xframe->curr;
920  tcr->xframe = tcr->xframe->prev;
921  tcr->valence = TCR_STATE_EXCEPTION_RETURN;
922  UNLOCK(lisp_global(EXCEPTION_LOCK),tcr);
923#if 0
924  fprintf(stderr, "0x%x released exception lock\n", tcr);
925#endif
926}
927
928/*
929   If an interrupt is pending on exception exit, try to ensure
930   that the thread sees it as soon as it's able to run.
931*/
932void
933raise_pending_interrupt(TCR *tcr)
934{
935  if ((TCR_INTERRUPT_LEVEL(tcr) >= 0) &&
936      (tcr->interrupt_pending)) {
937    pthread_kill((pthread_t)(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT);
938  }
939}
940
941void
942exit_signal_handler(TCR *tcr, int old_valence)
943{
944  sigset_t mask;
945  sigfillset(&mask);
946 
947  pthread_sigmask(SIG_SETMASK,&mask, NULL);
948  tcr->valence = old_valence;
949  tcr->pending_exception_context = NULL;
950}
951
952void
953signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
954{
955#ifdef DARWIN_GS_HACK
956  Boolean gs_was_tcr = ensure_gs_pthread();
957#endif
958  xframe_list xframe_link;
959#ifndef DARWIN
960  tcr = get_tcr(false);
961
962  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
963#endif
964  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
965    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
966    pthread_kill(pthread_self(), thread_suspend_signal);
967  }
968  wait_for_exception_lock_in_handler(tcr,context, &xframe_link);
969
970
971  if (! handle_exception(signum, info, context, tcr, old_valence)) {
972    char msg[512];
973    int foreign = (old_valence == TCR_STATE_LISP) ? 0 : debug_foreign_exception;
974
975    snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x%lx, context->regs at #x%lx", signum, xpPC(context), (natural)xpGPRvector(context));
976   
977    if (lisp_Debugger(context, info, signum | foreign, msg)) {
978      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
979    }
980  }
981  unlock_exception_lock_in_handler(tcr);
982#ifndef DARWIN_USE_PSEUDO_SIGRETURN
983  exit_signal_handler(tcr, old_valence);
984#endif
985  /* raise_pending_interrupt(tcr); */
986#ifdef DARWIN_GS_HACK
987  if (gs_was_tcr) {
988    set_gs_address(tcr);
989  }
990#endif
991#ifndef DARWIN_USE_PSEUDO_SIGRETURN
992  SIGRETURN(context);
993#endif
994}
995
996#ifdef DARWIN
997void
998pseudo_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
999{
1000  sigset_t mask;
1001
1002  sigfillset(&mask);
1003
1004  pthread_sigmask(SIG_SETMASK,&mask,&(context->uc_sigmask));
1005  signal_handler(signum, info, context, tcr, old_valence);
1006}
1007#endif
1008
1009
1010
1011#ifdef LINUX
1012LispObj *
1013copy_fpregs(ExceptionInformation *xp, LispObj *current, fpregset_t *destptr)
1014{
1015  fpregset_t src = xp->uc_mcontext.fpregs, dest;
1016 
1017  if (src) {
1018    dest = ((fpregset_t)current)-1;
1019    *dest = *src;
1020    *destptr = dest;
1021    current = (LispObj *) dest;
1022  }
1023  return current;
1024}
1025#endif
1026
1027#ifdef DARWIN
1028LispObj *
1029copy_darwin_mcontext(MCONTEXT_T context, 
1030                     LispObj *current, 
1031                     MCONTEXT_T *out)
1032{
1033  MCONTEXT_T dest = ((MCONTEXT_T)current)-1;
1034  dest = (MCONTEXT_T) (((LispObj)dest) & ~15);
1035
1036  *dest = *context;
1037  *out = dest;
1038  return (LispObj *)dest;
1039}
1040#endif
1041
1042LispObj *
1043copy_siginfo(siginfo_t *info, LispObj *current)
1044{
1045  siginfo_t *dest = ((siginfo_t *)current) - 1;
1046  dest = (siginfo_t *) (((LispObj)dest)&~15);
1047  *dest = *info;
1048  return (LispObj *)dest;
1049}
1050
1051#ifdef LINUX
1052typedef fpregset_t copy_ucontext_last_arg_t;
1053#else
1054typedef void * copy_ucontext_last_arg_t;
1055#endif
1056
1057LispObj *
1058copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1059{
1060  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1061  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1062
1063  *dest = *context;
1064  /* Fix it up a little; where's the signal mask allocated, if indeed
1065     it is "allocated" ? */
1066#ifdef LINUX
1067  dest->uc_mcontext.fpregs = fp;
1068#endif
1069  dest->uc_stack.ss_sp = 0;
1070  dest->uc_stack.ss_size = 0;
1071  dest->uc_stack.ss_flags = 0;
1072  dest->uc_link = NULL;
1073  return (LispObj *)dest;
1074}
1075
1076LispObj *
1077find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1078{
1079
1080  if (((BytePtr)rsp < foreign_area->low) ||
1081      ((BytePtr)rsp > foreign_area->high)) {
1082    rsp = (LispObj)(tcr->foreign_sp);
1083  }
1084  return (LispObj *) ((rsp-128 & ~15));
1085}
1086
1087
1088#ifdef DARWIN
1089void
1090bogus_signal_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1091{
1092  if (signum == SIGSYS) {
1093    return;                     /* Leopard lossage */
1094  }
1095}
1096#endif
1097
1098void
1099handle_signal_on_foreign_stack(TCR *tcr,
1100                               void *handler, 
1101                               int signum, 
1102                               siginfo_t *info, 
1103                               ExceptionInformation *context,
1104                               LispObj return_address
1105#ifdef DARWIN_GS_HACK
1106                               , Boolean gs_was_tcr
1107#endif
1108                               )
1109{
1110#ifdef LINUX
1111  fpregset_t fpregs = NULL;
1112#else
1113  void *fpregs = NULL;
1114#endif
1115#ifdef DARWIN
1116  MCONTEXT_T mcontextp = NULL;
1117#endif
1118  siginfo_t *info_copy = NULL;
1119  ExceptionInformation *xp = NULL;
1120  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1121
1122#ifdef LINUX
1123  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1124#endif
1125#ifdef DARWIN
1126  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1127#endif
1128  foreign_rsp = copy_siginfo(info, foreign_rsp);
1129  info_copy = (siginfo_t *)foreign_rsp;
1130  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1131  xp = (ExceptionInformation *)foreign_rsp;
1132#ifdef DARWIN
1133  UC_MCONTEXT(xp) = mcontextp;
1134#endif
1135  *--foreign_rsp = return_address;
1136#ifdef DARWIN_GS_HACK
1137  if (gs_was_tcr) {
1138    set_gs_address(tcr);
1139  }
1140#endif
1141  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1142}
1143
1144
1145#ifndef USE_SIGALTSTACK
1146void
1147arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1148{
1149  TCR *tcr = get_interrupt_tcr(false);
1150#if 1
1151  if (tcr->valence != TCR_STATE_LISP) {
1152    FBug(context, "exception in foreign context");
1153  }
1154#endif
1155  {
1156    area *vs = tcr->vs_area;
1157    BytePtr current_sp = (BytePtr) current_stack_pointer();
1158
1159
1160    if ((current_sp >= vs->low) &&
1161        (current_sp < vs->high)) {
1162      handle_signal_on_foreign_stack(tcr,
1163                                     signal_handler,
1164                                     signum,
1165                                     info,
1166                                     context,
1167                                     (LispObj)__builtin_return_address(0)
1168#ifdef DARWIN_GS_HACK
1169                                     , false
1170#endif
1171
1172                                     );
1173    } else {
1174      signal_handler(signum, info, context, tcr, 0);
1175    }
1176  }
1177}
1178
1179#else
1180void
1181altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1182{
1183  TCR* tcr = get_tcr(true);
1184#if 1
1185  if (tcr->valence != TCR_STATE_LISP) {
1186    FBug(context, "exception in foreign context");
1187  }
1188#endif
1189  handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1190#ifdef DARWIN_GS_HACK
1191                                 , false
1192#endif
1193);
1194}
1195#endif
1196
1197Boolean
1198stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr)
1199{
1200  area *a = tcr->vs_area;
1201 
1202  return (((BytePtr)stack_pointer <= a->high) &&
1203          ((BytePtr)stack_pointer > a->low));
1204}
1205
1206void
1207interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1208{
1209#ifdef DARWIN_GS_HACK
1210  Boolean gs_was_tcr = ensure_gs_pthread();
1211#endif
1212  TCR *tcr = get_interrupt_tcr(false);
1213  if (tcr) {
1214    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1215        (tcr->valence != TCR_STATE_LISP) ||
1216        (tcr->unwinding != 0) ||
1217        ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) ||
1218        ! stack_pointer_on_vstack_p(xpGPR(context,Irbp), tcr)) {
1219      tcr->interrupt_pending = (1L << (nbits_in_word - 1L));
1220    } else {
1221      LispObj cmain = nrs_CMAIN.vcell;
1222
1223      if ((fulltag_of(cmain) == fulltag_misc) &&
1224          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1225        /*
1226           This thread can (allegedly) take an interrupt now.
1227        */
1228
1229        xframe_list xframe_link;
1230        int old_valence;
1231        signed_natural alloc_displacement = 0;
1232        LispObj
1233          *next_tsp = tcr->next_tsp,
1234          *save_tsp = tcr->save_tsp,
1235          *p,
1236          q;
1237        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1238
1239        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1240           
1241        if (next_tsp != save_tsp) {
1242          tcr->next_tsp = save_tsp;
1243        } else {
1244          next_tsp = NULL;
1245        }
1246        /* have to do this before allowing interrupts */
1247        pc_luser_xp(context, tcr, &alloc_displacement);
1248        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1249        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1250        handle_exception(signum, info, context, tcr, old_valence);
1251        if (alloc_displacement) {
1252          tcr->save_allocptr -= alloc_displacement;
1253        }
1254        if (next_tsp) {
1255          tcr->next_tsp = next_tsp;
1256          p = next_tsp;
1257          while (p != save_tsp) {
1258            *p++ = 0;
1259          }
1260          q = (LispObj)save_tsp;
1261          *next_tsp = q;
1262        }
1263        tcr->flags |= old_foreign_exception;
1264        unlock_exception_lock_in_handler(tcr);
1265        exit_signal_handler(tcr, old_valence);
1266      }
1267    }
1268  }
1269#ifdef DARWIN_GS_HACK
1270  if (gs_was_tcr) {
1271    set_gs_address(tcr);
1272  }
1273#endif
1274  SIGRETURN(context);
1275}
1276
1277#ifndef USE_SIGALTSTACK
1278void
1279arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1280{
1281#ifdef DARWIN_GS_HACK
1282  Boolean gs_was_tcr = ensure_gs_pthread();
1283#endif
1284  TCR *tcr = get_interrupt_tcr(false);
1285  area *vs = tcr->vs_area;
1286  BytePtr current_sp = (BytePtr) current_stack_pointer();
1287
1288  if ((current_sp >= vs->low) &&
1289      (current_sp < vs->high)) {
1290    handle_signal_on_foreign_stack(tcr,
1291                                   interrupt_handler,
1292                                   signum,
1293                                   info,
1294                                   context,
1295                                   (LispObj)__builtin_return_address(0)
1296#ifdef DARWIN_GS_HACK
1297                                   ,gs_was_tcr
1298#endif
1299                                   );
1300  } else {
1301    /* If we're not on the value stack, we pretty much have to be on
1302       the C stack.  Just run the handler. */
1303#ifdef DARWIN_GS_HACK
1304    if (gs_was_tcr) {
1305      set_gs_address(tcr);
1306    }
1307#endif
1308    interrupt_handler(signum, info, context);
1309  }
1310}
1311
1312#else /* altstack works */
1313 
1314void
1315altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1316{
1317#ifdef DARWIN_GS_HACK
1318  Boolean gs_was_tcr = ensure_gs_pthread();
1319#endif
1320  TCR *tcr = get_interrupt_tcr(false);
1321  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1322#ifdef DARWIN_GS_HACK
1323                                 ,gs_was_tcr
1324#endif
1325                                 );
1326}
1327
1328#endif
1329
1330
1331void
1332install_signal_handler(int signo, void * handler)
1333{
1334  struct sigaction sa;
1335 
1336  sa.sa_sigaction = (void *)handler;
1337  sigfillset(&sa.sa_mask);
1338#ifdef FREEBSD
1339  /* Strange FreeBSD behavior wrt synchronous signals */
1340  sigdelset(&sa.sa_mask,SIGNUM_FOR_INTN_TRAP);
1341  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1342  sigdelset(&sa.sa_mask,SIGILL);
1343  sigdelset(&sa.sa_mask,SIGFPE);
1344  sigdelset(&sa.sa_mask,SIGSEGV);
1345#endif
1346  sa.sa_flags = 
1347    SA_RESTART
1348#ifdef USE_SIGALTSTACK
1349    | SA_ONSTACK
1350#endif
1351    | SA_SIGINFO;
1352
1353  sigaction(signo, &sa, NULL);
1354}
1355
1356
1357void
1358install_pmcl_exception_handlers()
1359{
1360#ifndef DARWIN 
1361  void *handler = (void *)
1362#ifdef USE_SIGALTSTACK
1363    altstack_signal_handler
1364#else
1365    arbstack_signal_handler;
1366#endif
1367  ;
1368  install_signal_handler(SIGILL, handler);
1369 
1370  install_signal_handler(SIGBUS, handler);
1371  install_signal_handler(SIGSEGV,handler);
1372  install_signal_handler(SIGFPE, handler);
1373#else
1374  install_signal_handler(SIGTRAP,bogus_signal_handler);
1375  install_signal_handler(SIGILL, bogus_signal_handler);
1376 
1377  install_signal_handler(SIGBUS, bogus_signal_handler);
1378  install_signal_handler(SIGSEGV,bogus_signal_handler);
1379  install_signal_handler(SIGFPE, bogus_signal_handler);
1380  /*  9.0.0d8 generates spurious SIGSYS from mach_msg_trap */
1381  install_signal_handler(SIGSYS, bogus_signal_handler);
1382#endif
1383 
1384  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT,
1385#ifdef USE_SIGALTSTACK
1386                         altstack_interrupt_handler
1387#else
1388                         arbstack_interrupt_handler
1389#endif
1390);
1391  signal(SIGPIPE, SIG_IGN);
1392}
1393
1394#ifndef USE_SIGALTSTACK
1395void
1396arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1397{
1398#ifdef DARWIN_GS_HACK
1399  Boolean gs_was_tcr = ensure_gs_pthread();
1400#endif
1401  TCR *tcr = get_interrupt_tcr(false);
1402  area *vs = tcr->vs_area;
1403  BytePtr current_sp = (BytePtr) current_stack_pointer();
1404
1405  if ((current_sp >= vs->low) &&
1406      (current_sp < vs->high)) {
1407    handle_signal_on_foreign_stack(tcr,
1408                                   suspend_resume_handler,
1409                                   signum,
1410                                   info,
1411                                   context,
1412                                   (LispObj)__builtin_return_address(0)
1413#ifdef DARWIN_GS_HACK
1414                                   ,gs_was_tcr
1415#endif
1416                                   );
1417  } else {
1418    /* If we're not on the value stack, we pretty much have to be on
1419       the C stack.  Just run the handler. */
1420#ifdef DARWIN_GS_HACK
1421    if (gs_was_tcr) {
1422      set_gs_address(tcr);
1423    }
1424#endif
1425    suspend_resume_handler(signum, info, context);
1426  }
1427}
1428
1429
1430#else /* altstack works */
1431void
1432altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1433{
1434#ifdef DARWIN_GS_HACK
1435  Boolean gs_was_tcr = ensure_gs_pthread();
1436#endif
1437  TCR* tcr = get_tcr(true);
1438  handle_signal_on_foreign_stack(tcr,
1439                                 suspend_resume_handler,
1440                                 signum,
1441                                 info,
1442                                 context,
1443                                 (LispObj)__builtin_return_address(0)
1444#ifdef DARWIN_GS_HACK
1445                                 ,gs_was_tcr
1446#endif
1447                                 );
1448}
1449
1450#endif
1451
1452void
1453quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1454{
1455  TCR *tcr = get_tcr(false);
1456  area *a;
1457  sigset_t mask;
1458 
1459  sigemptyset(&mask);
1460
1461
1462  if (tcr) {
1463    tcr->valence = TCR_STATE_FOREIGN;
1464    a = tcr->vs_area;
1465    if (a) {
1466      a->active = a->high;
1467    }
1468    a = tcr->ts_area;
1469    if (a) {
1470      a->active = a->high;
1471    }
1472    a = tcr->cs_area;
1473    if (a) {
1474      a->active = a->high;
1475    }
1476  }
1477 
1478  pthread_sigmask(SIG_SETMASK,&mask,NULL);
1479  pthread_exit(NULL);
1480}
1481
1482#ifndef USE_SIGALTSTACK
1483arbstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1484{
1485#ifdef DARWIN_GS_HACK
1486  Boolean gs_was_tcr = ensure_gs_pthread();
1487#endif
1488  TCR *tcr = get_interrupt_tcr(false);
1489  area *vs = tcr->vs_area;
1490  BytePtr current_sp = (BytePtr) current_stack_pointer();
1491
1492  if ((current_sp >= vs->low) &&
1493      (current_sp < vs->high)) {
1494    handle_signal_on_foreign_stack(tcr,
1495                                   quit_handler,
1496                                   signum,
1497                                   info,
1498                                   context,
1499                                   (LispObj)__builtin_return_address(0)
1500#ifdef DARWIN_GS_HACK
1501                                   ,gs_was_tcr
1502#endif
1503                                   );
1504  } else {
1505    /* If we're not on the value stack, we pretty much have to be on
1506       the C stack.  Just run the handler. */
1507#ifdef DARWIN_GS_HACK
1508    if (gs_was_tcr) {
1509      set_gs_address(tcr);
1510    }
1511#endif
1512    quit_handler(signum, info, context);
1513  }
1514}
1515
1516
1517#else
1518void
1519altstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1520{
1521#ifdef DARWIN_GS_HACK
1522  Boolean gs_was_tcr = ensure_gs_pthread();
1523#endif
1524  TCR* tcr = get_tcr(true);
1525  handle_signal_on_foreign_stack(tcr,
1526                                 quit_handler,
1527                                 signum,
1528                                 info,
1529                                 context,
1530                                 (LispObj)__builtin_return_address(0)
1531#ifdef DARWIN_GS_HACK
1532                                 ,gs_was_tcr
1533#endif
1534                                 );
1535}
1536#endif
1537
1538#ifdef USE_SIGALTSTACK
1539#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
1540#define QUIT_HANDLER altstack_quit_handler
1541#else
1542#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
1543#define QUIT_HANDLER arbstack_quit_handler
1544#endif
1545
1546void
1547thread_signal_setup()
1548{
1549  thread_suspend_signal = SIG_SUSPEND_THREAD;
1550  thread_resume_signal = SIG_RESUME_THREAD;
1551
1552  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
1553  install_signal_handler(thread_resume_signal, (void *)SUSPEND_RESUME_HANDLER);
1554  install_signal_handler(SIGQUIT, (void *)QUIT_HANDLER);
1555}
1556
1557
1558void
1559enable_fp_exceptions()
1560{
1561}
1562
1563void
1564exception_init()
1565{
1566  install_pmcl_exception_handlers();
1567}
1568
1569void
1570adjust_exception_pc(ExceptionInformation *xp, int delta)
1571{
1572  xpPC(xp) += delta;
1573}
1574
1575/*
1576  Lower (move toward 0) the "end" of the soft protected area associated
1577  with a by a page, if we can.
1578*/
1579
1580void
1581
1582adjust_soft_protection_limit(area *a)
1583{
1584  char *proposed_new_soft_limit = a->softlimit - 4096;
1585  protected_area_ptr p = a->softprot;
1586 
1587  if (proposed_new_soft_limit >= (p->start+16384)) {
1588    p->end = proposed_new_soft_limit;
1589    p->protsize = p->end-p->start;
1590    a->softlimit = proposed_new_soft_limit;
1591  }
1592  protect_area(p);
1593}
1594
1595void
1596restore_soft_stack_limit(unsigned restore_tsp)
1597{
1598  TCR *tcr = get_tcr(false);
1599  area *a;
1600 
1601  if (restore_tsp) {
1602    a = tcr->ts_area;
1603  } else {
1604    a = tcr->vs_area;
1605  }
1606  adjust_soft_protection_limit(a);
1607}
1608
1609
1610#ifdef USE_SIGALTSTACK
1611void
1612setup_sigaltstack(area *a)
1613{
1614  stack_t stack;
1615  stack.ss_sp = a->low;
1616  a->low += SIGSTKSZ*8;
1617  stack.ss_size = SIGSTKSZ*8;
1618  stack.ss_flags = 0;
1619  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
1620  if (sigaltstack(&stack, NULL) != 0) {
1621    perror("sigaltstack");
1622    exit(-1);
1623  }
1624}
1625#endif
1626
1627extern opcode egc_write_barrier_start, egc_write_barrier_end,
1628  egc_store_node_conditional_success_test,egc_store_node_conditional,
1629  egc_set_hash_key, egc_gvset, egc_rplacd;
1630
1631/* We use (extremely) rigidly defined instruction sequences for consing,
1632   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
1633   while consing.
1634
1635   Note that we can usually identify which of these instructions is about
1636   to be executed by a stopped thread without comparing all of the bytes
1637   to those at the stopped program counter, but we generally need to
1638   know the sizes of each of these instructions.
1639*/
1640
1641opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
1642  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00};
1643opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
1644  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00};
1645opcode branch_around_alloc_trap_instruction[] =
1646  {0x7f,0x02};
1647opcode alloc_trap_instruction[] =
1648  {0xcd,0xc5};
1649opcode clear_tcr_save_allocptr_tag_instruction[] =
1650  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0};
1651opcode set_allocptr_header_instruction[] =
1652  {0x48,0x89,0x43,0xf3};
1653
1654
1655alloc_instruction_id
1656recognize_alloc_instruction(pc program_counter)
1657{
1658  switch(program_counter[0]) {
1659  case 0xcd: return ID_alloc_trap_instruction;
1660  case 0x7f: return ID_branch_around_alloc_trap_instruction;
1661  case 0x48: return ID_set_allocptr_header_instruction;
1662  case 0x65: 
1663    switch(program_counter[1]) {
1664    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
1665    case 0x48:
1666      switch(program_counter[2]) {
1667      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
1668      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
1669      }
1670    }
1671  }
1672  return ID_unrecognized_alloc_instruction;
1673}
1674     
1675 
1676void
1677pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
1678{
1679  pc program_counter = (pc)xpPC(xp);
1680  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
1681
1682  if (allocptr_tag != 0) {
1683    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
1684    signed_natural
1685      disp = (allocptr_tag == fulltag_cons) ?
1686      sizeof(cons) - fulltag_cons :
1687      xpGPR(xp,Iimm1);
1688    LispObj new_vector;
1689
1690    if ((state == ID_unrecognized_alloc_instruction) ||
1691        ((state == ID_set_allocptr_header_instruction) &&
1692         (allocptr_tag != fulltag_misc))) {
1693      Bug(xp, "Can't determine state of thread 0x%lx, interrupted during memory allocation", tcr);
1694    }
1695    switch(state) {
1696    case ID_set_allocptr_header_instruction:
1697      /* We were consing a vector and we won.  Set the header of the new vector
1698         (in the allocptr register) to the header in %rax and skip over this
1699         instruction, then fall into the next case. */
1700      new_vector = xpGPR(xp,Iallocptr);
1701      deref(new_vector,0) = xpGPR(xp,Iimm0);
1702
1703      xpPC(xp) += sizeof(set_allocptr_header_instruction);
1704      /* Fall thru */
1705    case ID_clear_tcr_save_allocptr_tag_instruction:
1706      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1707      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1708      break;
1709    case ID_alloc_trap_instruction:
1710      /* If we're looking at another thread, we're pretty much committed to
1711         taking the trap.  We don't want the allocptr register to be pointing
1712         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
1713         was determined above.
1714      */
1715      if (interrupt_displacement == NULL) {
1716        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
1717        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
1718      } else {
1719        /* Back out, and tell the caller how to resume the allocation attempt */
1720        *interrupt_displacement = disp;
1721        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1722        tcr->save_allocptr += disp;
1723        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
1724                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1725                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1726      }
1727      break;
1728    case ID_branch_around_alloc_trap_instruction:
1729      /* If we'd take the branch - which is a 'jg" - around the alloc trap,
1730         we might as well finish the allocation.  Otherwise, back out of the
1731         attempt. */
1732      {
1733        int flags = (int)xpGPR(xp,Iflags);
1734       
1735        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
1736            ((flags & (1 << X86_SIGN_FLAG_BIT)) ==
1737             (flags & (1 << X86_CARRY_FLAG_BIT)))) {
1738          /* The branch (jg) would have been taken.  Emulate taking it. */
1739          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
1740                       sizeof(alloc_trap_instruction));
1741          if (allocptr_tag == fulltag_misc) {
1742            /* Slap the header on the new uvector */
1743            new_vector = xpGPR(xp,Iallocptr);
1744            deref(new_vector,0) = xpGPR(xp,Iimm0);
1745            xpPC(xp) += sizeof(set_allocptr_header_instruction);
1746          }
1747          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1748          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1749        } else {
1750          /* Back up */
1751          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1752                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1753          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1754          if (interrupt_displacement) {
1755            *interrupt_displacement = disp;
1756            tcr->save_allocptr += disp;
1757          } else {
1758            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1759          }
1760        }
1761      }
1762      break;
1763    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
1764      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1765      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
1766      /* Fall through */
1767    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
1768      if (interrupt_displacement) {
1769        tcr->save_allocptr += disp;
1770        *interrupt_displacement = disp;
1771      } else {
1772        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1773      }
1774      break;
1775    }
1776    return;
1777  }
1778  if ((program_counter >= &egc_write_barrier_start) &&
1779      (program_counter < &egc_write_barrier_end)) {
1780    LispObj *ea = 0, val, root;
1781    bitvector refbits = (bitvector)(lisp_global(REFBITS));
1782    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
1783
1784    if (program_counter >= &egc_store_node_conditional) {
1785      if ((program_counter < &egc_store_node_conditional_success_test) ||
1786          ((program_counter == &egc_store_node_conditional_success_test) &&
1787           !(xpGPR(xp, Iflags) & (1 << X86_ZERO_FLAG_BIT)))) {
1788        /* Back up the PC, try again */
1789        xpPC(xp) = (LispObj) &egc_store_node_conditional;
1790        return;
1791      }
1792      /* The conditional store succeeded.  Set the refbit, return to ra0 */
1793      val = xpGPR(xp,Iarg_z);
1794      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
1795                                                       xpGPR(xp,Itemp0))));
1796      xpGPR(xp,Iarg_z) = t_value;
1797      need_store = false;
1798    } else if (program_counter >= &egc_set_hash_key) {
1799      root = xpGPR(xp,Iarg_x);
1800      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
1801      val = xpGPR(xp,Iarg_z);
1802      need_memoize_root = true;
1803    } else if (program_counter >= &egc_gvset) {
1804      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
1805      val = xpGPR(xp,Iarg_z);
1806    } else if (program_counter >= &egc_rplacd) {
1807      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
1808      val = xpGPR(xp,Iarg_z);
1809    } else {                      /* egc_rplaca */
1810      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
1811      val = xpGPR(xp,Iarg_z);
1812    }
1813    if (need_store) {
1814      *ea = val;
1815    }
1816    if (need_check_memo) {
1817      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
1818      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
1819          ((LispObj)ea < val)) {
1820        atomic_set_bit(refbits, bitnumber);
1821        if (need_memoize_root) {
1822          bitnumber = area_dnode(root, lisp_global(HEAP_START));
1823          atomic_set_bit(refbits, bitnumber);
1824        }
1825      }
1826    }
1827    {
1828      /* These subprimitives are called via CALL/RET; need
1829         to pop the return address off the stack and set
1830         the PC there. */
1831      LispObj *rsp = (LispObj *)xpGPR(xp,Isp), ra = *rsp++;
1832      xpPC(xp) = ra;
1833      xpGPR(xp,Isp)=(LispObj)rsp;
1834    }
1835    return;
1836  }
1837}
1838
1839void
1840normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
1841{
1842  void *cur_allocptr = (void *)(tcr->save_allocptr);
1843  LispObj lisprsp, lisptsp;
1844  area *a;
1845
1846  if (xp) {
1847    if (is_other_tcr) {
1848      pc_luser_xp(xp, tcr, NULL);
1849    }
1850    a = tcr->vs_area;
1851    lisprsp = xpGPR(xp, Isp);
1852    if (((BytePtr)lisprsp >= a->low) &&
1853        ((BytePtr)lisprsp < a->high)) {
1854      a->active = (BytePtr)lisprsp;
1855    } else {
1856      a->active = (BytePtr) tcr->save_vsp;
1857    }
1858    a = tcr->ts_area;
1859    a->active = (BytePtr) tcr->save_tsp;
1860  } else {
1861    /* In ff-call; get area active pointers from tcr */
1862    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
1863    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
1864  }
1865  if (cur_allocptr) {
1866    update_bytes_allocated(tcr, cur_allocptr);
1867  }
1868  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
1869  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
1870    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
1871  }
1872}
1873
1874
1875/* Suspend and "normalize" other tcrs, then call a gc-like function
1876   in that context.  Resume the other tcrs, then return what the
1877   function returned */
1878
1879TCR *gc_tcr = NULL;
1880
1881
1882int
1883gc_like_from_xp(ExceptionInformation *xp, 
1884                int(*fun)(TCR *, signed_natural), 
1885                signed_natural param)
1886{
1887  TCR *tcr = get_tcr(false), *other_tcr;
1888  ExceptionInformation* other_xp;
1889  int result;
1890  signed_natural inhibit;
1891
1892  suspend_other_threads(true);
1893  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
1894  if (inhibit != 0) {
1895    if (inhibit > 0) {
1896      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
1897    }
1898    resume_other_threads(true);
1899    gc_deferred++;
1900    return 0;
1901  }
1902  gc_deferred = 0;
1903
1904  gc_tcr = tcr;
1905
1906  /* This is generally necessary if the current thread invoked the GC
1907     via an alloc trap, and harmless if the GC was invoked via a GC
1908     trap.  (It's necessary in the first case because the "allocptr"
1909     register - %rbx - may be pointing into the middle of something
1910     below tcr->save_allocbase, and we wouldn't want the GC to see
1911     that bogus pointer.) */
1912  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
1913
1914  normalize_tcr(xp, tcr, false);
1915
1916
1917  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
1918    if (other_tcr->pending_exception_context) {
1919      other_tcr->gc_context = other_tcr->pending_exception_context;
1920    } else if (other_tcr->valence == TCR_STATE_LISP) {
1921      other_tcr->gc_context = other_tcr->suspend_context;
1922    } else {
1923      /* no pending exception, didn't suspend in lisp state:
1924         must have executed a synchronous ff-call.
1925      */
1926      other_tcr->gc_context = NULL;
1927    }
1928    normalize_tcr(other_tcr->gc_context, other_tcr, true);
1929  }
1930   
1931
1932
1933  result = fun(tcr, param);
1934
1935  other_tcr = tcr;
1936  do {
1937    other_tcr->gc_context = NULL;
1938    other_tcr = other_tcr->next;
1939  } while (other_tcr != tcr);
1940
1941  gc_tcr = NULL;
1942
1943  resume_other_threads(true);
1944
1945  return result;
1946
1947}
1948
1949int
1950purify_from_xp(ExceptionInformation *xp, signed_natural param)
1951{
1952  return gc_like_from_xp(xp, purify, param);
1953}
1954
1955int
1956impurify_from_xp(ExceptionInformation *xp, signed_natural param)
1957{
1958  return gc_like_from_xp(xp, impurify, param);
1959}
1960
1961/* Returns #bytes freed by invoking GC */
1962
1963int
1964gc_from_tcr(TCR *tcr, signed_natural param)
1965{
1966  area *a;
1967  BytePtr oldfree, newfree;
1968  BytePtr oldend, newend;
1969
1970#if 0
1971  fprintf(stderr, "Start GC  in 0x%lx\n", tcr);
1972#endif
1973  a = active_dynamic_area;
1974  oldend = a->high;
1975  oldfree = a->active;
1976  gc(tcr, param);
1977  newfree = a->active;
1978  newend = a->high;
1979#if 0
1980  fprintf(stderr, "End GC  in 0x%lx\n", tcr);
1981#endif
1982  return ((oldfree-newfree)+(newend-oldend));
1983}
1984
1985int
1986gc_from_xp(ExceptionInformation *xp, signed_natural param)
1987{
1988  int status = gc_like_from_xp(xp, gc_from_tcr, param);
1989
1990  freeGCptrs();
1991  return status;
1992}
1993
1994#ifdef DARWIN
1995
1996#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
1997#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
1998
1999#if USE_MACH_EXCEPTION_LOCK
2000pthread_mutex_t _mach_exception_lock, *mach_exception_lock;
2001#endif
2002extern void pseudo_sigreturn(void);
2003
2004
2005
2006#define LISP_EXCEPTIONS_HANDLED_MASK \
2007 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2008
2009/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2010#define NUM_LISP_EXCEPTIONS_HANDLED 4
2011
2012typedef struct {
2013  int foreign_exception_port_count;
2014  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2015  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2016  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2017  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2018} MACH_foreign_exception_state;
2019
2020
2021
2022
2023/*
2024  Mach's exception mechanism works a little better than its signal
2025  mechanism (and, not incidentally, it gets along with GDB a lot
2026  better.
2027
2028  Initially, we install an exception handler to handle each native
2029  thread's exceptions.  This process involves creating a distinguished
2030  thread which listens for kernel exception messages on a set of
2031  0 or more thread exception ports.  As threads are created, they're
2032  added to that port set; a thread's exception port is destroyed
2033  (and therefore removed from the port set) when the thread exits.
2034
2035  A few exceptions can be handled directly in the handler thread;
2036  others require that we resume the user thread (and that the
2037  exception thread resumes listening for exceptions.)  The user
2038  thread might eventually want to return to the original context
2039  (possibly modified somewhat.)
2040
2041  As it turns out, the simplest way to force the faulting user
2042  thread to handle its own exceptions is to do pretty much what
2043  signal() does: the exception handlng thread sets up a sigcontext
2044  on the user thread's stack and forces the user thread to resume
2045  execution as if a signal handler had been called with that
2046  context as an argument.  We can use a distinguished UUO at a
2047  distinguished address to do something like sigreturn(); that'll
2048  have the effect of resuming the user thread's execution in
2049  the (pseudo-) signal context.
2050
2051  Since:
2052    a) we have miles of code in C and in Lisp that knows how to
2053    deal with Linux sigcontexts
2054    b) Linux sigcontexts contain a little more useful information
2055    (the DAR, DSISR, etc.) than their Darwin counterparts
2056    c) we have to create a sigcontext ourselves when calling out
2057    to the user thread: we aren't really generating a signal, just
2058    leveraging existing signal-handling code.
2059
2060  we create a Linux sigcontext struct.
2061
2062  Simple ?  Hopefully from the outside it is ...
2063
2064  We want the process of passing a thread's own context to it to
2065  appear to be atomic: in particular, we don't want the GC to suspend
2066  a thread that's had an exception but has not yet had its user-level
2067  exception handler called, and we don't want the thread's exception
2068  context to be modified by a GC while the Mach handler thread is
2069  copying it around.  On Linux (and on Jaguar), we avoid this issue
2070  because (a) the kernel sets up the user-level signal handler and
2071  (b) the signal handler blocks signals (including the signal used
2072  by the GC to suspend threads) until tcr->xframe is set up.
2073
2074  The GC and the Mach server thread therefore contend for the lock
2075  "mach_exception_lock".  The Mach server thread holds the lock
2076  when copying exception information between the kernel and the
2077  user thread; the GC holds this lock during most of its execution
2078  (delaying exception processing until it can be done without
2079  GC interference.)
2080
2081*/
2082
2083#ifdef PPC64
2084#define C_REDZONE_LEN           320
2085#define C_STK_ALIGN             32
2086#else
2087#define C_REDZONE_LEN           224
2088#define C_STK_ALIGN             16
2089#endif
2090#define C_PARAMSAVE_LEN         64
2091#define C_LINKAGE_LEN           48
2092
2093#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2094
2095void
2096fatal_mach_error(char *format, ...);
2097
2098#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2099
2100
2101void
2102restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2103{
2104  int i, j;
2105  kern_return_t kret;
2106#if WORD_SIZE == 64
2107  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2108#else
2109  struct mcontext * mc = UC_MCONTEXT(pseudosigcontext);
2110#endif
2111
2112  /* Set the thread's FP state from the pseudosigcontext */
2113  kret = thread_set_state(thread,
2114                          x86_FLOAT_STATE64,
2115                          (thread_state_t)&(mc->__fs),
2116                          x86_FLOAT_STATE64_COUNT);
2117
2118  MACH_CHECK_ERROR("setting thread FP state", kret);
2119
2120  /* The thread'll be as good as new ... */
2121#if WORD_SIZE == 64
2122  kret = thread_set_state(thread,
2123                          x86_THREAD_STATE64,
2124                          (thread_state_t)&(mc->__ss),
2125                          x86_THREAD_STATE64_COUNT);
2126#else
2127  kret = thread_set_state(thread, 
2128                          x86_THREAD_STATE32,
2129                          (thread_state_t)&(mc->__ss),
2130                          x86_THREAD_STATE32_COUNT);
2131#endif
2132  MACH_CHECK_ERROR("setting thread state", kret);
2133} 
2134
2135/* This code runs in the exception handling thread, in response
2136   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2137   in response to a call to pseudo_sigreturn() from the specified
2138   user thread.
2139   Find that context (the user thread's R3 points to it), then
2140   use that context to set the user thread's state.  When this
2141   function's caller returns, the Mach kernel will resume the
2142   user thread.
2143*/
2144
2145kern_return_t
2146do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
2147{
2148  ExceptionInformation *xp;
2149
2150#ifdef DEBUG_MACH_EXCEPTIONS
2151  fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
2152#endif
2153  xp = tcr->pending_exception_context;
2154  if (xp) {
2155    tcr->pending_exception_context = NULL;
2156    tcr->valence = TCR_STATE_LISP;
2157    restore_mach_thread_state(thread, xp);
2158    raise_pending_interrupt(tcr);
2159  } else {
2160    Bug(NULL, "no xp here!\n");
2161  }
2162#ifdef DEBUG_MACH_EXCEPTIONS
2163  fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
2164#endif
2165  return KERN_SUCCESS;
2166} 
2167
2168ExceptionInformation *
2169create_thread_context_frame(mach_port_t thread, 
2170                            natural *new_stack_top,
2171                            siginfo_t **info_ptr,
2172                            TCR *tcr,
2173#ifdef X8664
2174                            x86_thread_state64_t *ts
2175#else
2176                            x86_thread_state_t *ts
2177#endif
2178                            )
2179{
2180  mach_msg_type_number_t thread_state_count;
2181  kern_return_t result;
2182  int i,j;
2183  ExceptionInformation *pseudosigcontext;
2184#ifdef X8664
2185  MCONTEXT_T mc;
2186#else
2187  struct mcontext *mc;
2188#endif
2189  natural stackp, backlink;
2190
2191 
2192  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2193  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2194  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
2195  if (info_ptr) {
2196    *info_ptr = (siginfo_t *)stackp;
2197  }
2198  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
2199  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
2200
2201  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
2202#ifdef X8664
2203  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
2204#else
2205  mc = (struct mcontext *) ptr_from_lispobj(stackp);
2206#endif
2207 
2208  bcopy(ts,&(mc->__ss),sizeof(*ts));
2209
2210  thread_state_count = x86_FLOAT_STATE64_COUNT;
2211  thread_get_state(thread,
2212                   x86_FLOAT_STATE64,
2213                   (thread_state_t)&(mc->__fs),
2214                   &thread_state_count);
2215
2216
2217#ifdef X8664
2218  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
2219#else
2220  thread_state_count = x86_EXCEPTION_STATE_COUNT;
2221#endif
2222  thread_get_state(thread,
2223#ifdef X8664
2224                   x86_EXCEPTION_STATE64,
2225#else
2226                   x86_EXCEPTION_STATE,
2227#endif
2228                   (thread_state_t)&(mc->__es),
2229                   &thread_state_count);
2230
2231
2232  UC_MCONTEXT(pseudosigcontext) = mc;
2233  if (new_stack_top) {
2234    *new_stack_top = stackp;
2235  }
2236  return pseudosigcontext;
2237}
2238
2239/*
2240  This code sets up the user thread so that it executes a "pseudo-signal
2241  handler" function when it resumes.  Create a fake ucontext struct
2242  on the thread's stack and pass it as an argument to the pseudo-signal
2243  handler.
2244
2245  Things are set up so that the handler "returns to" pseudo_sigreturn(),
2246  which will restore the thread's context.
2247
2248  If the handler invokes code that throws (or otherwise never sigreturn()'s
2249  to the context), that's fine.
2250
2251  Actually, check that: throw (and variants) may need to be careful and
2252  pop the tcr's xframe list until it's younger than any frame being
2253  entered.
2254*/
2255
2256int
2257setup_signal_frame(mach_port_t thread,
2258                   void *handler_address,
2259                   int signum,
2260                   int code,
2261                   TCR *tcr,
2262#ifdef X8664
2263                   x86_thread_state64_t *ts
2264#else
2265                   x86_thread_state_t *ts
2266#endif
2267                   )
2268{
2269#ifdef X8664
2270  x86_thread_state64_t new_ts;
2271#else
2272  x86_thread_state_t new_ts;
2273#endif
2274  ExceptionInformation *pseudosigcontext;
2275  int i, j, old_valence = tcr->valence;
2276  kern_return_t result;
2277  natural stackp, *stackpp;
2278  siginfo_t *info;
2279
2280#ifdef DEBUG_MACH_EXCEPTIONS
2281  fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
2282#endif
2283  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
2284  bzero(info, sizeof(*info));
2285  info->si_code = code;
2286  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
2287  info->si_signo = signum;
2288  pseudosigcontext->uc_onstack = 0;
2289  pseudosigcontext->uc_sigmask = (sigset_t) 0;
2290  pseudosigcontext->uc_stack.ss_sp = 0;
2291  pseudosigcontext->uc_stack.ss_size = 0;
2292  pseudosigcontext->uc_stack.ss_flags = 0;
2293  pseudosigcontext->uc_link = NULL;
2294  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
2295  tcr->pending_exception_context = pseudosigcontext;
2296  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
2297 
2298
2299  /*
2300     It seems like we've created a  sigcontext on the thread's
2301     stack.  Set things up so that we call the handler (with appropriate
2302     args) when the thread's resumed.
2303  */
2304
2305  new_ts.__rip = (natural) handler_address;
2306  stackpp = (natural *)stackp;
2307  *--stackpp = (natural)pseudo_sigreturn;
2308  stackp = (natural)stackpp;
2309  new_ts.__rdi = signum;
2310  new_ts.__rsi = (natural)info;
2311  new_ts.__rdx = (natural)pseudosigcontext;
2312  new_ts.__rcx = (natural)tcr;
2313  new_ts.__r8 = (natural)old_valence;
2314  new_ts.__rsp = stackp;
2315  new_ts.__rflags = ts->__rflags;
2316
2317
2318#ifdef X8664
2319  thread_set_state(thread,
2320                   x86_THREAD_STATE64,
2321                   (thread_state_t)&new_ts,
2322                   x86_THREAD_STATE64_COUNT);
2323#else
2324  thread_set_state(thread, 
2325                   x86_THREAD_STATE,
2326                   (thread_state_t)&new_ts,
2327                   x86_THREAD_STATE_COUNT);
2328#endif
2329#ifdef DEBUG_MACH_EXCEPTIONS
2330  fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
2331#endif
2332  return 0;
2333}
2334
2335
2336
2337
2338
2339
2340/*
2341  This function runs in the exception handling thread.  It's
2342  called (by this precise name) from the library function "exc_server()"
2343  when the thread's exception ports are set up.  (exc_server() is called
2344  via mach_msg_server(), which is a function that waits for and dispatches
2345  on exception messages from the Mach kernel.)
2346
2347  This checks to see if the exception was caused by a pseudo_sigreturn()
2348  UUO; if so, it arranges for the thread to have its state restored
2349  from the specified context.
2350
2351  Otherwise, it tries to map the exception to a signal number and
2352  arranges that the thread run a "pseudo signal handler" to handle
2353  the exception.
2354
2355  Some exceptions could and should be handled here directly.
2356*/
2357
2358/* We need the thread's state earlier on x86_64 than we did on PPC;
2359   the PC won't fit in code_vector[1].  We shouldn't try to get it
2360   lazily (via catch_exception_raise_state()); until we own the
2361   exception lock, we shouldn't have it in userspace (since a GCing
2362   thread wouldn't know that we had our hands on it.)
2363*/
2364
2365#ifdef X8664
2366#define ts_pc(t) t.__rip
2367#else
2368#define ts_pc(t) t.eip
2369#endif
2370
2371#ifdef DARWIN_USE_PSEUDO_SIGRETURN
2372#define DARWIN_EXCEPTION_HANDLER signal_handler
2373#else
2374#define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler
2375#endif
2376
2377
2378kern_return_t
2379catch_exception_raise(mach_port_t exception_port,
2380                      mach_port_t thread,
2381                      mach_port_t task, 
2382                      exception_type_t exception,
2383                      exception_data_t code_vector,
2384                      mach_msg_type_number_t code_count)
2385{
2386  int signum = 0, code = *code_vector, code1;
2387  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
2388  kern_return_t kret, call_kret;
2389#ifdef X8664
2390  x86_thread_state64_t ts;
2391#else
2392  x86_thread_state_t ts;
2393#endif
2394  mach_msg_type_number_t thread_state_count;
2395
2396
2397
2398#ifdef DEBUG_MACH_EXCEPTIONS
2399  fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
2400#endif
2401
2402
2403  if (
2404#if USE_MACH_EXCEPTION_LOCK
2405      pthread_mutex_trylock(mach_exception_lock) == 0
2406#else
2407      1
2408#endif
2409      ) {
2410#ifdef X8664
2411    do {
2412      thread_state_count = x86_THREAD_STATE64_COUNT;
2413      call_kret = thread_get_state(thread,
2414                                   x86_THREAD_STATE64,
2415                                   (thread_state_t)&ts,
2416                                   &thread_state_count);
2417    } while (call_kret == KERN_ABORTED);
2418  MACH_CHECK_ERROR("getting thread state",call_kret);
2419#else
2420    thread_state_count = x86_THREAD_STATE_COUNT;
2421    thread_get_state(thread,
2422                     x86_THREAD_STATE,
2423                     (thread_state_t)&ts,
2424                     &thread_state_count);
2425#endif
2426    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
2427      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2428    } 
2429    if ((code == EXC_I386_GPFLT) &&
2430        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
2431      kret = do_pseudo_sigreturn(thread, tcr);
2432#if 0
2433      fprintf(stderr, "Exception return in 0x%x\n",tcr);
2434#endif
2435    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
2436      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
2437      kret = 17;
2438    } else {
2439      switch (exception) {
2440      case EXC_BAD_ACCESS:
2441        if (code == EXC_I386_GPFLT) {
2442          signum = SIGSEGV;
2443        } else {
2444          signum = SIGBUS;
2445        }
2446        break;
2447       
2448      case EXC_BAD_INSTRUCTION:
2449        if (code == EXC_I386_GPFLT) {
2450          signum = SIGSEGV;
2451        } else {
2452          signum = SIGILL;
2453        }
2454        break;
2455         
2456      case EXC_SOFTWARE:
2457        signum = SIGILL;
2458        break;
2459       
2460      case EXC_ARITHMETIC:
2461        signum = SIGFPE;
2462        break;
2463       
2464      default:
2465        break;
2466      }
2467      if (signum) {
2468        kret = setup_signal_frame(thread,
2469                                  (void *)DARWIN_EXCEPTION_HANDLER,
2470                                  signum,
2471                                  code,
2472                                  tcr, 
2473                                  &ts);
2474#if 0
2475        fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
2476#endif
2477       
2478      } else {
2479        kret = 17;
2480      }
2481    }
2482#if USE_MACH_EXCEPTION_LOCK
2483#ifdef DEBUG_MACH_EXCEPTIONS
2484    fprintf(stderr, "releasing Mach exception lock in exception thread\n");
2485#endif
2486    pthread_mutex_unlock(mach_exception_lock);
2487#endif
2488  } else {
2489    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2490     
2491#if 0
2492    fprintf(stderr, "deferring pending exception in 0x%x\n", tcr);
2493#endif
2494    kret = KERN_SUCCESS;
2495    if (tcr == gc_tcr) {
2496      int i;
2497      write(1, "exception in GC thread. Sleeping for 60 seconds\n",sizeof("exception in GC thread.  Sleeping for 60 seconds\n"));
2498      for (i = 0; i < 60; i++) {
2499        sleep(1);
2500      }
2501      _exit(EX_SOFTWARE);
2502    }
2503  }
2504  return kret;
2505}
2506
2507
2508
2509
2510static mach_port_t mach_exception_thread = (mach_port_t)0;
2511
2512
2513/*
2514  The initial function for an exception-handling thread.
2515*/
2516
2517void *
2518exception_handler_proc(void *arg)
2519{
2520  extern boolean_t exc_server();
2521  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
2522
2523  mach_exception_thread = pthread_mach_thread_np(pthread_self());
2524  mach_msg_server(exc_server, 256, p, 0);
2525  /* Should never return. */
2526  abort();
2527}
2528
2529
2530
2531void
2532mach_exception_thread_shutdown()
2533{
2534  kern_return_t kret;
2535
2536  fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
2537  kret = thread_terminate(mach_exception_thread);
2538  if (kret != KERN_SUCCESS) {
2539    fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
2540  }
2541}
2542
2543
2544mach_port_t
2545mach_exception_port_set()
2546{
2547  static mach_port_t __exception_port_set = MACH_PORT_NULL;
2548  kern_return_t kret; 
2549  if (__exception_port_set == MACH_PORT_NULL) {
2550#if USE_MACH_EXCEPTION_LOCK
2551    mach_exception_lock = &_mach_exception_lock;
2552    pthread_mutex_init(mach_exception_lock, NULL);
2553#endif
2554
2555    kret = mach_port_allocate(mach_task_self(),
2556                              MACH_PORT_RIGHT_PORT_SET,
2557                              &__exception_port_set);
2558    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
2559    create_system_thread(0,
2560                         NULL,
2561                         exception_handler_proc, 
2562                         (void *)((natural)__exception_port_set));
2563  }
2564  return __exception_port_set;
2565}
2566
2567/*
2568  Setup a new thread to handle those exceptions specified by
2569  the mask "which".  This involves creating a special Mach
2570  message port, telling the Mach kernel to send exception
2571  messages for the calling thread to that port, and setting
2572  up a handler thread which listens for and responds to
2573  those messages.
2574
2575*/
2576
2577/*
2578  Establish the lisp thread's TCR as its exception port, and determine
2579  whether any other ports have been established by foreign code for
2580  exceptions that lisp cares about.
2581
2582  If this happens at all, it should happen on return from foreign
2583  code and on entry to lisp code via a callback.
2584
2585  This is a lot of trouble (and overhead) to support Java, or other
2586  embeddable systems that clobber their caller's thread exception ports.
2587 
2588*/
2589kern_return_t
2590tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
2591{
2592  kern_return_t kret;
2593  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
2594  int i;
2595  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
2596  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
2597  exception_mask_t mask = 0;
2598
2599  kret = thread_swap_exception_ports(thread,
2600                                     LISP_EXCEPTIONS_HANDLED_MASK,
2601                                     lisp_port,
2602                                     EXCEPTION_DEFAULT,
2603                                     THREAD_STATE_NONE,
2604                                     fxs->masks,
2605                                     &n,
2606                                     fxs->ports,
2607                                     fxs->behaviors,
2608                                     fxs->flavors);
2609  if (kret == KERN_SUCCESS) {
2610    fxs->foreign_exception_port_count = n;
2611    for (i = 0; i < n; i ++) {
2612      foreign_port = fxs->ports[i];
2613
2614      if ((foreign_port != lisp_port) &&
2615          (foreign_port != MACH_PORT_NULL)) {
2616        mask |= fxs->masks[i];
2617      }
2618    }
2619    tcr->foreign_exception_status = (int) mask;
2620  }
2621  return kret;
2622}
2623
2624kern_return_t
2625tcr_establish_lisp_exception_port(TCR *tcr)
2626{
2627  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
2628}
2629
2630/*
2631  Do this when calling out to or returning from foreign code, if
2632  any conflicting foreign exception ports were established when we
2633  last entered lisp code.
2634*/
2635kern_return_t
2636restore_foreign_exception_ports(TCR *tcr)
2637{
2638  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
2639 
2640  if (m) {
2641    MACH_foreign_exception_state *fxs  = 
2642      (MACH_foreign_exception_state *) tcr->native_thread_info;
2643    int i, n = fxs->foreign_exception_port_count;
2644    exception_mask_t tm;
2645
2646    for (i = 0; i < n; i++) {
2647      if ((tm = fxs->masks[i]) & m) {
2648        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
2649                                   tm,
2650                                   fxs->ports[i],
2651                                   fxs->behaviors[i],
2652                                   fxs->flavors[i]);
2653      }
2654    }
2655  }
2656}
2657                                   
2658
2659/*
2660  This assumes that a Mach port (to be used as the thread's exception port) whose
2661  "name" matches the TCR's 32-bit address has already been allocated.
2662*/
2663
2664kern_return_t
2665setup_mach_exception_handling(TCR *tcr)
2666{
2667  mach_port_t
2668    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
2669    target_thread = pthread_mach_thread_np((pthread_t)ptr_from_lispobj(tcr->osid)),
2670    task_self = mach_task_self();
2671  kern_return_t kret;
2672
2673  kret = mach_port_insert_right(task_self,
2674                                thread_exception_port,
2675                                thread_exception_port,
2676                                MACH_MSG_TYPE_MAKE_SEND);
2677  MACH_CHECK_ERROR("adding send right to exception_port",kret);
2678
2679  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
2680  if (kret == KERN_SUCCESS) {
2681    mach_port_t exception_port_set = mach_exception_port_set();
2682
2683    kret = mach_port_move_member(task_self,
2684                                 thread_exception_port,
2685                                 exception_port_set);
2686  }
2687  return kret;
2688}
2689
2690void
2691darwin_exception_init(TCR *tcr)
2692{
2693  void tcr_monitor_exception_handling(TCR*, Boolean);
2694  kern_return_t kret;
2695  MACH_foreign_exception_state *fxs = 
2696    calloc(1, sizeof(MACH_foreign_exception_state));
2697 
2698  tcr->native_thread_info = (void *) fxs;
2699
2700  if ((kret = setup_mach_exception_handling(tcr))
2701      != KERN_SUCCESS) {
2702    fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
2703    terminate_lisp();
2704  }
2705  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
2706  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
2707}
2708
2709/*
2710  The tcr is the "name" of the corresponding thread's exception port.
2711  Destroying the port should remove it from all port sets of which it's
2712  a member (notably, the exception port set.)
2713*/
2714void
2715darwin_exception_cleanup(TCR *tcr)
2716{
2717  void *fxs = tcr->native_thread_info;
2718  extern Boolean use_mach_exception_handling;
2719
2720  if (fxs) {
2721    tcr->native_thread_info = NULL;
2722    free(fxs);
2723  }
2724  if (use_mach_exception_handling) {
2725    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2726    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2727  }
2728}
2729
2730
2731Boolean
2732suspend_mach_thread(mach_port_t mach_thread)
2733{
2734  kern_return_t status;
2735  Boolean aborted = false;
2736 
2737  do {
2738    aborted = false;
2739    status = thread_suspend(mach_thread);
2740    if (status == KERN_SUCCESS) {
2741      status = thread_abort_safely(mach_thread);
2742      if (status == KERN_SUCCESS) {
2743        aborted = true;
2744      } else {
2745        fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
2746        thread_resume(mach_thread);
2747      }
2748    } else {
2749      return false;
2750    }
2751  } while (! aborted);
2752  return true;
2753}
2754
2755/*
2756  Only do this if pthread_kill indicated that the pthread isn't
2757  listening to signals anymore, as can happen as soon as pthread_exit()
2758  is called on Darwin.  The thread could still call out to lisp as it
2759  is exiting, so we need another way to suspend it in this case.
2760*/
2761Boolean
2762mach_suspend_tcr(TCR *tcr)
2763{
2764  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
2765  ExceptionInformation *pseudosigcontext;
2766  Boolean result = false;
2767 
2768  result = suspend_mach_thread(mach_thread);
2769  if (result) {
2770    mach_msg_type_number_t thread_state_count;
2771#ifdef X8664
2772    x86_thread_state64_t ts;
2773    thread_state_count = x86_THREAD_STATE64_COUNT;
2774    thread_get_state(mach_thread,
2775                     x86_THREAD_STATE64,
2776                     (thread_state_t)&ts,
2777                     &thread_state_count);
2778#else
2779    x86_thread_state_t ts;
2780    thread_state_count = x86_THREAD_STATE_COUNT;
2781    thread_get_state(mach_thread,
2782                     x86_THREAD_STATE,
2783                     (thread_state_t)&ts,
2784                     &thread_state_count);
2785#endif
2786
2787    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
2788    pseudosigcontext->uc_onstack = 0;
2789    pseudosigcontext->uc_sigmask = (sigset_t) 0;
2790    tcr->suspend_context = pseudosigcontext;
2791  }
2792  return result;
2793}
2794
2795void
2796mach_resume_tcr(TCR *tcr)
2797{
2798  ExceptionInformation *xp;
2799  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
2800 
2801  xp = tcr->suspend_context;
2802#ifdef DEBUG_MACH_EXCEPTIONS
2803  fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
2804          tcr, tcr->pending_exception_context);
2805#endif
2806  tcr->suspend_context = NULL;
2807  restore_mach_thread_state(mach_thread, xp);
2808#ifdef DEBUG_MACH_EXCEPTIONS
2809  fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
2810          tcr, tcr->pending_exception_context);
2811#endif
2812  thread_resume(mach_thread);
2813}
2814
2815void
2816fatal_mach_error(char *format, ...)
2817{
2818  va_list args;
2819  char s[512];
2820 
2821
2822  va_start(args, format);
2823  vsnprintf(s, sizeof(s),format, args);
2824  va_end(args);
2825
2826  Fatal("Mach error", s);
2827}
2828
2829
2830
2831
2832#endif
Note: See TracBrowser for help on using the repository browser.