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

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

x86-exceptions.h: define xpMXCSRptr macro for Win32 (the MXCSR is buried
in there somewhere.)

lisp-debug.c: use xpMXCSRptr to find the MXCSR register on Win32.

x86-exceptions.c: Win32 uses exception codes STATUS_FLOAT_MULTIPLE_FAULTS
and STATUS_FLOAT_MULTIPLE_TRAPS for SSE2-related FP exceptions. Map these
to SIGFPE, look at the MXCSR to determine the FP exception flavor.

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