source: branches/ia32/lisp-kernel/x86-exceptions.c @ 7287

Last change on this file since 7287 was 7287, checked in by rme, 13 years ago

Merged trunk changes r7244:7286

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