source: branches/1.2-devel/ccl/lisp-kernel/x86-exceptions.c @ 7979

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

Don't restart system calls automatically (this affects #_read at
least) when they're interrupted.

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