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

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

Merged trunk changes r6975:7243

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