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

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

Complain if lisp stack pointer isn't in lisp stack when calling out
for process-interrupt.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 77.0 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, false, "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, false,  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    Boolean foreign = (old_valence != TCR_STATE_LISP);
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#if 1
1143  if (tcr->valence != TCR_STATE_LISP) {
1144    FBug(context, "exception in foreign context");
1145  }
1146#endif
1147  {
1148    area *vs = tcr->vs_area;
1149    BytePtr current_sp = (BytePtr) current_stack_pointer();
1150
1151    if ((current_sp >= vs->low) &&
1152        (current_sp < vs->high)) {
1153      handle_signal_on_foreign_stack(tcr,
1154                                     signal_handler,
1155                                     signum,
1156                                     info,
1157                                     context,
1158                                     (LispObj)__builtin_return_address(0)
1159#ifdef DARWIN_GS_HACK
1160                                     , false
1161#endif
1162
1163                                     );
1164    } else {
1165      signal_handler(signum, info, context, tcr, 0);
1166    }
1167  }
1168}
1169
1170#else
1171void
1172altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1173{
1174  TCR* tcr = get_tcr(true);
1175#if 1
1176  if (tcr->valence != TCR_STATE_LISP) {
1177    FBug(context, "exception in foreign context");
1178  }
1179#endif
1180  handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1181#ifdef DARWIN_GS_HACK
1182                                 , false
1183#endif
1184);
1185}
1186#endif
1187
1188void
1189interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1190{
1191#ifdef DARWIN_GS_HACK
1192  Boolean gs_was_tcr = ensure_gs_pthread();
1193#endif
1194  TCR *tcr = get_interrupt_tcr(false);
1195  if (tcr) {
1196    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1197        (tcr->valence != TCR_STATE_LISP) ||
1198        (tcr->unwinding != 0)) {
1199      tcr->interrupt_pending = (1L << (nbits_in_word - 1L));
1200    } else {
1201      LispObj cmain = nrs_CMAIN.vcell;
1202
1203      if ((fulltag_of(cmain) == fulltag_misc) &&
1204          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1205        /*
1206           This thread can (allegedly) take an interrupt now.
1207        */
1208
1209        xframe_list xframe_link;
1210        int old_valence;
1211        signed_natural alloc_displacement = 0;
1212        LispObj
1213          *next_tsp = tcr->next_tsp,
1214          *save_tsp = tcr->save_tsp,
1215          *p,
1216          q;
1217        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1218
1219        {
1220          BytePtr interrupted_sp = (BytePtr)xpGPR(context, Isp);
1221          area *vs_area = tcr->vs_area;
1222
1223          if ((interrupted_sp < vs_area->low) ||
1224              (interrupted_sp > vs_area->high)) {
1225            Bug(context, "lisp stack pointer not in lisp stack");
1226          }
1227        }
1228         
1229        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1230           
1231        if (next_tsp != save_tsp) {
1232          tcr->next_tsp = save_tsp;
1233        } else {
1234          next_tsp = NULL;
1235        }
1236        /* have to do this before allowing interrupts */
1237        pc_luser_xp(context, tcr, &alloc_displacement);
1238        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1239        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1240        handle_exception(signum, info, context, tcr, old_valence);
1241        if (alloc_displacement) {
1242          tcr->save_allocptr -= alloc_displacement;
1243        }
1244        if (next_tsp) {
1245          tcr->next_tsp = next_tsp;
1246          p = next_tsp;
1247          while (p != save_tsp) {
1248            *p++ = 0;
1249          }
1250          q = (LispObj)save_tsp;
1251          *next_tsp = q;
1252        }
1253        tcr->flags |= old_foreign_exception;
1254        unlock_exception_lock_in_handler(tcr);
1255        exit_signal_handler(tcr, old_valence);
1256      }
1257    }
1258  }
1259#ifdef DARWIN_GS_HACK
1260  if (gs_was_tcr) {
1261    set_gs_address(tcr);
1262  }
1263#endif
1264  SIGRETURN(context);
1265}
1266
1267#ifndef USE_SIGALTSTACK
1268void
1269arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1270{
1271#ifdef DARWIN_GS_HACK
1272  Boolean gs_was_tcr = ensure_gs_pthread();
1273#endif
1274  TCR *tcr = get_interrupt_tcr(false);
1275  area *vs = tcr->vs_area;
1276  BytePtr current_sp = (BytePtr) current_stack_pointer();
1277
1278  if ((current_sp >= vs->low) &&
1279      (current_sp < vs->high)) {
1280    handle_signal_on_foreign_stack(tcr,
1281                                   interrupt_handler,
1282                                   signum,
1283                                   info,
1284                                   context,
1285                                   (LispObj)__builtin_return_address(0)
1286#ifdef DARWIN_GS_HACK
1287                                   ,gs_was_tcr
1288#endif
1289                                   );
1290  } else {
1291    /* If we're not on the value stack, we pretty much have to be on
1292       the C stack.  Just run the handler. */
1293#ifdef DARWIN_GS_HACK
1294    if (gs_was_tcr) {
1295      set_gs_address(tcr);
1296    }
1297#endif
1298    interrupt_handler(signum, info, context);
1299  }
1300}
1301
1302#else /* altstack works */
1303 
1304void
1305altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1306{
1307#ifdef DARWIN_GS_HACK
1308  Boolean gs_was_tcr = ensure_gs_pthread();
1309#endif
1310  TCR *tcr = get_interrupt_tcr(false);
1311  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1312#ifdef DARWIN_GS_HACK
1313                                 ,gs_was_tcr
1314#endif
1315                                 );
1316}
1317
1318#endif
1319
1320
1321void
1322install_signal_handler(int signo, void * handler)
1323{
1324  struct sigaction sa;
1325 
1326  sa.sa_sigaction = (void *)handler;
1327  sigfillset(&sa.sa_mask);
1328#ifdef FREEBSD
1329  /* Strange FreeBSD behavior wrt synchronous signals */
1330  sigdelset(&sa.sa_mask,SIGNUM_FOR_INTN_TRAP);
1331  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1332  sigdelset(&sa.sa_mask,SIGILL);
1333  sigdelset(&sa.sa_mask,SIGFPE);
1334  sigdelset(&sa.sa_mask,SIGSEGV);
1335#endif
1336  sa.sa_flags = 
1337    SA_RESTART
1338#ifdef USE_SIGALTSTACK
1339    | SA_ONSTACK
1340#endif
1341    | SA_SIGINFO;
1342
1343  sigaction(signo, &sa, NULL);
1344}
1345
1346
1347void
1348install_pmcl_exception_handlers()
1349{
1350#ifndef DARWIN 
1351  void *handler = (void *)
1352#ifdef USE_SIGALTSTACK
1353    altstack_signal_handler
1354#else
1355    arbstack_signal_handler;
1356#endif
1357  ;
1358  install_signal_handler(SIGILL, handler);
1359 
1360  install_signal_handler(SIGBUS, handler);
1361  install_signal_handler(SIGSEGV,handler);
1362  install_signal_handler(SIGFPE, handler);
1363#else
1364  install_signal_handler(SIGTRAP,bogus_signal_handler);
1365  install_signal_handler(SIGILL, bogus_signal_handler);
1366 
1367  install_signal_handler(SIGBUS, bogus_signal_handler);
1368  install_signal_handler(SIGSEGV,bogus_signal_handler);
1369  install_signal_handler(SIGFPE, bogus_signal_handler);
1370  /*  9.0.0d8 generates spurious SIGSYS from mach_msg_trap */
1371  install_signal_handler(SIGSYS, bogus_signal_handler);
1372#endif
1373 
1374  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT,
1375#ifdef USE_SIGALTSTACK
1376                         altstack_interrupt_handler
1377#else
1378                         arbstack_interrupt_handler
1379#endif
1380);
1381  signal(SIGPIPE, SIG_IGN);
1382}
1383
1384#ifndef USE_SIGALTSTACK
1385void
1386arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1387{
1388#ifdef DARWIN_GS_HACK
1389  Boolean gs_was_tcr = ensure_gs_pthread();
1390#endif
1391  TCR *tcr = get_interrupt_tcr(false);
1392  area *vs = tcr->vs_area;
1393  BytePtr current_sp = (BytePtr) current_stack_pointer();
1394
1395  if ((current_sp >= vs->low) &&
1396      (current_sp < vs->high)) {
1397    handle_signal_on_foreign_stack(tcr,
1398                                   suspend_resume_handler,
1399                                   signum,
1400                                   info,
1401                                   context,
1402                                   (LispObj)__builtin_return_address(0)
1403#ifdef DARWIN_GS_HACK
1404                                   ,gs_was_tcr
1405#endif
1406                                   );
1407  } else {
1408    /* If we're not on the value stack, we pretty much have to be on
1409       the C stack.  Just run the handler. */
1410#ifdef DARWIN_GS_HACK
1411    if (gs_was_tcr) {
1412      set_gs_address(tcr);
1413    }
1414#endif
1415    suspend_resume_handler(signum, info, context);
1416  }
1417}
1418
1419
1420#else /* altstack works */
1421void
1422altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1423{
1424#ifdef DARWIN_GS_HACK
1425  Boolean gs_was_tcr = ensure_gs_pthread();
1426#endif
1427  TCR* tcr = get_tcr(true);
1428  handle_signal_on_foreign_stack(tcr,
1429                                 suspend_resume_handler,
1430                                 signum,
1431                                 info,
1432                                 context,
1433                                 (LispObj)__builtin_return_address(0)
1434#ifdef DARWIN_GS_HACK
1435                                 ,gs_was_tcr
1436#endif
1437                                 );
1438}
1439
1440#endif
1441
1442void
1443quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1444{
1445  TCR *tcr = get_tcr(false);
1446  area *a;
1447  sigset_t mask;
1448 
1449  sigemptyset(&mask);
1450
1451
1452  if (tcr) {
1453    tcr->valence = TCR_STATE_FOREIGN;
1454    a = tcr->vs_area;
1455    if (a) {
1456      a->active = a->high;
1457    }
1458    a = tcr->ts_area;
1459    if (a) {
1460      a->active = a->high;
1461    }
1462    a = tcr->cs_area;
1463    if (a) {
1464      a->active = a->high;
1465    }
1466  }
1467 
1468  pthread_sigmask(SIG_SETMASK,&mask,NULL);
1469  pthread_exit(NULL);
1470}
1471
1472#ifndef USE_SIGALTSTACK
1473arbstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1474{
1475#ifdef DARWIN_GS_HACK
1476  Boolean gs_was_tcr = ensure_gs_pthread();
1477#endif
1478  TCR *tcr = get_interrupt_tcr(false);
1479  area *vs = tcr->vs_area;
1480  BytePtr current_sp = (BytePtr) current_stack_pointer();
1481
1482  if ((current_sp >= vs->low) &&
1483      (current_sp < vs->high)) {
1484    handle_signal_on_foreign_stack(tcr,
1485                                   quit_handler,
1486                                   signum,
1487                                   info,
1488                                   context,
1489                                   (LispObj)__builtin_return_address(0)
1490#ifdef DARWIN_GS_HACK
1491                                   ,gs_was_tcr
1492#endif
1493                                   );
1494  } else {
1495    /* If we're not on the value stack, we pretty much have to be on
1496       the C stack.  Just run the handler. */
1497#ifdef DARWIN_GS_HACK
1498    if (gs_was_tcr) {
1499      set_gs_address(tcr);
1500    }
1501#endif
1502    quit_handler(signum, info, context);
1503  }
1504}
1505
1506
1507#else
1508void
1509altstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1510{
1511#ifdef DARWIN_GS_HACK
1512  Boolean gs_was_tcr = ensure_gs_pthread();
1513#endif
1514  TCR* tcr = get_tcr(true);
1515  handle_signal_on_foreign_stack(tcr,
1516                                 quit_handler,
1517                                 signum,
1518                                 info,
1519                                 context,
1520                                 (LispObj)__builtin_return_address(0)
1521#ifdef DARWIN_GS_HACK
1522                                 ,gs_was_tcr
1523#endif
1524                                 );
1525}
1526#endif
1527
1528#ifdef USE_SIGALTSTACK
1529#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
1530#define QUIT_HANDLER altstack_quit_handler
1531#else
1532#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
1533#define QUIT_HANDLER arbstack_quit_handler
1534#endif
1535
1536void
1537thread_signal_setup()
1538{
1539  thread_suspend_signal = SIG_SUSPEND_THREAD;
1540  thread_resume_signal = SIG_RESUME_THREAD;
1541
1542  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
1543  install_signal_handler(thread_resume_signal, (void *)SUSPEND_RESUME_HANDLER);
1544  install_signal_handler(SIGQUIT, (void *)QUIT_HANDLER);
1545}
1546
1547
1548void
1549enable_fp_exceptions()
1550{
1551}
1552
1553void
1554exception_init()
1555{
1556  install_pmcl_exception_handlers();
1557}
1558
1559void
1560adjust_exception_pc(ExceptionInformation *xp, int delta)
1561{
1562  xpPC(xp) += delta;
1563}
1564
1565/*
1566  Lower (move toward 0) the "end" of the soft protected area associated
1567  with a by a page, if we can.
1568*/
1569
1570void
1571
1572adjust_soft_protection_limit(area *a)
1573{
1574  char *proposed_new_soft_limit = a->softlimit - 4096;
1575  protected_area_ptr p = a->softprot;
1576 
1577  if (proposed_new_soft_limit >= (p->start+16384)) {
1578    p->end = proposed_new_soft_limit;
1579    p->protsize = p->end-p->start;
1580    a->softlimit = proposed_new_soft_limit;
1581  }
1582  protect_area(p);
1583}
1584
1585void
1586restore_soft_stack_limit(unsigned restore_tsp)
1587{
1588  TCR *tcr = get_tcr(false);
1589  area *a;
1590 
1591  if (restore_tsp) {
1592    a = tcr->ts_area;
1593  } else {
1594    a = tcr->vs_area;
1595  }
1596  adjust_soft_protection_limit(a);
1597}
1598
1599
1600#ifdef USE_SIGALTSTACK
1601void
1602setup_sigaltstack(area *a)
1603{
1604  stack_t stack;
1605  stack.ss_sp = a->low;
1606  a->low += SIGSTKSZ*8;
1607  stack.ss_size = SIGSTKSZ*8;
1608  stack.ss_flags = 0;
1609  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
1610  if (sigaltstack(&stack, NULL) != 0) {
1611    perror("sigaltstack");
1612    exit(-1);
1613  }
1614}
1615#endif
1616
1617extern opcode egc_write_barrier_start, egc_write_barrier_end,
1618  egc_store_node_conditional_success_test,egc_store_node_conditional,
1619  egc_set_hash_key, egc_gvset, egc_rplacd;
1620
1621/* We use (extremely) rigidly defined instruction sequences for consing,
1622   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
1623   while consing.
1624
1625   Note that we can usually identify which of these instructions is about
1626   to be executed by a stopped thread without comparing all of the bytes
1627   to those at the stopped program counter, but we generally need to
1628   know the sizes of each of these instructions.
1629*/
1630
1631opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
1632  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00};
1633opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
1634  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00};
1635opcode branch_around_alloc_trap_instruction[] =
1636  {0x7f,0x02};
1637opcode alloc_trap_instruction[] =
1638  {0xcd,0xc5};
1639opcode clear_tcr_save_allocptr_tag_instruction[] =
1640  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0};
1641opcode set_allocptr_header_instruction[] =
1642  {0x48,0x89,0x43,0xf3};
1643
1644
1645alloc_instruction_id
1646recognize_alloc_instruction(pc program_counter)
1647{
1648  switch(program_counter[0]) {
1649  case 0xcd: return ID_alloc_trap_instruction;
1650  case 0x7f: return ID_branch_around_alloc_trap_instruction;
1651  case 0x48: return ID_set_allocptr_header_instruction;
1652  case 0x65: 
1653    switch(program_counter[1]) {
1654    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
1655    case 0x48:
1656      switch(program_counter[2]) {
1657      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
1658      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
1659      }
1660    }
1661  }
1662  return ID_unrecognized_alloc_instruction;
1663}
1664     
1665 
1666void
1667pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
1668{
1669  pc program_counter = (pc)xpPC(xp);
1670  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
1671
1672  if (allocptr_tag != 0) {
1673    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
1674    signed_natural
1675      disp = (allocptr_tag == fulltag_cons) ?
1676      sizeof(cons) - fulltag_cons :
1677      xpGPR(xp,Iimm1);
1678    LispObj new_vector;
1679
1680    if ((state == ID_unrecognized_alloc_instruction) ||
1681        ((state == ID_set_allocptr_header_instruction) &&
1682         (allocptr_tag != fulltag_misc))) {
1683      Bug(xp, "Can't determine state of thread 0x%lx, interrupted during memory allocation", tcr);
1684    }
1685    switch(state) {
1686    case ID_set_allocptr_header_instruction:
1687      /* We were consing a vector and we won.  Set the header of the new vector
1688         (in the allocptr register) to the header in %rax and skip over this
1689         instruction, then fall into the next case. */
1690      new_vector = xpGPR(xp,Iallocptr);
1691      deref(new_vector,0) = xpGPR(xp,Iimm0);
1692
1693      xpPC(xp) += sizeof(set_allocptr_header_instruction);
1694      /* Fall thru */
1695    case ID_clear_tcr_save_allocptr_tag_instruction:
1696      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1697      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1698      break;
1699    case ID_alloc_trap_instruction:
1700      /* If we're looking at another thread, we're pretty much committed to
1701         taking the trap.  We don't want the allocptr register to be pointing
1702         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
1703         was determined above.
1704      */
1705      if (interrupt_displacement == NULL) {
1706        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
1707        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
1708      } else {
1709        /* Back out, and tell the caller how to resume the allocation attempt */
1710        *interrupt_displacement = disp;
1711        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1712        tcr->save_allocptr += disp;
1713        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
1714                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1715                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1716      }
1717      break;
1718    case ID_branch_around_alloc_trap_instruction:
1719      /* If we'd take the branch - which is a 'jg" - around the alloc trap,
1720         we might as well finish the allocation.  Otherwise, back out of the
1721         attempt. */
1722      {
1723        int flags = (int)xpGPR(xp,Iflags);
1724       
1725        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
1726            ((flags & (1 << X86_SIGN_FLAG_BIT)) ==
1727             (flags & (1 << X86_CARRY_FLAG_BIT)))) {
1728          /* The branch (jg) would have been taken.  Emulate taking it. */
1729          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
1730                       sizeof(alloc_trap_instruction));
1731          if (allocptr_tag == fulltag_misc) {
1732            /* Slap the header on the new uvector */
1733            new_vector = xpGPR(xp,Iallocptr);
1734            deref(new_vector,0) = xpGPR(xp,Iimm0);
1735            xpPC(xp) += sizeof(set_allocptr_header_instruction);
1736          }
1737          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1738          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1739        } else {
1740          /* Back up */
1741          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1742                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1743          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1744          if (interrupt_displacement) {
1745            *interrupt_displacement = disp;
1746            tcr->save_allocptr += disp;
1747          } else {
1748            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1749          }
1750        }
1751      }
1752      break;
1753    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
1754      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1755      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
1756      /* Fall through */
1757    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
1758      if (interrupt_displacement) {
1759        tcr->save_allocptr += disp;
1760        *interrupt_displacement = disp;
1761      } else {
1762        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1763      }
1764      break;
1765    }
1766    return;
1767  }
1768  if ((program_counter >= &egc_write_barrier_start) &&
1769      (program_counter < &egc_write_barrier_end)) {
1770    LispObj *ea = 0, val, root;
1771    bitvector refbits = (bitvector)(lisp_global(REFBITS));
1772    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
1773
1774    if (program_counter >= &egc_store_node_conditional) {
1775      if ((program_counter < &egc_store_node_conditional_success_test) ||
1776          ((program_counter == &egc_store_node_conditional_success_test) &&
1777           !(xpGPR(xp, Iflags) & (1 << X86_ZERO_FLAG_BIT)))) {
1778        /* Back up the PC, try again */
1779        xpPC(xp) = (LispObj) &egc_store_node_conditional;
1780        return;
1781      }
1782      /* The conditional store succeeded.  Set the refbit, return to ra0 */
1783      val = xpGPR(xp,Iarg_z);
1784      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
1785                                                       xpGPR(xp,Itemp0))));
1786      xpGPR(xp,Iarg_z) = t_value;
1787      need_store = false;
1788    } else if (program_counter >= &egc_set_hash_key) {
1789      root = xpGPR(xp,Iarg_x);
1790      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
1791      val = xpGPR(xp,Iarg_z);
1792      need_memoize_root = true;
1793    } else if (program_counter >= &egc_gvset) {
1794      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
1795      val = xpGPR(xp,Iarg_z);
1796    } else if (program_counter >= &egc_rplacd) {
1797      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
1798      val = xpGPR(xp,Iarg_z);
1799    } else {                      /* egc_rplaca */
1800      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
1801      val = xpGPR(xp,Iarg_z);
1802    }
1803    if (need_store) {
1804      *ea = val;
1805    }
1806    if (need_check_memo) {
1807      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
1808      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
1809          ((LispObj)ea < val)) {
1810        atomic_set_bit(refbits, bitnumber);
1811        if (need_memoize_root) {
1812          bitnumber = area_dnode(root, lisp_global(HEAP_START));
1813          atomic_set_bit(refbits, bitnumber);
1814        }
1815      }
1816    }
1817    {
1818      /* These subprimitives are called via CALL/RET; need
1819         to pop the return address off the stack and set
1820         the PC there. */
1821      LispObj *rsp = (LispObj *)xpGPR(xp,Isp), ra = *rsp++;
1822      xpPC(xp) = ra;
1823      xpGPR(xp,Isp)=(LispObj)rsp;
1824    }
1825    return;
1826  }
1827}
1828
1829void
1830normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
1831{
1832  void *cur_allocptr = (void *)(tcr->save_allocptr);
1833  LispObj lisprsp, lisptsp;
1834  area *a;
1835
1836  if (xp) {
1837    if (is_other_tcr) {
1838      pc_luser_xp(xp, tcr, NULL);
1839    }
1840    a = tcr->vs_area;
1841    lisprsp = xpGPR(xp, Isp);
1842    if (((BytePtr)lisprsp >= a->low) &&
1843        ((BytePtr)lisprsp < a->high)) {
1844      a->active = (BytePtr)lisprsp;
1845    } else {
1846      a->active = (BytePtr) tcr->save_vsp;
1847    }
1848    a = tcr->ts_area;
1849    a->active = (BytePtr) tcr->save_tsp;
1850  } else {
1851    /* In ff-call; get area active pointers from tcr */
1852    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
1853    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
1854  }
1855  if (cur_allocptr) {
1856    update_bytes_allocated(tcr, cur_allocptr);
1857  }
1858  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
1859  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
1860    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
1861  }
1862}
1863
1864
1865/* Suspend and "normalize" other tcrs, then call a gc-like function
1866   in that context.  Resume the other tcrs, then return what the
1867   function returned */
1868
1869TCR *gc_tcr = NULL;
1870
1871
1872int
1873gc_like_from_xp(ExceptionInformation *xp, 
1874                int(*fun)(TCR *, signed_natural), 
1875                signed_natural param)
1876{
1877  TCR *tcr = get_tcr(false), *other_tcr;
1878  ExceptionInformation* other_xp;
1879  int result;
1880  signed_natural inhibit;
1881
1882  suspend_other_threads(true);
1883  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
1884  if (inhibit != 0) {
1885    if (inhibit > 0) {
1886      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
1887    }
1888    resume_other_threads(true);
1889    gc_deferred++;
1890    return 0;
1891  }
1892  gc_deferred = 0;
1893
1894  gc_tcr = tcr;
1895
1896  /* This is generally necessary if the current thread invoked the GC
1897     via an alloc trap, and harmless if the GC was invoked via a GC
1898     trap.  (It's necessary in the first case because the "allocptr"
1899     register - %rbx - may be pointing into the middle of something
1900     below tcr->save_allocbase, and we wouldn't want the GC to see
1901     that bogus pointer.) */
1902  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
1903
1904  normalize_tcr(xp, tcr, false);
1905
1906
1907  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
1908    if (other_tcr->pending_exception_context) {
1909      other_tcr->gc_context = other_tcr->pending_exception_context;
1910    } else if (other_tcr->valence == TCR_STATE_LISP) {
1911      other_tcr->gc_context = other_tcr->suspend_context;
1912    } else {
1913      /* no pending exception, didn't suspend in lisp state:
1914         must have executed a synchronous ff-call.
1915      */
1916      other_tcr->gc_context = NULL;
1917    }
1918    normalize_tcr(other_tcr->gc_context, other_tcr, true);
1919  }
1920   
1921
1922
1923  result = fun(tcr, param);
1924
1925  other_tcr = tcr;
1926  do {
1927    other_tcr->gc_context = NULL;
1928    other_tcr = other_tcr->next;
1929  } while (other_tcr != tcr);
1930
1931  gc_tcr = NULL;
1932
1933  resume_other_threads(true);
1934
1935  return result;
1936
1937}
1938
1939int
1940change_hons_area_size_from_xp(ExceptionInformation *xp, signed_natural delta_in_bytes)
1941{
1942  return gc_like_from_xp(xp, change_hons_area_size, delta_in_bytes);
1943}
1944
1945int
1946purify_from_xp(ExceptionInformation *xp, signed_natural param)
1947{
1948  return gc_like_from_xp(xp, purify, param);
1949}
1950
1951int
1952impurify_from_xp(ExceptionInformation *xp, signed_natural param)
1953{
1954  return gc_like_from_xp(xp, impurify, param);
1955}
1956
1957/* Returns #bytes freed by invoking GC */
1958
1959int
1960gc_from_tcr(TCR *tcr, signed_natural param)
1961{
1962  area *a;
1963  BytePtr oldfree, newfree;
1964  BytePtr oldend, newend;
1965
1966#if 0
1967  fprintf(stderr, "Start GC  in 0x%lx\n", tcr);
1968#endif
1969  a = active_dynamic_area;
1970  oldend = a->high;
1971  oldfree = a->active;
1972  gc(tcr, param);
1973  newfree = a->active;
1974  newend = a->high;
1975#if 0
1976  fprintf(stderr, "End GC  in 0x%lx\n", tcr);
1977#endif
1978  return ((oldfree-newfree)+(newend-oldend));
1979}
1980
1981int
1982gc_from_xp(ExceptionInformation *xp, signed_natural param)
1983{
1984  int status = gc_like_from_xp(xp, gc_from_tcr, param);
1985
1986  freeGCptrs();
1987  return status;
1988}
1989
1990#ifdef DARWIN
1991
1992#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
1993#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
1994
1995#if USE_MACH_EXCEPTION_LOCK
1996pthread_mutex_t _mach_exception_lock, *mach_exception_lock;
1997#endif
1998extern void pseudo_sigreturn(void);
1999
2000
2001
2002#define LISP_EXCEPTIONS_HANDLED_MASK \
2003 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2004
2005/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2006#define NUM_LISP_EXCEPTIONS_HANDLED 4
2007
2008typedef struct {
2009  int foreign_exception_port_count;
2010  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2011  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2012  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2013  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2014} MACH_foreign_exception_state;
2015
2016
2017
2018
2019/*
2020  Mach's exception mechanism works a little better than its signal
2021  mechanism (and, not incidentally, it gets along with GDB a lot
2022  better.
2023
2024  Initially, we install an exception handler to handle each native
2025  thread's exceptions.  This process involves creating a distinguished
2026  thread which listens for kernel exception messages on a set of
2027  0 or more thread exception ports.  As threads are created, they're
2028  added to that port set; a thread's exception port is destroyed
2029  (and therefore removed from the port set) when the thread exits.
2030
2031  A few exceptions can be handled directly in the handler thread;
2032  others require that we resume the user thread (and that the
2033  exception thread resumes listening for exceptions.)  The user
2034  thread might eventually want to return to the original context
2035  (possibly modified somewhat.)
2036
2037  As it turns out, the simplest way to force the faulting user
2038  thread to handle its own exceptions is to do pretty much what
2039  signal() does: the exception handlng thread sets up a sigcontext
2040  on the user thread's stack and forces the user thread to resume
2041  execution as if a signal handler had been called with that
2042  context as an argument.  We can use a distinguished UUO at a
2043  distinguished address to do something like sigreturn(); that'll
2044  have the effect of resuming the user thread's execution in
2045  the (pseudo-) signal context.
2046
2047  Since:
2048    a) we have miles of code in C and in Lisp that knows how to
2049    deal with Linux sigcontexts
2050    b) Linux sigcontexts contain a little more useful information
2051    (the DAR, DSISR, etc.) than their Darwin counterparts
2052    c) we have to create a sigcontext ourselves when calling out
2053    to the user thread: we aren't really generating a signal, just
2054    leveraging existing signal-handling code.
2055
2056  we create a Linux sigcontext struct.
2057
2058  Simple ?  Hopefully from the outside it is ...
2059
2060  We want the process of passing a thread's own context to it to
2061  appear to be atomic: in particular, we don't want the GC to suspend
2062  a thread that's had an exception but has not yet had its user-level
2063  exception handler called, and we don't want the thread's exception
2064  context to be modified by a GC while the Mach handler thread is
2065  copying it around.  On Linux (and on Jaguar), we avoid this issue
2066  because (a) the kernel sets up the user-level signal handler and
2067  (b) the signal handler blocks signals (including the signal used
2068  by the GC to suspend threads) until tcr->xframe is set up.
2069
2070  The GC and the Mach server thread therefore contend for the lock
2071  "mach_exception_lock".  The Mach server thread holds the lock
2072  when copying exception information between the kernel and the
2073  user thread; the GC holds this lock during most of its execution
2074  (delaying exception processing until it can be done without
2075  GC interference.)
2076
2077*/
2078
2079#ifdef PPC64
2080#define C_REDZONE_LEN           320
2081#define C_STK_ALIGN             32
2082#else
2083#define C_REDZONE_LEN           224
2084#define C_STK_ALIGN             16
2085#endif
2086#define C_PARAMSAVE_LEN         64
2087#define C_LINKAGE_LEN           48
2088
2089#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2090
2091void
2092fatal_mach_error(char *format, ...);
2093
2094#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2095
2096
2097void
2098restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2099{
2100  int i, j;
2101  kern_return_t kret;
2102#if WORD_SIZE == 64
2103  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2104#else
2105  struct mcontext * mc = UC_MCONTEXT(pseudosigcontext);
2106#endif
2107
2108  /* Set the thread's FP state from the pseudosigcontext */
2109  kret = thread_set_state(thread,
2110                          x86_FLOAT_STATE64,
2111                          (thread_state_t)&(mc->__fs),
2112                          x86_FLOAT_STATE64_COUNT);
2113
2114  MACH_CHECK_ERROR("setting thread FP state", kret);
2115
2116  /* The thread'll be as good as new ... */
2117#if WORD_SIZE == 64
2118  kret = thread_set_state(thread,
2119                          x86_THREAD_STATE64,
2120                          (thread_state_t)&(mc->__ss),
2121                          x86_THREAD_STATE64_COUNT);
2122#else
2123  kret = thread_set_state(thread, 
2124                          x86_THREAD_STATE32,
2125                          (thread_state_t)&(mc->__ss),
2126                          x86_THREAD_STATE32_COUNT);
2127#endif
2128  MACH_CHECK_ERROR("setting thread state", kret);
2129} 
2130
2131/* This code runs in the exception handling thread, in response
2132   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2133   in response to a call to pseudo_sigreturn() from the specified
2134   user thread.
2135   Find that context (the user thread's R3 points to it), then
2136   use that context to set the user thread's state.  When this
2137   function's caller returns, the Mach kernel will resume the
2138   user thread.
2139*/
2140
2141kern_return_t
2142do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
2143{
2144  ExceptionInformation *xp;
2145
2146#ifdef DEBUG_MACH_EXCEPTIONS
2147  fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
2148#endif
2149  xp = tcr->pending_exception_context;
2150  if (xp) {
2151    tcr->pending_exception_context = NULL;
2152    tcr->valence = TCR_STATE_LISP;
2153    restore_mach_thread_state(thread, xp);
2154    raise_pending_interrupt(tcr);
2155  } else {
2156    FBug(NULL, "no xp here!\n");
2157  }
2158#ifdef DEBUG_MACH_EXCEPTIONS
2159  fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
2160#endif
2161  return KERN_SUCCESS;
2162} 
2163
2164ExceptionInformation *
2165create_thread_context_frame(mach_port_t thread, 
2166                            natural *new_stack_top,
2167                            siginfo_t **info_ptr,
2168                            TCR *tcr,
2169#ifdef X8664
2170                            x86_thread_state64_t *ts
2171#else
2172                            x86_thread_state_t *ts
2173#endif
2174                            )
2175{
2176  mach_msg_type_number_t thread_state_count;
2177  kern_return_t result;
2178  int i,j;
2179  ExceptionInformation *pseudosigcontext;
2180#ifdef X8664
2181  MCONTEXT_T mc;
2182#else
2183  struct mcontext *mc;
2184#endif
2185  natural stackp, backlink;
2186
2187 
2188  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2189  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2190  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
2191  if (info_ptr) {
2192    *info_ptr = (siginfo_t *)stackp;
2193  }
2194  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
2195  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
2196
2197  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
2198#ifdef X8664
2199  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
2200#else
2201  mc = (struct mcontext *) ptr_from_lispobj(stackp);
2202#endif
2203 
2204  bcopy(ts,&(mc->__ss),sizeof(*ts));
2205
2206  thread_state_count = x86_FLOAT_STATE64_COUNT;
2207  thread_get_state(thread,
2208                   x86_FLOAT_STATE64,
2209                   (thread_state_t)&(mc->__fs),
2210                   &thread_state_count);
2211
2212
2213#ifdef X8664
2214  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
2215#else
2216  thread_state_count = x86_EXCEPTION_STATE_COUNT;
2217#endif
2218  thread_get_state(thread,
2219#ifdef X8664
2220                   x86_EXCEPTION_STATE64,
2221#else
2222                   x86_EXCEPTION_STATE,
2223#endif
2224                   (thread_state_t)&(mc->__es),
2225                   &thread_state_count);
2226
2227
2228  UC_MCONTEXT(pseudosigcontext) = mc;
2229  if (new_stack_top) {
2230    *new_stack_top = stackp;
2231  }
2232  return pseudosigcontext;
2233}
2234
2235/*
2236  This code sets up the user thread so that it executes a "pseudo-signal
2237  handler" function when it resumes.  Create a fake ucontext struct
2238  on the thread's stack and pass it as an argument to the pseudo-signal
2239  handler.
2240
2241  Things are set up so that the handler "returns to" pseudo_sigreturn(),
2242  which will restore the thread's context.
2243
2244  If the handler invokes code that throws (or otherwise never sigreturn()'s
2245  to the context), that's fine.
2246
2247  Actually, check that: throw (and variants) may need to be careful and
2248  pop the tcr's xframe list until it's younger than any frame being
2249  entered.
2250*/
2251
2252int
2253setup_signal_frame(mach_port_t thread,
2254                   void *handler_address,
2255                   int signum,
2256                   int code,
2257                   TCR *tcr,
2258#ifdef X8664
2259                   x86_thread_state64_t *ts
2260#else
2261                   x86_thread_state_t *ts
2262#endif
2263                   )
2264{
2265#ifdef X8664
2266  x86_thread_state64_t new_ts;
2267#else
2268  x86_thread_state_t new_ts;
2269#endif
2270  ExceptionInformation *pseudosigcontext;
2271  int i, j, old_valence = tcr->valence;
2272  kern_return_t result;
2273  natural stackp, *stackpp;
2274  siginfo_t *info;
2275
2276#ifdef DEBUG_MACH_EXCEPTIONS
2277  fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
2278#endif
2279  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
2280  bzero(info, sizeof(*info));
2281  info->si_code = code;
2282  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
2283  info->si_signo = signum;
2284  pseudosigcontext->uc_onstack = 0;
2285  pseudosigcontext->uc_sigmask = (sigset_t) 0;
2286  pseudosigcontext->uc_stack.ss_sp = 0;
2287  pseudosigcontext->uc_stack.ss_size = 0;
2288  pseudosigcontext->uc_stack.ss_flags = 0;
2289  pseudosigcontext->uc_link = NULL;
2290  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
2291  tcr->pending_exception_context = pseudosigcontext;
2292  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
2293 
2294
2295  /*
2296     It seems like we've created a  sigcontext on the thread's
2297     stack.  Set things up so that we call the handler (with appropriate
2298     args) when the thread's resumed.
2299  */
2300
2301  new_ts.__rip = (natural) handler_address;
2302  stackpp = (natural *)stackp;
2303  *--stackpp = (natural)pseudo_sigreturn;
2304  stackp = (natural)stackpp;
2305  new_ts.__rdi = signum;
2306  new_ts.__rsi = (natural)info;
2307  new_ts.__rdx = (natural)pseudosigcontext;
2308  new_ts.__rcx = (natural)tcr;
2309  new_ts.__r8 = (natural)old_valence;
2310  new_ts.__rsp = stackp;
2311  new_ts.__rflags = ts->__rflags;
2312
2313
2314#ifdef X8664
2315  thread_set_state(thread,
2316                   x86_THREAD_STATE64,
2317                   (thread_state_t)&new_ts,
2318                   x86_THREAD_STATE64_COUNT);
2319#else
2320  thread_set_state(thread, 
2321                   x86_THREAD_STATE,
2322                   (thread_state_t)&new_ts,
2323                   x86_THREAD_STATE_COUNT);
2324#endif
2325#ifdef DEBUG_MACH_EXCEPTIONS
2326  fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
2327#endif
2328  return 0;
2329}
2330
2331
2332
2333
2334
2335
2336/*
2337  This function runs in the exception handling thread.  It's
2338  called (by this precise name) from the library function "exc_server()"
2339  when the thread's exception ports are set up.  (exc_server() is called
2340  via mach_msg_server(), which is a function that waits for and dispatches
2341  on exception messages from the Mach kernel.)
2342
2343  This checks to see if the exception was caused by a pseudo_sigreturn()
2344  UUO; if so, it arranges for the thread to have its state restored
2345  from the specified context.
2346
2347  Otherwise, it tries to map the exception to a signal number and
2348  arranges that the thread run a "pseudo signal handler" to handle
2349  the exception.
2350
2351  Some exceptions could and should be handled here directly.
2352*/
2353
2354/* We need the thread's state earlier on x86_64 than we did on PPC;
2355   the PC won't fit in code_vector[1].  We shouldn't try to get it
2356   lazily (via catch_exception_raise_state()); until we own the
2357   exception lock, we shouldn't have it in userspace (since a GCing
2358   thread wouldn't know that we had our hands on it.)
2359*/
2360
2361#ifdef X8664
2362#define ts_pc(t) t.__rip
2363#else
2364#define ts_pc(t) t.eip
2365#endif
2366
2367#ifdef DARWIN_USE_PSEUDO_SIGRETURN
2368#define DARWIN_EXCEPTION_HANDLER signal_handler
2369#else
2370#define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler
2371#endif
2372
2373
2374kern_return_t
2375catch_exception_raise(mach_port_t exception_port,
2376                      mach_port_t thread,
2377                      mach_port_t task, 
2378                      exception_type_t exception,
2379                      exception_data_t code_vector,
2380                      mach_msg_type_number_t code_count)
2381{
2382  int signum = 0, code = *code_vector, code1;
2383  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
2384  kern_return_t kret, call_kret;
2385#ifdef X8664
2386  x86_thread_state64_t ts;
2387#else
2388  x86_thread_state_t ts;
2389#endif
2390  mach_msg_type_number_t thread_state_count;
2391
2392
2393
2394#ifdef DEBUG_MACH_EXCEPTIONS
2395  fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
2396#endif
2397
2398
2399  if (
2400#if USE_MACH_EXCEPTION_LOCK
2401      pthread_mutex_trylock(mach_exception_lock) == 0
2402#else
2403      1
2404#endif
2405      ) {
2406#ifdef X8664
2407    do {
2408      thread_state_count = x86_THREAD_STATE64_COUNT;
2409      call_kret = thread_get_state(thread,
2410                                   x86_THREAD_STATE64,
2411                                   (thread_state_t)&ts,
2412                                   &thread_state_count);
2413    } while (call_kret == KERN_ABORTED);
2414  MACH_CHECK_ERROR("getting thread state",call_kret);
2415#else
2416    thread_state_count = x86_THREAD_STATE_COUNT;
2417    thread_get_state(thread,
2418                     x86_THREAD_STATE,
2419                     (thread_state_t)&ts,
2420                     &thread_state_count);
2421#endif
2422    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
2423      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2424    } 
2425    if ((code == EXC_I386_GPFLT) &&
2426        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
2427      kret = do_pseudo_sigreturn(thread, tcr);
2428#if 0
2429      fprintf(stderr, "Exception return in 0x%x\n",tcr);
2430#endif
2431    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
2432      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
2433      kret = 17;
2434    } else {
2435      switch (exception) {
2436      case EXC_BAD_ACCESS:
2437        if (code == EXC_I386_GPFLT) {
2438          signum = SIGSEGV;
2439        } else {
2440          signum = SIGBUS;
2441        }
2442        break;
2443       
2444      case EXC_BAD_INSTRUCTION:
2445        if (code == EXC_I386_GPFLT) {
2446          signum = SIGSEGV;
2447        } else {
2448          signum = SIGILL;
2449        }
2450        break;
2451         
2452      case EXC_SOFTWARE:
2453        signum = SIGILL;
2454        break;
2455       
2456      case EXC_ARITHMETIC:
2457        signum = SIGFPE;
2458        break;
2459       
2460      default:
2461        break;
2462      }
2463      if (signum) {
2464        kret = setup_signal_frame(thread,
2465                                  (void *)DARWIN_EXCEPTION_HANDLER,
2466                                  signum,
2467                                  code,
2468                                  tcr, 
2469                                  &ts);
2470#if 0
2471        fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
2472#endif
2473       
2474      } else {
2475        kret = 17;
2476      }
2477    }
2478#if USE_MACH_EXCEPTION_LOCK
2479#ifdef DEBUG_MACH_EXCEPTIONS
2480    fprintf(stderr, "releasing Mach exception lock in exception thread\n");
2481#endif
2482    pthread_mutex_unlock(mach_exception_lock);
2483#endif
2484  } else {
2485    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2486     
2487#if 0
2488    fprintf(stderr, "deferring pending exception in 0x%x\n", tcr);
2489#endif
2490    kret = KERN_SUCCESS;
2491    if (tcr == gc_tcr) {
2492      int i;
2493      write(1, "exception in GC thread. Sleeping for 60 seconds\n",sizeof("exception in GC thread.  Sleeping for 60 seconds\n"));
2494      for (i = 0; i < 60; i++) {
2495        sleep(1);
2496      }
2497      _exit(EX_SOFTWARE);
2498    }
2499  }
2500  return kret;
2501}
2502
2503
2504
2505
2506static mach_port_t mach_exception_thread = (mach_port_t)0;
2507
2508
2509/*
2510  The initial function for an exception-handling thread.
2511*/
2512
2513void *
2514exception_handler_proc(void *arg)
2515{
2516  extern boolean_t exc_server();
2517  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
2518
2519  mach_exception_thread = pthread_mach_thread_np(pthread_self());
2520  mach_msg_server(exc_server, 256, p, 0);
2521  /* Should never return. */
2522  abort();
2523}
2524
2525
2526
2527void
2528mach_exception_thread_shutdown()
2529{
2530  kern_return_t kret;
2531
2532  fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
2533  kret = thread_terminate(mach_exception_thread);
2534  if (kret != KERN_SUCCESS) {
2535    fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
2536  }
2537}
2538
2539
2540mach_port_t
2541mach_exception_port_set()
2542{
2543  static mach_port_t __exception_port_set = MACH_PORT_NULL;
2544  kern_return_t kret; 
2545  if (__exception_port_set == MACH_PORT_NULL) {
2546#if USE_MACH_EXCEPTION_LOCK
2547    mach_exception_lock = &_mach_exception_lock;
2548    pthread_mutex_init(mach_exception_lock, NULL);
2549#endif
2550
2551    kret = mach_port_allocate(mach_task_self(),
2552                              MACH_PORT_RIGHT_PORT_SET,
2553                              &__exception_port_set);
2554    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
2555    create_system_thread(0,
2556                         NULL,
2557                         exception_handler_proc, 
2558                         (void *)((natural)__exception_port_set));
2559  }
2560  return __exception_port_set;
2561}
2562
2563/*
2564  Setup a new thread to handle those exceptions specified by
2565  the mask "which".  This involves creating a special Mach
2566  message port, telling the Mach kernel to send exception
2567  messages for the calling thread to that port, and setting
2568  up a handler thread which listens for and responds to
2569  those messages.
2570
2571*/
2572
2573/*
2574  Establish the lisp thread's TCR as its exception port, and determine
2575  whether any other ports have been established by foreign code for
2576  exceptions that lisp cares about.
2577
2578  If this happens at all, it should happen on return from foreign
2579  code and on entry to lisp code via a callback.
2580
2581  This is a lot of trouble (and overhead) to support Java, or other
2582  embeddable systems that clobber their caller's thread exception ports.
2583 
2584*/
2585kern_return_t
2586tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
2587{
2588  kern_return_t kret;
2589  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
2590  int i;
2591  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
2592  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
2593  exception_mask_t mask = 0;
2594
2595  kret = thread_swap_exception_ports(thread,
2596                                     LISP_EXCEPTIONS_HANDLED_MASK,
2597                                     lisp_port,
2598                                     EXCEPTION_DEFAULT,
2599                                     THREAD_STATE_NONE,
2600                                     fxs->masks,
2601                                     &n,
2602                                     fxs->ports,
2603                                     fxs->behaviors,
2604                                     fxs->flavors);
2605  if (kret == KERN_SUCCESS) {
2606    fxs->foreign_exception_port_count = n;
2607    for (i = 0; i < n; i ++) {
2608      foreign_port = fxs->ports[i];
2609
2610      if ((foreign_port != lisp_port) &&
2611          (foreign_port != MACH_PORT_NULL)) {
2612        mask |= fxs->masks[i];
2613      }
2614    }
2615    tcr->foreign_exception_status = (int) mask;
2616  }
2617  return kret;
2618}
2619
2620kern_return_t
2621tcr_establish_lisp_exception_port(TCR *tcr)
2622{
2623  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
2624}
2625
2626/*
2627  Do this when calling out to or returning from foreign code, if
2628  any conflicting foreign exception ports were established when we
2629  last entered lisp code.
2630*/
2631kern_return_t
2632restore_foreign_exception_ports(TCR *tcr)
2633{
2634  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
2635 
2636  if (m) {
2637    MACH_foreign_exception_state *fxs  = 
2638      (MACH_foreign_exception_state *) tcr->native_thread_info;
2639    int i, n = fxs->foreign_exception_port_count;
2640    exception_mask_t tm;
2641
2642    for (i = 0; i < n; i++) {
2643      if ((tm = fxs->masks[i]) & m) {
2644        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
2645                                   tm,
2646                                   fxs->ports[i],
2647                                   fxs->behaviors[i],
2648                                   fxs->flavors[i]);
2649      }
2650    }
2651  }
2652}
2653                                   
2654
2655/*
2656  This assumes that a Mach port (to be used as the thread's exception port) whose
2657  "name" matches the TCR's 32-bit address has already been allocated.
2658*/
2659
2660kern_return_t
2661setup_mach_exception_handling(TCR *tcr)
2662{
2663  mach_port_t
2664    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
2665    target_thread = pthread_mach_thread_np((pthread_t)ptr_from_lispobj(tcr->osid)),
2666    task_self = mach_task_self();
2667  kern_return_t kret;
2668
2669  kret = mach_port_insert_right(task_self,
2670                                thread_exception_port,
2671                                thread_exception_port,
2672                                MACH_MSG_TYPE_MAKE_SEND);
2673  MACH_CHECK_ERROR("adding send right to exception_port",kret);
2674
2675  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
2676  if (kret == KERN_SUCCESS) {
2677    mach_port_t exception_port_set = mach_exception_port_set();
2678
2679    kret = mach_port_move_member(task_self,
2680                                 thread_exception_port,
2681                                 exception_port_set);
2682  }
2683  return kret;
2684}
2685
2686void
2687darwin_exception_init(TCR *tcr)
2688{
2689  void tcr_monitor_exception_handling(TCR*, Boolean);
2690  kern_return_t kret;
2691  MACH_foreign_exception_state *fxs = 
2692    calloc(1, sizeof(MACH_foreign_exception_state));
2693 
2694  tcr->native_thread_info = (void *) fxs;
2695
2696  if ((kret = setup_mach_exception_handling(tcr))
2697      != KERN_SUCCESS) {
2698    fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
2699    terminate_lisp();
2700  }
2701  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
2702  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
2703}
2704
2705/*
2706  The tcr is the "name" of the corresponding thread's exception port.
2707  Destroying the port should remove it from all port sets of which it's
2708  a member (notably, the exception port set.)
2709*/
2710void
2711darwin_exception_cleanup(TCR *tcr)
2712{
2713  void *fxs = tcr->native_thread_info;
2714  extern Boolean use_mach_exception_handling;
2715
2716  if (fxs) {
2717    tcr->native_thread_info = NULL;
2718    free(fxs);
2719  }
2720  if (use_mach_exception_handling) {
2721    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2722    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2723  }
2724}
2725
2726
2727Boolean
2728suspend_mach_thread(mach_port_t mach_thread)
2729{
2730  kern_return_t status;
2731  Boolean aborted = false;
2732 
2733  do {
2734    aborted = false;
2735    status = thread_suspend(mach_thread);
2736    if (status == KERN_SUCCESS) {
2737      status = thread_abort_safely(mach_thread);
2738      if (status == KERN_SUCCESS) {
2739        aborted = true;
2740      } else {
2741        fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
2742        thread_resume(mach_thread);
2743      }
2744    } else {
2745      return false;
2746    }
2747  } while (! aborted);
2748  return true;
2749}
2750
2751/*
2752  Only do this if pthread_kill indicated that the pthread isn't
2753  listening to signals anymore, as can happen as soon as pthread_exit()
2754  is called on Darwin.  The thread could still call out to lisp as it
2755  is exiting, so we need another way to suspend it in this case.
2756*/
2757Boolean
2758mach_suspend_tcr(TCR *tcr)
2759{
2760  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
2761  ExceptionInformation *pseudosigcontext;
2762  Boolean result = false;
2763 
2764  result = suspend_mach_thread(mach_thread);
2765  if (result) {
2766    mach_msg_type_number_t thread_state_count;
2767#ifdef X8664
2768    x86_thread_state64_t ts;
2769    thread_state_count = x86_THREAD_STATE64_COUNT;
2770    thread_get_state(mach_thread,
2771                     x86_THREAD_STATE64,
2772                     (thread_state_t)&ts,
2773                     &thread_state_count);
2774#else
2775    x86_thread_state_t ts;
2776    thread_state_count = x86_THREAD_STATE_COUNT;
2777    thread_get_state(mach_thread,
2778                     x86_THREAD_STATE,
2779                     (thread_state_t)&ts,
2780                     &thread_state_count);
2781#endif
2782
2783    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
2784    pseudosigcontext->uc_onstack = 0;
2785    pseudosigcontext->uc_sigmask = (sigset_t) 0;
2786    tcr->suspend_context = pseudosigcontext;
2787  }
2788  return result;
2789}
2790
2791void
2792mach_resume_tcr(TCR *tcr)
2793{
2794  ExceptionInformation *xp;
2795  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
2796 
2797  xp = tcr->suspend_context;
2798#ifdef DEBUG_MACH_EXCEPTIONS
2799  fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
2800          tcr, tcr->pending_exception_context);
2801#endif
2802  tcr->suspend_context = NULL;
2803  restore_mach_thread_state(mach_thread, xp);
2804#ifdef DEBUG_MACH_EXCEPTIONS
2805  fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
2806          tcr, tcr->pending_exception_context);
2807#endif
2808  thread_resume(mach_thread);
2809}
2810
2811void
2812fatal_mach_error(char *format, ...)
2813{
2814  va_list args;
2815  char s[512];
2816 
2817
2818  va_start(args, format);
2819  vsnprintf(s, sizeof(s),format, args);
2820  va_end(args);
2821
2822  Fatal("Mach error", s);
2823}
2824
2825
2826
2827
2828#endif
Note: See TracBrowser for help on using the repository browser.