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

Last change on this file since 9901 was 9901, checked in by gb, 11 years ago

Remove unused variables. (May need to compile with -Wall to find
more unused vars on PPC, too.)

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