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

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

Skip over GC suspend traps.

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