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

Last change on this file since 9055 was 9055, checked in by gb, 12 years ago

Move prototypes for get/set_mxcsr() to .h file.

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