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

Last change on this file since 8475 was 8475, checked in by gb, 13 years ago

get impurify() working on x86-64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 78.2 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  thread_resume_signal = SIG_RESUME_THREAD;
1590
1591  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
1592  install_signal_handler(thread_resume_signal, (void *)SUSPEND_RESUME_HANDLER);
1593  install_signal_handler(SIGQUIT, (void *)QUIT_HANDLER);
1594}
1595
1596
1597void
1598enable_fp_exceptions()
1599{
1600}
1601
1602void
1603exception_init()
1604{
1605  install_pmcl_exception_handlers();
1606}
1607
1608void
1609adjust_exception_pc(ExceptionInformation *xp, int delta)
1610{
1611  xpPC(xp) += delta;
1612}
1613
1614/*
1615  Lower (move toward 0) the "end" of the soft protected area associated
1616  with a by a page, if we can.
1617*/
1618
1619void
1620
1621adjust_soft_protection_limit(area *a)
1622{
1623  char *proposed_new_soft_limit = a->softlimit - 4096;
1624  protected_area_ptr p = a->softprot;
1625 
1626  if (proposed_new_soft_limit >= (p->start+16384)) {
1627    p->end = proposed_new_soft_limit;
1628    p->protsize = p->end-p->start;
1629    a->softlimit = proposed_new_soft_limit;
1630  }
1631  protect_area(p);
1632}
1633
1634void
1635restore_soft_stack_limit(unsigned restore_tsp)
1636{
1637  TCR *tcr = get_tcr(false);
1638  area *a;
1639 
1640  if (restore_tsp) {
1641    a = tcr->ts_area;
1642  } else {
1643    a = tcr->vs_area;
1644  }
1645  adjust_soft_protection_limit(a);
1646}
1647
1648
1649#ifdef USE_SIGALTSTACK
1650void
1651setup_sigaltstack(area *a)
1652{
1653  stack_t stack;
1654  stack.ss_sp = a->low;
1655  a->low += SIGSTKSZ*8;
1656  stack.ss_size = SIGSTKSZ*8;
1657  stack.ss_flags = 0;
1658  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
1659  if (sigaltstack(&stack, NULL) != 0) {
1660    perror("sigaltstack");
1661    exit(-1);
1662  }
1663}
1664#endif
1665
1666extern opcode egc_write_barrier_start, egc_write_barrier_end,
1667  egc_store_node_conditional_success_test,egc_store_node_conditional,
1668  egc_set_hash_key, egc_gvset, egc_rplacd;
1669
1670/* We use (extremely) rigidly defined instruction sequences for consing,
1671   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
1672   while consing.
1673
1674   Note that we can usually identify which of these instructions is about
1675   to be executed by a stopped thread without comparing all of the bytes
1676   to those at the stopped program counter, but we generally need to
1677   know the sizes of each of these instructions.
1678*/
1679
1680opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
1681  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00};
1682opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
1683  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00};
1684opcode branch_around_alloc_trap_instruction[] =
1685  {0x7f,0x02};
1686opcode alloc_trap_instruction[] =
1687  {0xcd,0xc5};
1688opcode clear_tcr_save_allocptr_tag_instruction[] =
1689  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0};
1690opcode set_allocptr_header_instruction[] =
1691  {0x48,0x89,0x43,0xf3};
1692
1693
1694alloc_instruction_id
1695recognize_alloc_instruction(pc program_counter)
1696{
1697  switch(program_counter[0]) {
1698  case 0xcd: return ID_alloc_trap_instruction;
1699  case 0x7f: return ID_branch_around_alloc_trap_instruction;
1700  case 0x48: return ID_set_allocptr_header_instruction;
1701  case 0x65: 
1702    switch(program_counter[1]) {
1703    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
1704    case 0x48:
1705      switch(program_counter[2]) {
1706      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
1707      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
1708      }
1709    }
1710  }
1711  return ID_unrecognized_alloc_instruction;
1712}
1713     
1714 
1715void
1716pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
1717{
1718  pc program_counter = (pc)xpPC(xp);
1719  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
1720
1721  if (allocptr_tag != 0) {
1722    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
1723    signed_natural
1724      disp = (allocptr_tag == fulltag_cons) ?
1725      sizeof(cons) - fulltag_cons :
1726      xpGPR(xp,Iimm1);
1727    LispObj new_vector;
1728
1729    if ((state == ID_unrecognized_alloc_instruction) ||
1730        ((state == ID_set_allocptr_header_instruction) &&
1731         (allocptr_tag != fulltag_misc))) {
1732      Bug(xp, "Can't determine state of thread 0x%lx, interrupted during memory allocation", tcr);
1733    }
1734    switch(state) {
1735    case ID_set_allocptr_header_instruction:
1736      /* We were consing a vector and we won.  Set the header of the new vector
1737         (in the allocptr register) to the header in %rax and skip over this
1738         instruction, then fall into the next case. */
1739      new_vector = xpGPR(xp,Iallocptr);
1740      deref(new_vector,0) = xpGPR(xp,Iimm0);
1741
1742      xpPC(xp) += sizeof(set_allocptr_header_instruction);
1743      /* Fall thru */
1744    case ID_clear_tcr_save_allocptr_tag_instruction:
1745      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1746      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1747      break;
1748    case ID_alloc_trap_instruction:
1749      /* If we're looking at another thread, we're pretty much committed to
1750         taking the trap.  We don't want the allocptr register to be pointing
1751         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
1752         was determined above.
1753      */
1754      if (interrupt_displacement == NULL) {
1755        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
1756        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
1757      } else {
1758        /* Back out, and tell the caller how to resume the allocation attempt */
1759        *interrupt_displacement = disp;
1760        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1761        tcr->save_allocptr += disp;
1762        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
1763                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1764                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1765      }
1766      break;
1767    case ID_branch_around_alloc_trap_instruction:
1768      /* If we'd take the branch - which is a 'jg" - around the alloc trap,
1769         we might as well finish the allocation.  Otherwise, back out of the
1770         attempt. */
1771      {
1772        int flags = (int)xpGPR(xp,Iflags);
1773       
1774        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
1775            ((flags & (1 << X86_SIGN_FLAG_BIT)) ==
1776             (flags & (1 << X86_CARRY_FLAG_BIT)))) {
1777          /* The branch (jg) would have been taken.  Emulate taking it. */
1778          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
1779                       sizeof(alloc_trap_instruction));
1780          if (allocptr_tag == fulltag_misc) {
1781            /* Slap the header on the new uvector */
1782            new_vector = xpGPR(xp,Iallocptr);
1783            deref(new_vector,0) = xpGPR(xp,Iimm0);
1784            xpPC(xp) += sizeof(set_allocptr_header_instruction);
1785          }
1786          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1787          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1788        } else {
1789          /* Back up */
1790          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1791                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1792          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1793          if (interrupt_displacement) {
1794            *interrupt_displacement = disp;
1795            tcr->save_allocptr += disp;
1796          } else {
1797            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1798          }
1799        }
1800      }
1801      break;
1802    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
1803      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1804      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
1805      /* Fall through */
1806    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
1807      if (interrupt_displacement) {
1808        tcr->save_allocptr += disp;
1809        *interrupt_displacement = disp;
1810      } else {
1811        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1812      }
1813      break;
1814    }
1815    return;
1816  }
1817  if ((program_counter >= &egc_write_barrier_start) &&
1818      (program_counter < &egc_write_barrier_end)) {
1819    LispObj *ea = 0, val, root;
1820    bitvector refbits = (bitvector)(lisp_global(REFBITS));
1821    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
1822
1823    if (program_counter >= &egc_store_node_conditional) {
1824      if ((program_counter < &egc_store_node_conditional_success_test) ||
1825          ((program_counter == &egc_store_node_conditional_success_test) &&
1826           !(xpGPR(xp, Iflags) & (1 << X86_ZERO_FLAG_BIT)))) {
1827        /* Back up the PC, try again */
1828        xpPC(xp) = (LispObj) &egc_store_node_conditional;
1829        return;
1830      }
1831      /* The conditional store succeeded.  Set the refbit, return to ra0 */
1832      val = xpGPR(xp,Iarg_z);
1833      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
1834                                                       xpGPR(xp,Itemp0))));
1835      xpGPR(xp,Iarg_z) = t_value;
1836      need_store = false;
1837    } else if (program_counter >= &egc_set_hash_key) {
1838      root = xpGPR(xp,Iarg_x);
1839      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
1840      val = xpGPR(xp,Iarg_z);
1841      need_memoize_root = true;
1842    } else if (program_counter >= &egc_gvset) {
1843      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
1844      val = xpGPR(xp,Iarg_z);
1845    } else if (program_counter >= &egc_rplacd) {
1846      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
1847      val = xpGPR(xp,Iarg_z);
1848    } else {                      /* egc_rplaca */
1849      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
1850      val = xpGPR(xp,Iarg_z);
1851    }
1852    if (need_store) {
1853      *ea = val;
1854    }
1855    if (need_check_memo) {
1856      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
1857      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
1858          ((LispObj)ea < val)) {
1859        atomic_set_bit(refbits, bitnumber);
1860        if (need_memoize_root) {
1861          bitnumber = area_dnode(root, lisp_global(HEAP_START));
1862          atomic_set_bit(refbits, bitnumber);
1863        }
1864      }
1865    }
1866    {
1867      /* These subprimitives are called via CALL/RET; need
1868         to pop the return address off the stack and set
1869         the PC there. */
1870      LispObj *rsp = (LispObj *)xpGPR(xp,Isp), ra = *rsp++;
1871      xpPC(xp) = ra;
1872      xpGPR(xp,Isp)=(LispObj)rsp;
1873    }
1874    return;
1875  }
1876}
1877
1878void
1879normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
1880{
1881  void *cur_allocptr = (void *)(tcr->save_allocptr);
1882  LispObj lisprsp, lisptsp;
1883  area *a;
1884
1885  if (xp) {
1886    if (is_other_tcr) {
1887      pc_luser_xp(xp, tcr, NULL);
1888    }
1889    a = tcr->vs_area;
1890    lisprsp = xpGPR(xp, Isp);
1891    if (((BytePtr)lisprsp >= a->low) &&
1892        ((BytePtr)lisprsp < a->high)) {
1893      a->active = (BytePtr)lisprsp;
1894    } else {
1895      a->active = (BytePtr) tcr->save_vsp;
1896    }
1897    a = tcr->ts_area;
1898    a->active = (BytePtr) tcr->save_tsp;
1899  } else {
1900    /* In ff-call; get area active pointers from tcr */
1901    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
1902    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
1903  }
1904  if (cur_allocptr) {
1905    update_bytes_allocated(tcr, cur_allocptr);
1906  }
1907  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
1908  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
1909    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
1910  }
1911}
1912
1913
1914/* Suspend and "normalize" other tcrs, then call a gc-like function
1915   in that context.  Resume the other tcrs, then return what the
1916   function returned */
1917
1918TCR *gc_tcr = NULL;
1919
1920
1921int
1922gc_like_from_xp(ExceptionInformation *xp, 
1923                int(*fun)(TCR *, signed_natural), 
1924                signed_natural param)
1925{
1926  TCR *tcr = get_tcr(false), *other_tcr;
1927  ExceptionInformation* other_xp;
1928  int result;
1929  signed_natural inhibit;
1930
1931  suspend_other_threads(true);
1932  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
1933  if (inhibit != 0) {
1934    if (inhibit > 0) {
1935      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
1936    }
1937    resume_other_threads(true);
1938    gc_deferred++;
1939    return 0;
1940  }
1941  gc_deferred = 0;
1942
1943  gc_tcr = tcr;
1944
1945  /* This is generally necessary if the current thread invoked the GC
1946     via an alloc trap, and harmless if the GC was invoked via a GC
1947     trap.  (It's necessary in the first case because the "allocptr"
1948     register - %rbx - may be pointing into the middle of something
1949     below tcr->save_allocbase, and we wouldn't want the GC to see
1950     that bogus pointer.) */
1951  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
1952
1953  normalize_tcr(xp, tcr, false);
1954
1955
1956  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
1957    if (other_tcr->pending_exception_context) {
1958      other_tcr->gc_context = other_tcr->pending_exception_context;
1959    } else if (other_tcr->valence == TCR_STATE_LISP) {
1960      other_tcr->gc_context = other_tcr->suspend_context;
1961    } else {
1962      /* no pending exception, didn't suspend in lisp state:
1963         must have executed a synchronous ff-call.
1964      */
1965      other_tcr->gc_context = NULL;
1966    }
1967    normalize_tcr(other_tcr->gc_context, other_tcr, true);
1968  }
1969   
1970
1971
1972  result = fun(tcr, param);
1973
1974  other_tcr = tcr;
1975  do {
1976    other_tcr->gc_context = NULL;
1977    other_tcr = other_tcr->next;
1978  } while (other_tcr != tcr);
1979
1980  gc_tcr = NULL;
1981
1982  resume_other_threads(true);
1983
1984  return result;
1985
1986}
1987
1988int
1989purify_from_xp(ExceptionInformation *xp, signed_natural param)
1990{
1991  return gc_like_from_xp(xp, purify, param);
1992}
1993
1994int
1995impurify_from_xp(ExceptionInformation *xp, signed_natural param)
1996{
1997  return gc_like_from_xp(xp, impurify, param);
1998}
1999
2000/* Returns #bytes freed by invoking GC */
2001
2002int
2003gc_from_tcr(TCR *tcr, signed_natural param)
2004{
2005  area *a;
2006  BytePtr oldfree, newfree;
2007  BytePtr oldend, newend;
2008
2009#if 0
2010  fprintf(stderr, "Start GC  in 0x%lx\n", tcr);
2011#endif
2012  a = active_dynamic_area;
2013  oldend = a->high;
2014  oldfree = a->active;
2015  gc(tcr, param);
2016  newfree = a->active;
2017  newend = a->high;
2018#if 0
2019  fprintf(stderr, "End GC  in 0x%lx\n", tcr);
2020#endif
2021  return ((oldfree-newfree)+(newend-oldend));
2022}
2023
2024int
2025gc_from_xp(ExceptionInformation *xp, signed_natural param)
2026{
2027  int status = gc_like_from_xp(xp, gc_from_tcr, param);
2028
2029  freeGCptrs();
2030  return status;
2031}
2032
2033#ifdef DARWIN
2034
2035#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2036#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2037
2038#if USE_MACH_EXCEPTION_LOCK
2039pthread_mutex_t _mach_exception_lock, *mach_exception_lock;
2040#endif
2041extern void pseudo_sigreturn(void);
2042
2043
2044
2045#define LISP_EXCEPTIONS_HANDLED_MASK \
2046 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2047
2048/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2049#define NUM_LISP_EXCEPTIONS_HANDLED 4
2050
2051typedef struct {
2052  int foreign_exception_port_count;
2053  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2054  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2055  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2056  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2057} MACH_foreign_exception_state;
2058
2059
2060
2061
2062/*
2063  Mach's exception mechanism works a little better than its signal
2064  mechanism (and, not incidentally, it gets along with GDB a lot
2065  better.
2066
2067  Initially, we install an exception handler to handle each native
2068  thread's exceptions.  This process involves creating a distinguished
2069  thread which listens for kernel exception messages on a set of
2070  0 or more thread exception ports.  As threads are created, they're
2071  added to that port set; a thread's exception port is destroyed
2072  (and therefore removed from the port set) when the thread exits.
2073
2074  A few exceptions can be handled directly in the handler thread;
2075  others require that we resume the user thread (and that the
2076  exception thread resumes listening for exceptions.)  The user
2077  thread might eventually want to return to the original context
2078  (possibly modified somewhat.)
2079
2080  As it turns out, the simplest way to force the faulting user
2081  thread to handle its own exceptions is to do pretty much what
2082  signal() does: the exception handlng thread sets up a sigcontext
2083  on the user thread's stack and forces the user thread to resume
2084  execution as if a signal handler had been called with that
2085  context as an argument.  We can use a distinguished UUO at a
2086  distinguished address to do something like sigreturn(); that'll
2087  have the effect of resuming the user thread's execution in
2088  the (pseudo-) signal context.
2089
2090  Since:
2091    a) we have miles of code in C and in Lisp that knows how to
2092    deal with Linux sigcontexts
2093    b) Linux sigcontexts contain a little more useful information
2094    (the DAR, DSISR, etc.) than their Darwin counterparts
2095    c) we have to create a sigcontext ourselves when calling out
2096    to the user thread: we aren't really generating a signal, just
2097    leveraging existing signal-handling code.
2098
2099  we create a Linux sigcontext struct.
2100
2101  Simple ?  Hopefully from the outside it is ...
2102
2103  We want the process of passing a thread's own context to it to
2104  appear to be atomic: in particular, we don't want the GC to suspend
2105  a thread that's had an exception but has not yet had its user-level
2106  exception handler called, and we don't want the thread's exception
2107  context to be modified by a GC while the Mach handler thread is
2108  copying it around.  On Linux (and on Jaguar), we avoid this issue
2109  because (a) the kernel sets up the user-level signal handler and
2110  (b) the signal handler blocks signals (including the signal used
2111  by the GC to suspend threads) until tcr->xframe is set up.
2112
2113  The GC and the Mach server thread therefore contend for the lock
2114  "mach_exception_lock".  The Mach server thread holds the lock
2115  when copying exception information between the kernel and the
2116  user thread; the GC holds this lock during most of its execution
2117  (delaying exception processing until it can be done without
2118  GC interference.)
2119
2120*/
2121
2122#ifdef PPC64
2123#define C_REDZONE_LEN           320
2124#define C_STK_ALIGN             32
2125#else
2126#define C_REDZONE_LEN           224
2127#define C_STK_ALIGN             16
2128#endif
2129#define C_PARAMSAVE_LEN         64
2130#define C_LINKAGE_LEN           48
2131
2132#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2133
2134void
2135fatal_mach_error(char *format, ...);
2136
2137#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2138
2139
2140void
2141restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2142{
2143  int i, j;
2144  kern_return_t kret;
2145#if WORD_SIZE == 64
2146  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2147#else
2148  struct mcontext * mc = UC_MCONTEXT(pseudosigcontext);
2149#endif
2150
2151  /* Set the thread's FP state from the pseudosigcontext */
2152  kret = thread_set_state(thread,
2153                          x86_FLOAT_STATE64,
2154                          (thread_state_t)&(mc->__fs),
2155                          x86_FLOAT_STATE64_COUNT);
2156
2157  MACH_CHECK_ERROR("setting thread FP state", kret);
2158
2159  /* The thread'll be as good as new ... */
2160#if WORD_SIZE == 64
2161  kret = thread_set_state(thread,
2162                          x86_THREAD_STATE64,
2163                          (thread_state_t)&(mc->__ss),
2164                          x86_THREAD_STATE64_COUNT);
2165#else
2166  kret = thread_set_state(thread, 
2167                          x86_THREAD_STATE32,
2168                          (thread_state_t)&(mc->__ss),
2169                          x86_THREAD_STATE32_COUNT);
2170#endif
2171  MACH_CHECK_ERROR("setting thread state", kret);
2172} 
2173
2174/* This code runs in the exception handling thread, in response
2175   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2176   in response to a call to pseudo_sigreturn() from the specified
2177   user thread.
2178   Find that context (the user thread's R3 points to it), then
2179   use that context to set the user thread's state.  When this
2180   function's caller returns, the Mach kernel will resume the
2181   user thread.
2182*/
2183
2184kern_return_t
2185do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
2186{
2187  ExceptionInformation *xp;
2188
2189#ifdef DEBUG_MACH_EXCEPTIONS
2190  fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
2191#endif
2192  xp = tcr->pending_exception_context;
2193  if (xp) {
2194    tcr->pending_exception_context = NULL;
2195    tcr->valence = TCR_STATE_LISP;
2196    restore_mach_thread_state(thread, xp);
2197    raise_pending_interrupt(tcr);
2198  } else {
2199    Bug(NULL, "no xp here!\n");
2200  }
2201#ifdef DEBUG_MACH_EXCEPTIONS
2202  fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
2203#endif
2204  return KERN_SUCCESS;
2205} 
2206
2207ExceptionInformation *
2208create_thread_context_frame(mach_port_t thread, 
2209                            natural *new_stack_top,
2210                            siginfo_t **info_ptr,
2211                            TCR *tcr,
2212#ifdef X8664
2213                            x86_thread_state64_t *ts
2214#else
2215                            x86_thread_state_t *ts
2216#endif
2217                            )
2218{
2219  mach_msg_type_number_t thread_state_count;
2220  kern_return_t result;
2221  int i,j;
2222  ExceptionInformation *pseudosigcontext;
2223#ifdef X8664
2224  MCONTEXT_T mc;
2225#else
2226  struct mcontext *mc;
2227#endif
2228  natural stackp, backlink;
2229
2230 
2231  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2232  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2233  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
2234  if (info_ptr) {
2235    *info_ptr = (siginfo_t *)stackp;
2236  }
2237  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
2238  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
2239
2240  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
2241#ifdef X8664
2242  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
2243#else
2244  mc = (struct mcontext *) ptr_from_lispobj(stackp);
2245#endif
2246 
2247  memmove(&(mc->__ss),ts,sizeof(*ts));
2248
2249  thread_state_count = x86_FLOAT_STATE64_COUNT;
2250  thread_get_state(thread,
2251                   x86_FLOAT_STATE64,
2252                   (thread_state_t)&(mc->__fs),
2253                   &thread_state_count);
2254
2255
2256#ifdef X8664
2257  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
2258#else
2259  thread_state_count = x86_EXCEPTION_STATE_COUNT;
2260#endif
2261  thread_get_state(thread,
2262#ifdef X8664
2263                   x86_EXCEPTION_STATE64,
2264#else
2265                   x86_EXCEPTION_STATE,
2266#endif
2267                   (thread_state_t)&(mc->__es),
2268                   &thread_state_count);
2269
2270
2271  UC_MCONTEXT(pseudosigcontext) = mc;
2272  if (new_stack_top) {
2273    *new_stack_top = stackp;
2274  }
2275  return pseudosigcontext;
2276}
2277
2278/*
2279  This code sets up the user thread so that it executes a "pseudo-signal
2280  handler" function when it resumes.  Create a fake ucontext struct
2281  on the thread's stack and pass it as an argument to the pseudo-signal
2282  handler.
2283
2284  Things are set up so that the handler "returns to" pseudo_sigreturn(),
2285  which will restore the thread's context.
2286
2287  If the handler invokes code that throws (or otherwise never sigreturn()'s
2288  to the context), that's fine.
2289
2290  Actually, check that: throw (and variants) may need to be careful and
2291  pop the tcr's xframe list until it's younger than any frame being
2292  entered.
2293*/
2294
2295int
2296setup_signal_frame(mach_port_t thread,
2297                   void *handler_address,
2298                   int signum,
2299                   int code,
2300                   TCR *tcr,
2301#ifdef X8664
2302                   x86_thread_state64_t *ts
2303#else
2304                   x86_thread_state_t *ts
2305#endif
2306                   )
2307{
2308#ifdef X8664
2309  x86_thread_state64_t new_ts;
2310#else
2311  x86_thread_state_t new_ts;
2312#endif
2313  ExceptionInformation *pseudosigcontext;
2314  int i, j, old_valence = tcr->valence;
2315  kern_return_t result;
2316  natural stackp, *stackpp;
2317  siginfo_t *info;
2318
2319#ifdef DEBUG_MACH_EXCEPTIONS
2320  fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
2321#endif
2322  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
2323  bzero(info, sizeof(*info));
2324  info->si_code = code;
2325  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
2326  info->si_signo = signum;
2327  pseudosigcontext->uc_onstack = 0;
2328  pseudosigcontext->uc_sigmask = (sigset_t) 0;
2329  pseudosigcontext->uc_stack.ss_sp = 0;
2330  pseudosigcontext->uc_stack.ss_size = 0;
2331  pseudosigcontext->uc_stack.ss_flags = 0;
2332  pseudosigcontext->uc_link = NULL;
2333  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
2334  tcr->pending_exception_context = pseudosigcontext;
2335  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
2336 
2337
2338  /*
2339     It seems like we've created a  sigcontext on the thread's
2340     stack.  Set things up so that we call the handler (with appropriate
2341     args) when the thread's resumed.
2342  */
2343
2344  new_ts.__rip = (natural) handler_address;
2345  stackpp = (natural *)stackp;
2346  *--stackpp = (natural)pseudo_sigreturn;
2347  stackp = (natural)stackpp;
2348  new_ts.__rdi = signum;
2349  new_ts.__rsi = (natural)info;
2350  new_ts.__rdx = (natural)pseudosigcontext;
2351  new_ts.__rcx = (natural)tcr;
2352  new_ts.__r8 = (natural)old_valence;
2353  new_ts.__rsp = stackp;
2354  new_ts.__rflags = ts->__rflags;
2355
2356
2357#ifdef X8664
2358  thread_set_state(thread,
2359                   x86_THREAD_STATE64,
2360                   (thread_state_t)&new_ts,
2361                   x86_THREAD_STATE64_COUNT);
2362#else
2363  thread_set_state(thread, 
2364                   x86_THREAD_STATE,
2365                   (thread_state_t)&new_ts,
2366                   x86_THREAD_STATE_COUNT);
2367#endif
2368#ifdef DEBUG_MACH_EXCEPTIONS
2369  fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
2370#endif
2371  return 0;
2372}
2373
2374
2375
2376
2377
2378
2379/*
2380  This function runs in the exception handling thread.  It's
2381  called (by this precise name) from the library function "exc_server()"
2382  when the thread's exception ports are set up.  (exc_server() is called
2383  via mach_msg_server(), which is a function that waits for and dispatches
2384  on exception messages from the Mach kernel.)
2385
2386  This checks to see if the exception was caused by a pseudo_sigreturn()
2387  UUO; if so, it arranges for the thread to have its state restored
2388  from the specified context.
2389
2390  Otherwise, it tries to map the exception to a signal number and
2391  arranges that the thread run a "pseudo signal handler" to handle
2392  the exception.
2393
2394  Some exceptions could and should be handled here directly.
2395*/
2396
2397/* We need the thread's state earlier on x86_64 than we did on PPC;
2398   the PC won't fit in code_vector[1].  We shouldn't try to get it
2399   lazily (via catch_exception_raise_state()); until we own the
2400   exception lock, we shouldn't have it in userspace (since a GCing
2401   thread wouldn't know that we had our hands on it.)
2402*/
2403
2404#ifdef X8664
2405#define ts_pc(t) t.__rip
2406#else
2407#define ts_pc(t) t.eip
2408#endif
2409
2410#ifdef DARWIN_USE_PSEUDO_SIGRETURN
2411#define DARWIN_EXCEPTION_HANDLER signal_handler
2412#else
2413#define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler
2414#endif
2415
2416
2417kern_return_t
2418catch_exception_raise(mach_port_t exception_port,
2419                      mach_port_t thread,
2420                      mach_port_t task, 
2421                      exception_type_t exception,
2422                      exception_data_t code_vector,
2423                      mach_msg_type_number_t code_count)
2424{
2425  int signum = 0, code = *code_vector, code1;
2426  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
2427  kern_return_t kret, call_kret;
2428#ifdef X8664
2429  x86_thread_state64_t ts;
2430#else
2431  x86_thread_state_t ts;
2432#endif
2433  mach_msg_type_number_t thread_state_count;
2434
2435
2436
2437#ifdef DEBUG_MACH_EXCEPTIONS
2438  fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
2439#endif
2440
2441
2442  if (
2443#if USE_MACH_EXCEPTION_LOCK
2444      pthread_mutex_trylock(mach_exception_lock) == 0
2445#else
2446      1
2447#endif
2448      ) {
2449#ifdef X8664
2450    do {
2451      thread_state_count = x86_THREAD_STATE64_COUNT;
2452      call_kret = thread_get_state(thread,
2453                                   x86_THREAD_STATE64,
2454                                   (thread_state_t)&ts,
2455                                   &thread_state_count);
2456    } while (call_kret == KERN_ABORTED);
2457  MACH_CHECK_ERROR("getting thread state",call_kret);
2458#else
2459    thread_state_count = x86_THREAD_STATE_COUNT;
2460    thread_get_state(thread,
2461                     x86_THREAD_STATE,
2462                     (thread_state_t)&ts,
2463                     &thread_state_count);
2464#endif
2465    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
2466      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2467    } 
2468    if ((code == EXC_I386_GPFLT) &&
2469        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
2470      kret = do_pseudo_sigreturn(thread, tcr);
2471#if 0
2472      fprintf(stderr, "Exception return in 0x%x\n",tcr);
2473#endif
2474    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
2475      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
2476      kret = 17;
2477    } else {
2478      switch (exception) {
2479      case EXC_BAD_ACCESS:
2480        if (code == EXC_I386_GPFLT) {
2481          signum = SIGSEGV;
2482        } else {
2483          signum = SIGBUS;
2484        }
2485        break;
2486       
2487      case EXC_BAD_INSTRUCTION:
2488        if (code == EXC_I386_GPFLT) {
2489          signum = SIGSEGV;
2490        } else {
2491          signum = SIGILL;
2492        }
2493        break;
2494         
2495      case EXC_SOFTWARE:
2496        signum = SIGILL;
2497        break;
2498       
2499      case EXC_ARITHMETIC:
2500        signum = SIGFPE;
2501        break;
2502       
2503      default:
2504        break;
2505      }
2506      if (signum) {
2507        kret = setup_signal_frame(thread,
2508                                  (void *)DARWIN_EXCEPTION_HANDLER,
2509                                  signum,
2510                                  code,
2511                                  tcr, 
2512                                  &ts);
2513#if 0
2514        fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
2515#endif
2516       
2517      } else {
2518        kret = 17;
2519      }
2520    }
2521#if USE_MACH_EXCEPTION_LOCK
2522#ifdef DEBUG_MACH_EXCEPTIONS
2523    fprintf(stderr, "releasing Mach exception lock in exception thread\n");
2524#endif
2525    pthread_mutex_unlock(mach_exception_lock);
2526#endif
2527  } else {
2528    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2529     
2530#if 0
2531    fprintf(stderr, "deferring pending exception in 0x%x\n", tcr);
2532#endif
2533    kret = KERN_SUCCESS;
2534    if (tcr == gc_tcr) {
2535      int i;
2536      write(1, "exception in GC thread. Sleeping for 60 seconds\n",sizeof("exception in GC thread.  Sleeping for 60 seconds\n"));
2537      for (i = 0; i < 60; i++) {
2538        sleep(1);
2539      }
2540      _exit(EX_SOFTWARE);
2541    }
2542  }
2543  return kret;
2544}
2545
2546
2547
2548
2549static mach_port_t mach_exception_thread = (mach_port_t)0;
2550
2551
2552/*
2553  The initial function for an exception-handling thread.
2554*/
2555
2556void *
2557exception_handler_proc(void *arg)
2558{
2559  extern boolean_t exc_server();
2560  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
2561
2562  mach_exception_thread = pthread_mach_thread_np(pthread_self());
2563  mach_msg_server(exc_server, 256, p, 0);
2564  /* Should never return. */
2565  abort();
2566}
2567
2568
2569
2570void
2571mach_exception_thread_shutdown()
2572{
2573  kern_return_t kret;
2574
2575  fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
2576  kret = thread_terminate(mach_exception_thread);
2577  if (kret != KERN_SUCCESS) {
2578    fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
2579  }
2580}
2581
2582
2583mach_port_t
2584mach_exception_port_set()
2585{
2586  static mach_port_t __exception_port_set = MACH_PORT_NULL;
2587  kern_return_t kret; 
2588  if (__exception_port_set == MACH_PORT_NULL) {
2589#if USE_MACH_EXCEPTION_LOCK
2590    mach_exception_lock = &_mach_exception_lock;
2591    pthread_mutex_init(mach_exception_lock, NULL);
2592#endif
2593
2594    kret = mach_port_allocate(mach_task_self(),
2595                              MACH_PORT_RIGHT_PORT_SET,
2596                              &__exception_port_set);
2597    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
2598    create_system_thread(0,
2599                         NULL,
2600                         exception_handler_proc, 
2601                         (void *)((natural)__exception_port_set));
2602  }
2603  return __exception_port_set;
2604}
2605
2606/*
2607  Setup a new thread to handle those exceptions specified by
2608  the mask "which".  This involves creating a special Mach
2609  message port, telling the Mach kernel to send exception
2610  messages for the calling thread to that port, and setting
2611  up a handler thread which listens for and responds to
2612  those messages.
2613
2614*/
2615
2616/*
2617  Establish the lisp thread's TCR as its exception port, and determine
2618  whether any other ports have been established by foreign code for
2619  exceptions that lisp cares about.
2620
2621  If this happens at all, it should happen on return from foreign
2622  code and on entry to lisp code via a callback.
2623
2624  This is a lot of trouble (and overhead) to support Java, or other
2625  embeddable systems that clobber their caller's thread exception ports.
2626 
2627*/
2628kern_return_t
2629tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
2630{
2631  kern_return_t kret;
2632  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
2633  int i;
2634  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
2635  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
2636  exception_mask_t mask = 0;
2637
2638  kret = thread_swap_exception_ports(thread,
2639                                     LISP_EXCEPTIONS_HANDLED_MASK,
2640                                     lisp_port,
2641                                     EXCEPTION_DEFAULT,
2642                                     THREAD_STATE_NONE,
2643                                     fxs->masks,
2644                                     &n,
2645                                     fxs->ports,
2646                                     fxs->behaviors,
2647                                     fxs->flavors);
2648  if (kret == KERN_SUCCESS) {
2649    fxs->foreign_exception_port_count = n;
2650    for (i = 0; i < n; i ++) {
2651      foreign_port = fxs->ports[i];
2652
2653      if ((foreign_port != lisp_port) &&
2654          (foreign_port != MACH_PORT_NULL)) {
2655        mask |= fxs->masks[i];
2656      }
2657    }
2658    tcr->foreign_exception_status = (int) mask;
2659  }
2660  return kret;
2661}
2662
2663kern_return_t
2664tcr_establish_lisp_exception_port(TCR *tcr)
2665{
2666  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
2667}
2668
2669/*
2670  Do this when calling out to or returning from foreign code, if
2671  any conflicting foreign exception ports were established when we
2672  last entered lisp code.
2673*/
2674kern_return_t
2675restore_foreign_exception_ports(TCR *tcr)
2676{
2677  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
2678 
2679  if (m) {
2680    MACH_foreign_exception_state *fxs  = 
2681      (MACH_foreign_exception_state *) tcr->native_thread_info;
2682    int i, n = fxs->foreign_exception_port_count;
2683    exception_mask_t tm;
2684
2685    for (i = 0; i < n; i++) {
2686      if ((tm = fxs->masks[i]) & m) {
2687        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
2688                                   tm,
2689                                   fxs->ports[i],
2690                                   fxs->behaviors[i],
2691                                   fxs->flavors[i]);
2692      }
2693    }
2694  }
2695}
2696                                   
2697
2698/*
2699  This assumes that a Mach port (to be used as the thread's exception port) whose
2700  "name" matches the TCR's 32-bit address has already been allocated.
2701*/
2702
2703kern_return_t
2704setup_mach_exception_handling(TCR *tcr)
2705{
2706  mach_port_t
2707    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
2708    target_thread = pthread_mach_thread_np((pthread_t)ptr_from_lispobj(tcr->osid)),
2709    task_self = mach_task_self();
2710  kern_return_t kret;
2711
2712  kret = mach_port_insert_right(task_self,
2713                                thread_exception_port,
2714                                thread_exception_port,
2715                                MACH_MSG_TYPE_MAKE_SEND);
2716  MACH_CHECK_ERROR("adding send right to exception_port",kret);
2717
2718  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
2719  if (kret == KERN_SUCCESS) {
2720    mach_port_t exception_port_set = mach_exception_port_set();
2721
2722    kret = mach_port_move_member(task_self,
2723                                 thread_exception_port,
2724                                 exception_port_set);
2725  }
2726  return kret;
2727}
2728
2729void
2730darwin_exception_init(TCR *tcr)
2731{
2732  void tcr_monitor_exception_handling(TCR*, Boolean);
2733  kern_return_t kret;
2734  MACH_foreign_exception_state *fxs = 
2735    calloc(1, sizeof(MACH_foreign_exception_state));
2736 
2737  tcr->native_thread_info = (void *) fxs;
2738
2739  if ((kret = setup_mach_exception_handling(tcr))
2740      != KERN_SUCCESS) {
2741    fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
2742    terminate_lisp();
2743  }
2744  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
2745  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
2746}
2747
2748/*
2749  The tcr is the "name" of the corresponding thread's exception port.
2750  Destroying the port should remove it from all port sets of which it's
2751  a member (notably, the exception port set.)
2752*/
2753void
2754darwin_exception_cleanup(TCR *tcr)
2755{
2756  void *fxs = tcr->native_thread_info;
2757  extern Boolean use_mach_exception_handling;
2758
2759  if (fxs) {
2760    tcr->native_thread_info = NULL;
2761    free(fxs);
2762  }
2763  if (use_mach_exception_handling) {
2764    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2765    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2766  }
2767}
2768
2769
2770Boolean
2771suspend_mach_thread(mach_port_t mach_thread)
2772{
2773  kern_return_t status;
2774  Boolean aborted = false;
2775 
2776  do {
2777    aborted = false;
2778    status = thread_suspend(mach_thread);
2779    if (status == KERN_SUCCESS) {
2780      status = thread_abort_safely(mach_thread);
2781      if (status == KERN_SUCCESS) {
2782        aborted = true;
2783      } else {
2784        fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
2785        thread_resume(mach_thread);
2786      }
2787    } else {
2788      return false;
2789    }
2790  } while (! aborted);
2791  return true;
2792}
2793
2794/*
2795  Only do this if pthread_kill indicated that the pthread isn't
2796  listening to signals anymore, as can happen as soon as pthread_exit()
2797  is called on Darwin.  The thread could still call out to lisp as it
2798  is exiting, so we need another way to suspend it in this case.
2799*/
2800Boolean
2801mach_suspend_tcr(TCR *tcr)
2802{
2803  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
2804  ExceptionInformation *pseudosigcontext;
2805  Boolean result = false;
2806 
2807  result = suspend_mach_thread(mach_thread);
2808  if (result) {
2809    mach_msg_type_number_t thread_state_count;
2810#ifdef X8664
2811    x86_thread_state64_t ts;
2812    thread_state_count = x86_THREAD_STATE64_COUNT;
2813    thread_get_state(mach_thread,
2814                     x86_THREAD_STATE64,
2815                     (thread_state_t)&ts,
2816                     &thread_state_count);
2817#else
2818    x86_thread_state_t ts;
2819    thread_state_count = x86_THREAD_STATE_COUNT;
2820    thread_get_state(mach_thread,
2821                     x86_THREAD_STATE,
2822                     (thread_state_t)&ts,
2823                     &thread_state_count);
2824#endif
2825
2826    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
2827    pseudosigcontext->uc_onstack = 0;
2828    pseudosigcontext->uc_sigmask = (sigset_t) 0;
2829    tcr->suspend_context = pseudosigcontext;
2830  }
2831  return result;
2832}
2833
2834void
2835mach_resume_tcr(TCR *tcr)
2836{
2837  ExceptionInformation *xp;
2838  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
2839 
2840  xp = tcr->suspend_context;
2841#ifdef DEBUG_MACH_EXCEPTIONS
2842  fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
2843          tcr, tcr->pending_exception_context);
2844#endif
2845  tcr->suspend_context = NULL;
2846  restore_mach_thread_state(mach_thread, xp);
2847#ifdef DEBUG_MACH_EXCEPTIONS
2848  fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
2849          tcr, tcr->pending_exception_context);
2850#endif
2851  thread_resume(mach_thread);
2852}
2853
2854void
2855fatal_mach_error(char *format, ...)
2856{
2857  va_list args;
2858  char s[512];
2859 
2860
2861  va_start(args, format);
2862  vsnprintf(s, sizeof(s),format, args);
2863  va_end(args);
2864
2865  Fatal("Mach error", s);
2866}
2867
2868
2869
2870
2871#endif
Note: See TracBrowser for help on using the repository browser.