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

Last change on this file since 10094 was 10094, checked in by rme, 12 years ago

Conditionalize for x8632.

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