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

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

On a write to the (usually write-protected) pure area, just unprotect
the page.

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