source: trunk/source/lisp-kernel/x86-exceptions.c @ 8540

Last change on this file since 8540 was 8540, checked in by gb, 12 years ago

Avoid using SIGEMT as asynch signal.

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