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

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

If we return from a callback with "skip == -1", set the absolute PC
from the relative PC differently on x8632.

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