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

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

In handle_exception: if we get a SIGNAL_FOR_INTN trap and don't
have an 'int n' instruction, fall through. If in lisp when the
exception occurred, callback as in handle_fault(), but set the
"write_p" code to (natural)-1 to indicate that we don't know
the fault address or much of anything more about the fault.
(We don't.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 99.3 KB
Line 
1/*
2   Copyright (C) 2005 Clozure Associates
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp-exceptions.h"
19#include "lisp_globals.h"
20#include "Threads.h"
21#include <ctype.h>
22#include <stdio.h>
23#include <stddef.h>
24#include <string.h>
25#include <stdarg.h>
26#include <errno.h>
27#include <stdio.h>
28#ifdef LINUX
29#include <strings.h>
30#include <sys/mman.h>
31#include <fpu_control.h>
32#include <linux/prctl.h>
33#endif
34#ifdef DARWIN
35#include <sysexits.h>
36#endif
37#ifndef WINDOWS
38#include <sys/syslog.h>
39#endif
40#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      if (old_valence == TCR_STATE_LISP) {
1096        LispObj cmain = nrs_CMAIN.vcell,
1097          xcf;
1098        if ((fulltag_of(cmain) == fulltag_misc) &&
1099            (header_subtag(header_of(cmain)) == subtag_macptr)) {
1100          xcf = create_exception_callback_frame(context, tcr);
1101          callback_to_lisp(tcr, cmain, context, xcf, SIGBUS, (natural)-1,0, 0);
1102        }
1103      }
1104      return false;
1105    }
1106    break;
1107
1108  case SIGNAL_FOR_PROCESS_INTERRUPT:
1109    tcr->interrupt_pending = 0;
1110    callback_for_interrupt(tcr, context);
1111    return true;
1112    break;
1113
1114
1115  case SIGILL:
1116    if ((program_counter[0] == XUUO_OPCODE_0) &&
1117        (program_counter[1] == XUUO_OPCODE_1)) {
1118      TCR *target = (TCR *)xpGPR(context, Iarg_z);
1119
1120      switch (program_counter[2]) {
1121      case XUUO_TLB_TOO_SMALL:
1122        if (extend_tcr_tlb(tcr,context)) {
1123          xpPC(context)+=3;
1124          return true;
1125        }
1126        break;
1127       
1128      case XUUO_INTERRUPT_NOW:
1129        callback_for_interrupt(tcr,context);
1130        xpPC(context)+=3;
1131        return true;
1132
1133      case XUUO_SUSPEND_NOW:
1134        xpPC(context)+=3;
1135        return true;
1136
1137      case XUUO_INTERRUPT:
1138        raise_thread_interrupt(target);
1139        xpPC(context)+=3;
1140        return true;
1141
1142      case XUUO_SUSPEND:
1143        xpGPR(context,Iimm0) = (LispObj) lisp_suspend_tcr(target);
1144        xpPC(context)+=3;
1145        return true;
1146
1147      case XUUO_SUSPEND_ALL:
1148        lisp_suspend_other_threads();
1149        xpPC(context)+=3;
1150        return true;
1151
1152
1153      case XUUO_RESUME:
1154        xpGPR(context,Iimm0) = (LispObj) lisp_resume_tcr(target);
1155        xpPC(context)+=3;
1156        return true;
1157       
1158      case XUUO_RESUME_ALL:
1159        lisp_resume_other_threads();
1160        xpPC(context)+=3;
1161        return true;
1162       
1163      case XUUO_KILL:
1164        xpGPR(context,Iimm0) = (LispObj)kill_tcr(target);
1165        xpPC(context)+=3;
1166        return true;
1167
1168      case XUUO_ALLOCATE_LIST:
1169        allocate_list(context,tcr);
1170        xpPC(context)+=3;
1171        return true;
1172
1173      default:
1174        return false;
1175      }
1176    } else {
1177      return false;
1178    }
1179    break;
1180   
1181  case SIGFPE:
1182#ifdef FREEBSD
1183    /* As of 6.1, FreeBSD/AMD64 doesn't seem real comfortable
1184       with this newfangled XMM business (and therefore info->si_code
1185       is often 0 on an XMM FP exception.
1186       Try to figure out what really happened by decoding mxcsr
1187       bits.
1188    */
1189    freebsd_decode_vector_fp_exception(info,context);
1190#endif
1191#ifdef DARWIN
1192    /* Same general problem with Darwin as of 8.7.2 */
1193    darwin_decode_vector_fp_exception(info,context);
1194#endif
1195
1196    return handle_floating_point_exception(tcr, context, info);
1197
1198#if SIGBUS != SIGNUM_FOR_INTN_TRAP
1199  case SIGBUS:
1200    return handle_fault(tcr, context, info, old_valence);
1201#endif
1202   
1203#if SIGSEGV != SIGNUM_FOR_INTN_TRAP
1204  case SIGSEGV:
1205    return handle_fault(tcr, context, info, old_valence);
1206#endif   
1207   
1208  default:
1209    return false;
1210  }
1211}
1212
1213
1214/*
1215   Current thread has all signals masked.  Before unmasking them,
1216   make it appear that the current thread has been suspended.
1217   (This is to handle the case where another thread is trying
1218   to GC before this thread is able to seize the exception lock.)
1219*/
1220int
1221prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context)
1222{
1223  int old_valence = tcr->valence;
1224
1225  tcr->pending_exception_context = context;
1226  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
1227
1228#ifdef WINDOWS
1229  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1230    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1231    SEM_RAISE(tcr->suspend);
1232    SEM_WAIT_FOREVER(tcr->resume);
1233  }
1234#else
1235  ALLOW_EXCEPTIONS(context);
1236#endif
1237  return old_valence;
1238} 
1239
1240void
1241wait_for_exception_lock_in_handler(TCR *tcr, 
1242                                   ExceptionInformation *context,
1243                                   xframe_list *xf)
1244{
1245
1246  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
1247#if 0
1248  fprintf(dbgout, "0x" LISP " has exception lock\n", tcr);
1249#endif
1250  xf->curr = context;
1251#ifdef X8632
1252  xf->node_regs_mask = tcr->node_regs_mask;
1253#endif
1254  xf->prev = tcr->xframe;
1255  tcr->xframe =  xf;
1256  tcr->pending_exception_context = NULL;
1257  tcr->valence = TCR_STATE_FOREIGN; 
1258}
1259
1260void
1261unlock_exception_lock_in_handler(TCR *tcr)
1262{
1263  tcr->pending_exception_context = tcr->xframe->curr;
1264#ifdef X8632
1265  tcr->node_regs_mask = tcr->xframe->node_regs_mask;
1266#endif
1267  tcr->xframe = tcr->xframe->prev;
1268  tcr->valence = TCR_STATE_EXCEPTION_RETURN;
1269  UNLOCK(lisp_global(EXCEPTION_LOCK),tcr);
1270#if 0
1271  fprintf(dbgout, "0x" LISP " released exception lock\n", tcr);
1272#endif
1273}
1274
1275/*
1276   If an interrupt is pending on exception exit, try to ensure
1277   that the thread sees it as soon as it's able to run.
1278*/
1279#ifdef WINDOWS
1280void
1281raise_pending_interrupt(TCR *tcr)
1282{
1283}
1284void
1285exit_signal_handler(TCR *tcr, int old_valence)
1286{
1287}
1288void
1289signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1290{
1291}
1292#else
1293void
1294raise_pending_interrupt(TCR *tcr)
1295{
1296  if ((TCR_INTERRUPT_LEVEL(tcr) >= 0) &&
1297      (tcr->interrupt_pending)) {
1298    pthread_kill((pthread_t)(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT);
1299  }
1300}
1301
1302void
1303exit_signal_handler(TCR *tcr, int old_valence)
1304{
1305  sigset_t mask;
1306  sigfillset(&mask);
1307#ifdef FREEBSD
1308  sigdelset(&mask,SIGTRAP);
1309#endif
1310 
1311  pthread_sigmask(SIG_SETMASK,&mask, NULL);
1312  tcr->valence = old_valence;
1313  tcr->pending_exception_context = NULL;
1314}
1315
1316void
1317signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context
1318#ifdef DARWIN
1319               , TCR *tcr, int old_valence
1320#endif
1321)
1322{
1323#ifdef DARWIN_GS_HACK
1324  Boolean gs_was_tcr = ensure_gs_pthread();
1325#endif
1326  xframe_list xframe_link;
1327#ifndef DARWIN
1328  TCR *tcr = get_tcr(false);
1329
1330  int old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1331#endif
1332  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1333    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1334    pthread_kill(pthread_self(), thread_suspend_signal);
1335  }
1336  wait_for_exception_lock_in_handler(tcr,context, &xframe_link);
1337
1338
1339  if (! handle_exception(signum, info, context, tcr, old_valence)) {
1340    char msg[512];
1341    Boolean foreign = (old_valence != TCR_STATE_LISP);
1342
1343    snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x" LISP ", context->regs at #x" LISP "", signum, xpPC(context), (natural)xpGPRvector(context));
1344   
1345    if (lisp_Debugger(context, info, signum,  foreign, msg)) {
1346      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1347    }
1348  }
1349  unlock_exception_lock_in_handler(tcr);
1350#ifndef DARWIN_USE_PSEUDO_SIGRETURN
1351  exit_signal_handler(tcr, old_valence);
1352#endif
1353  /* raise_pending_interrupt(tcr); */
1354#ifdef DARWIN_GS_HACK
1355  if (gs_was_tcr) {
1356    set_gs_address(tcr);
1357  }
1358#endif
1359#ifndef DARWIN_USE_PSEUDO_SIGRETURN
1360  SIGRETURN(context);
1361#endif
1362}
1363#endif
1364
1365
1366
1367
1368#ifdef LINUX
1369/* type of pointer to saved fp state */
1370#ifdef X8664
1371typedef fpregset_t FPREGS;
1372#else
1373typedef struct _fpstate *FPREGS;
1374#endif
1375LispObj *
1376copy_fpregs(ExceptionInformation *xp, LispObj *current, FPREGS *destptr)
1377{
1378  FPREGS src = (FPREGS)(xp->uc_mcontext.fpregs), dest;
1379 
1380  if (src) {
1381    dest = ((FPREGS)current)-1;
1382    *dest = *src;
1383    *destptr = dest;
1384    current = (LispObj *) dest;
1385  }
1386  return current;
1387}
1388#endif
1389
1390#ifdef DARWIN
1391LispObj *
1392copy_darwin_mcontext(MCONTEXT_T context, 
1393                     LispObj *current, 
1394                     MCONTEXT_T *out)
1395{
1396  MCONTEXT_T dest = ((MCONTEXT_T)current)-1;
1397  dest = (MCONTEXT_T) (((LispObj)dest) & ~15);
1398
1399  *dest = *context;
1400  *out = dest;
1401  return (LispObj *)dest;
1402}
1403#endif
1404
1405LispObj *
1406copy_siginfo(siginfo_t *info, LispObj *current)
1407{
1408  siginfo_t *dest = ((siginfo_t *)current) - 1;
1409#if !defined(LINUX) || !defined(X8632)
1410  dest = (siginfo_t *) (((LispObj)dest)&~15);
1411#endif
1412  *dest = *info;
1413  return (LispObj *)dest;
1414}
1415
1416#ifdef LINUX
1417typedef FPREGS copy_ucontext_last_arg_t;
1418#else
1419typedef void * copy_ucontext_last_arg_t;
1420#endif
1421
1422#ifndef WINDOWS
1423LispObj *
1424copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1425{
1426  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1427#if !defined(LINUX) || !defined(X8632)
1428  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1429#endif
1430
1431  *dest = *context;
1432  /* Fix it up a little; where's the signal mask allocated, if indeed
1433     it is "allocated" ? */
1434#ifdef LINUX
1435  dest->uc_mcontext.fpregs = (fpregset_t)fp;
1436#endif
1437  dest->uc_stack.ss_sp = 0;
1438  dest->uc_stack.ss_size = 0;
1439  dest->uc_stack.ss_flags = 0;
1440  dest->uc_link = NULL;
1441  return (LispObj *)dest;
1442}
1443#endif
1444
1445
1446LispObj *
1447tcr_frame_ptr(TCR *tcr)
1448{
1449  ExceptionInformation *xp;
1450  LispObj *bp;
1451
1452  if (tcr->pending_exception_context)
1453    xp = tcr->pending_exception_context;
1454  else if (tcr->valence == TCR_STATE_LISP) {
1455    xp = tcr->suspend_context;
1456  } else {
1457    xp = NULL;
1458  }
1459  if (xp) {
1460#ifdef X8664
1461    bp = (LispObj *) xpGPR(xp, Irbp);
1462#else
1463    bp = (LispObj *) xpGPR(xp, Iebp);
1464#endif
1465  } else {
1466#ifdef X8664
1467    bp = tcr->save_rbp;
1468#else
1469    bp = tcr->save_ebp;
1470#endif
1471  }
1472  return bp;
1473}
1474
1475
1476LispObj *
1477find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1478{
1479
1480  if (((BytePtr)rsp < foreign_area->low) ||
1481      ((BytePtr)rsp > foreign_area->high)) {
1482    rsp = (LispObj)(tcr->foreign_sp);
1483  }
1484  return (LispObj *) (((rsp-128) & ~15));
1485}
1486
1487#ifdef X8632
1488#ifdef LINUX
1489/* This is here for debugging.  On entry to a signal handler that
1490   receives info and context arguments, the stack should look exactly
1491   like this.  The "pretcode field" of the structure is the address
1492   of code that does an rt_sigreturn syscall, and rt_sigreturn expects
1493   %esp at the time of that syscall to be pointing just past the
1494   pretcode field.
1495   handle_signal_on_foreign_stack() and helpers have to be very
1496   careful to duplicate this "structure" exactly.
1497   Note that on x8664 Linux, rt_sigreturn expects a ucontext to
1498   be on top of the stack (with a siginfo_t underneath it.)
1499   It sort of half-works to do sigreturn via setcontext() on
1500   x8632 Linux, but (a) it may not be available on some distributions
1501   and (b) even a relatively modern version of it uses "fldenv" to
1502   restore FP context, and "fldenv" isn't nearly good enough.
1503*/
1504
1505struct rt_sigframe {
1506        char *pretcode;
1507        int sig;
1508        siginfo_t  *pinfo;
1509        void  *puc;
1510        siginfo_t info;
1511        struct ucontext uc;
1512        struct _fpstate fpstate;
1513        char retcode[8];
1514};
1515struct rt_sigframe *rtsf = 0;
1516
1517#endif
1518#endif
1519
1520
1521#ifndef WINDOWS
1522/* x8632 Linux requires that the stack-allocated siginfo is nearer
1523   the top of stack than the stack-allocated ucontext.  If other
1524   platforms care, they expect the ucontext to be nearer the top
1525   of stack.
1526*/
1527
1528#if defined(LINUX) && defined(X8632)
1529#define UCONTEXT_ON_TOP_OF_STACK 0
1530#else
1531#define UCONTEXT_ON_TOP_OF_STACK 1
1532#endif
1533void
1534handle_signal_on_foreign_stack(TCR *tcr,
1535                               void *handler, 
1536                               int signum, 
1537                               siginfo_t *info, 
1538                               ExceptionInformation *context,
1539                               LispObj return_address
1540#ifdef DARWIN_GS_HACK
1541                               , Boolean gs_was_tcr
1542#endif
1543                               )
1544{
1545#ifdef LINUX
1546  FPREGS fpregs = NULL;
1547#else
1548  void *fpregs = NULL;
1549#endif
1550#ifdef DARWIN
1551  MCONTEXT_T mcontextp = NULL;
1552#endif
1553  siginfo_t *info_copy = NULL;
1554  ExceptionInformation *xp = NULL;
1555  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1556
1557#ifdef LINUX
1558  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1559#endif
1560#ifdef DARWIN
1561  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1562#endif
1563#if UCONTEXT_ON_TOP_OF_STACK
1564  /* copy info first */
1565  foreign_rsp = copy_siginfo(info, foreign_rsp);
1566  info_copy = (siginfo_t *)foreign_rsp;
1567  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1568  xp = (ExceptionInformation *)foreign_rsp;
1569#else
1570  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1571  xp = (ExceptionInformation *)foreign_rsp;
1572  foreign_rsp = copy_siginfo(info, foreign_rsp);
1573  info_copy = (siginfo_t *)foreign_rsp;
1574#endif
1575#ifdef DARWIN
1576  UC_MCONTEXT(xp) = mcontextp;
1577#endif
1578  *--foreign_rsp = return_address;
1579#ifdef DARWIN_GS_HACK
1580  if (gs_was_tcr) {
1581    set_gs_address(tcr);
1582  }
1583#endif
1584  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1585}
1586#endif
1587
1588
1589#ifndef WINDOWS
1590#ifndef USE_SIGALTSTACK
1591void
1592arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1593{
1594  TCR *tcr = get_interrupt_tcr(false);
1595#if 1
1596  if (tcr->valence != TCR_STATE_LISP) {
1597    FBug(context, "exception in foreign context");
1598  }
1599#endif
1600  {
1601    area *vs = tcr->vs_area;
1602    BytePtr current_sp = (BytePtr) current_stack_pointer();
1603
1604
1605    if ((current_sp >= vs->low) &&
1606        (current_sp < vs->high)) {
1607      handle_signal_on_foreign_stack(tcr,
1608                                     signal_handler,
1609                                     signum,
1610                                     info,
1611                                     context,
1612                                     (LispObj)__builtin_return_address(0)
1613#ifdef DARWIN_GS_HACK
1614                                     , false
1615#endif
1616
1617                                     );
1618    } else {
1619      signal_handler(signum, info, context, tcr, 0);
1620    }
1621  }
1622}
1623
1624#else
1625void
1626altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1627{
1628  TCR* tcr = get_tcr(true);
1629#if 1
1630  if (tcr->valence != TCR_STATE_LISP) {
1631    FBug(context, "exception in foreign context");
1632  }
1633#endif
1634  handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1635#ifdef DARWIN_GS_HACK
1636                                 , false
1637#endif
1638);
1639}
1640#endif
1641#endif
1642
1643Boolean
1644stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr)
1645{
1646  area *a = tcr->vs_area;
1647 
1648  return (((BytePtr)stack_pointer <= a->high) &&
1649          ((BytePtr)stack_pointer > a->low));
1650}
1651
1652
1653#ifdef WINDOWS
1654extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int);
1655#endif
1656
1657void
1658interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1659{
1660#ifdef DARWIN_GS_HACK
1661  Boolean gs_was_tcr = ensure_gs_pthread();
1662#endif
1663  TCR *tcr = get_interrupt_tcr(false);
1664  int old_valence = tcr->valence;
1665
1666  if (tcr) {
1667    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1668        (tcr->valence != TCR_STATE_LISP) ||
1669        (tcr->unwinding != 0) ||
1670        ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) ||
1671#ifdef X8664
1672        ! stack_pointer_on_vstack_p(xpGPR(context,Irbp), tcr)) {
1673#else
1674        ! stack_pointer_on_vstack_p(xpGPR(context,Iebp), tcr)) {
1675#endif
1676      tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1)));
1677    } else {
1678      LispObj cmain = nrs_CMAIN.vcell;
1679
1680      if ((fulltag_of(cmain) == fulltag_misc) &&
1681          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1682        /*
1683           This thread can (allegedly) take an interrupt now.
1684        */
1685
1686        xframe_list xframe_link;
1687        signed_natural alloc_displacement = 0;
1688        LispObj
1689          *next_tsp = tcr->next_tsp,
1690          *save_tsp = tcr->save_tsp,
1691          *p,
1692          q;
1693        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1694
1695        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1696           
1697        if (next_tsp != save_tsp) {
1698          tcr->next_tsp = save_tsp;
1699        } else {
1700          next_tsp = NULL;
1701        }
1702        /* have to do this before allowing interrupts */
1703        pc_luser_xp(context, tcr, &alloc_displacement);
1704        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1705        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1706        handle_exception(signum, info, context, tcr, old_valence);
1707        if (alloc_displacement) {
1708          tcr->save_allocptr -= alloc_displacement;
1709        }
1710        if (next_tsp) {
1711          tcr->next_tsp = next_tsp;
1712          p = next_tsp;
1713          while (p != save_tsp) {
1714            *p++ = 0;
1715          }
1716          q = (LispObj)save_tsp;
1717          *next_tsp = q;
1718        }
1719        tcr->flags |= old_foreign_exception;
1720        unlock_exception_lock_in_handler(tcr);
1721#ifndef WINDOWS
1722        exit_signal_handler(tcr, old_valence);
1723#endif
1724      }
1725    }
1726  }
1727#ifdef DARWIN_GS_HACK
1728  if (gs_was_tcr) {
1729    set_gs_address(tcr);
1730  }
1731#endif
1732#ifdef WINDOWS
1733  restore_windows_context(context,tcr,old_valence);
1734#else
1735  SIGRETURN(context);
1736#endif
1737}
1738
1739
1740#ifndef WINDOWS
1741#ifndef USE_SIGALTSTACK
1742void
1743arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1744{
1745#ifdef DARWIN_GS_HACK
1746  Boolean gs_was_tcr = ensure_gs_pthread();
1747#endif
1748  TCR *tcr = get_interrupt_tcr(false);
1749  area *vs = tcr->vs_area;
1750  BytePtr current_sp = (BytePtr) current_stack_pointer();
1751
1752  if ((current_sp >= vs->low) &&
1753      (current_sp < vs->high)) {
1754    handle_signal_on_foreign_stack(tcr,
1755                                   interrupt_handler,
1756                                   signum,
1757                                   info,
1758                                   context,
1759                                   (LispObj)__builtin_return_address(0)
1760#ifdef DARWIN_GS_HACK
1761                                   ,gs_was_tcr
1762#endif
1763                                   );
1764  } else {
1765    /* If we're not on the value stack, we pretty much have to be on
1766       the C stack.  Just run the handler. */
1767#ifdef DARWIN_GS_HACK
1768    if (gs_was_tcr) {
1769      set_gs_address(tcr);
1770    }
1771#endif
1772    interrupt_handler(signum, info, context);
1773  }
1774}
1775
1776#else /* altstack works */
1777 
1778void
1779altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1780{
1781#ifdef DARWIN_GS_HACK
1782  Boolean gs_was_tcr = ensure_gs_pthread();
1783#endif
1784  TCR *tcr = get_interrupt_tcr(false);
1785  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1786#ifdef DARWIN_GS_HACK
1787                                 ,gs_was_tcr
1788#endif
1789                                 );
1790}
1791
1792#endif
1793#endif
1794
1795#ifndef WINDOWS
1796void
1797install_signal_handler(int signo, void * handler)
1798{
1799  struct sigaction sa;
1800 
1801  sa.sa_sigaction = (void *)handler;
1802  sigfillset(&sa.sa_mask);
1803#ifdef FREEBSD
1804  /* Strange FreeBSD behavior wrt synchronous signals */
1805  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1806#endif
1807  sa.sa_flags = 
1808    0 /* SA_RESTART */
1809#ifdef USE_SIGALTSTACK
1810    | SA_ONSTACK
1811#endif
1812    | SA_SIGINFO;
1813
1814  sigaction(signo, &sa, NULL);
1815}
1816#endif
1817
1818#ifdef WINDOWS
1819BOOL
1820CALLBACK ControlEventHandler(DWORD event)
1821{
1822  switch(event) {
1823  case CTRL_C_EVENT:
1824    lisp_global(INTFLAG) = (1 << fixnumshift);
1825    return TRUE;
1826    break;
1827  default:
1828    return FALSE;
1829  }
1830}
1831
1832static
1833DWORD mxcsr_bit_to_fpe_code[] = {
1834  EXCEPTION_FLT_INVALID_OPERATION, /* ie */
1835  0,                            /* de */
1836  EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */
1837  EXCEPTION_FLT_OVERFLOW,       /* oe */
1838  EXCEPTION_FLT_UNDERFLOW,      /* ue */
1839  EXCEPTION_FLT_INEXACT_RESULT  /* pe */
1840};
1841
1842#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
1843#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4
1844#endif
1845
1846#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
1847#define  STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5
1848#endif
1849
1850int
1851map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context)
1852{
1853  switch (code) {
1854#ifdef WIN_32
1855  case STATUS_FLOAT_MULTIPLE_FAULTS:
1856  case STATUS_FLOAT_MULTIPLE_TRAPS:
1857    {
1858      int xbit, maskbit;
1859      DWORD mxcsr = *(xpMXCSRptr(context));
1860
1861      for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
1862        if ((mxcsr & (1 << xbit)) &&
1863            !(mxcsr & (1 << maskbit))) {
1864          info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit];
1865          break;
1866        }
1867      }
1868    }
1869    return SIGFPE;
1870#endif
1871     
1872  case EXCEPTION_ACCESS_VIOLATION:
1873    return SIGSEGV;
1874  case EXCEPTION_FLT_DENORMAL_OPERAND:
1875  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
1876  case EXCEPTION_FLT_INEXACT_RESULT:
1877  case EXCEPTION_FLT_INVALID_OPERATION:
1878  case EXCEPTION_FLT_OVERFLOW:
1879  case EXCEPTION_FLT_STACK_CHECK:
1880  case EXCEPTION_FLT_UNDERFLOW:
1881  case EXCEPTION_INT_DIVIDE_BY_ZERO:
1882  case EXCEPTION_INT_OVERFLOW:
1883    return SIGFPE;
1884  case EXCEPTION_PRIV_INSTRUCTION:
1885  case EXCEPTION_ILLEGAL_INSTRUCTION:
1886    return SIGILL;
1887  case EXCEPTION_IN_PAGE_ERROR:
1888    return SIGBUS;
1889  default:
1890    return -1;
1891  }
1892}
1893
1894
1895LONG
1896windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr)
1897{
1898  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1899  int old_valence, signal_number;
1900  ExceptionInformation *context = exception_pointers->ContextRecord;
1901  siginfo_t *info = exception_pointers->ExceptionRecord;
1902  xframe_list xframes;
1903
1904  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1905  wait_for_exception_lock_in_handler(tcr, context, &xframes);
1906
1907  signal_number = map_windows_exception_code_to_posix_signal(code, info, context);
1908 
1909  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
1910    char msg[512];
1911    Boolean foreign = (old_valence != TCR_STATE_LISP);
1912
1913    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));
1914   
1915    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
1916      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1917    }
1918  }
1919  unlock_exception_lock_in_handler(tcr);
1920  return restore_windows_context(context, tcr, old_valence);
1921}
1922
1923void
1924setup_exception_handler_call(CONTEXT *context,
1925                             LispObj new_sp,
1926                             void *handler,
1927                             EXCEPTION_POINTERS *new_ep,
1928                             TCR *tcr)
1929{
1930  extern void windows_halt(void);
1931  LispObj *p = (LispObj *)new_sp;
1932#ifdef WIN_64
1933  p-=4;                         /* win64 abi argsave nonsense */
1934  *(--p) = (LispObj)windows_halt;
1935  context->Rsp = (DWORD64)p;
1936  context->Rip = (DWORD64)handler;
1937  context->Rcx = (DWORD64)new_ep;
1938  context->Rdx = (DWORD64)tcr;
1939#else
1940  p-=4;                          /* args on stack, stack aligned */
1941  p[0] = (LispObj)new_ep;
1942  p[1] = (LispObj)tcr;
1943  *(--p) = (LispObj)windows_halt;
1944  context->Esp = (DWORD)p;
1945  context->Eip = (DWORD)handler;
1946#ifdef WIN32_ES_HACK
1947  context->SegEs = context->SegDs;
1948#endif
1949#endif
1950  context->EFlags &= ~0x400;  /* clear direction flag */
1951}
1952
1953void
1954prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr,
1955                                                     CONTEXT *context,
1956                                                     void *handler,
1957                                                     EXCEPTION_POINTERS *original_ep)
1958{
1959  LispObj foreign_rsp = 
1960    (LispObj) (tcr->foreign_sp - 128) & ~15;
1961  CONTEXT *new_context;
1962  siginfo_t *new_info;
1963  EXCEPTION_POINTERS *new_ep;
1964
1965  new_context = ((CONTEXT *)(foreign_rsp&~15))-1;
1966  *new_context = *context;
1967  foreign_rsp = (LispObj)new_context;
1968  new_info = ((siginfo_t *)(foreign_rsp&~15))-1;
1969  *new_info = *original_ep->ExceptionRecord;
1970  foreign_rsp = (LispObj)new_info;
1971  new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1;
1972  foreign_rsp = (LispObj)new_ep & ~15;
1973  new_ep->ContextRecord = new_context;
1974  new_ep->ExceptionRecord = new_info;
1975  setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr);
1976}
1977
1978LONG CALLBACK
1979windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers)
1980{
1981  extern void ensure_safe_for_string_operations(void);
1982  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1983
1984
1985 
1986  if ((code & 0x80000000L) == 0) {
1987    return EXCEPTION_CONTINUE_SEARCH;
1988  } else {
1989    TCR *tcr = get_interrupt_tcr(false);
1990    area *cs = tcr->cs_area;
1991    BytePtr current_sp = (BytePtr) current_stack_pointer();
1992    CONTEXT *context = exception_pointers->ContextRecord;
1993   
1994    ensure_safe_for_string_operations();
1995
1996    if ((current_sp >= cs->low) &&
1997        (current_sp < cs->high)) {
1998      debug_show_registers(context, exception_pointers->ExceptionRecord, 0);
1999      FBug(context, "Exception on foreign stack\n");
2000      return EXCEPTION_CONTINUE_EXECUTION;
2001    }
2002
2003    prepare_to_handle_windows_exception_on_foreign_stack(tcr,
2004                                                         context,
2005                                                         windows_exception_handler,
2006                                                         exception_pointers);
2007    return EXCEPTION_CONTINUE_EXECUTION;
2008  }
2009}
2010
2011
2012void
2013install_pmcl_exception_handlers()
2014{
2015  AddVectoredExceptionHandler(1,windows_arbstack_exception_handler);
2016}
2017#else
2018void
2019install_pmcl_exception_handlers()
2020{
2021#ifndef DARWIN 
2022  void *handler = (void *)
2023#ifdef USE_SIGALTSTACK
2024    altstack_signal_handler
2025#else
2026    arbstack_signal_handler;
2027#endif
2028  ;
2029  install_signal_handler(SIGILL, handler);
2030 
2031  install_signal_handler(SIGBUS, handler);
2032  install_signal_handler(SIGSEGV,handler);
2033  install_signal_handler(SIGFPE, handler);
2034#endif
2035 
2036  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT,
2037#ifdef USE_SIGALTSTACK
2038                         altstack_interrupt_handler
2039#else
2040                         arbstack_interrupt_handler
2041#endif
2042);
2043  signal(SIGPIPE, SIG_IGN);
2044}
2045#endif
2046
2047#ifndef WINDOWS
2048#ifndef USE_SIGALTSTACK
2049void
2050arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
2051{
2052#ifdef DARWIN_GS_HACK
2053  Boolean gs_was_tcr = ensure_gs_pthread();
2054#endif
2055  TCR *tcr = get_interrupt_tcr(false);
2056  if (tcr != NULL) {
2057    area *vs = tcr->vs_area;
2058    BytePtr current_sp = (BytePtr) current_stack_pointer();
2059   
2060    if ((current_sp >= vs->low) &&
2061        (current_sp < vs->high)) {
2062      return
2063        handle_signal_on_foreign_stack(tcr,
2064                                       suspend_resume_handler,
2065                                       signum,
2066                                       info,
2067                                       context,
2068                                       (LispObj)__builtin_return_address(0)
2069#ifdef DARWIN_GS_HACK
2070                                       ,gs_was_tcr
2071#endif
2072                                       );
2073    } else {
2074      /* If we're not on the value stack, we pretty much have to be on
2075         the C stack.  Just run the handler. */
2076#ifdef DARWIN_GS_HACK
2077      if (gs_was_tcr) {
2078        set_gs_address(tcr);
2079      }
2080#endif
2081    }
2082  }
2083  suspend_resume_handler(signum, info, context);
2084}
2085
2086
2087#else /* altstack works */
2088void
2089altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
2090{
2091#ifdef DARWIN_GS_HACK
2092  Boolean gs_was_tcr = ensure_gs_pthread();
2093#endif
2094  TCR* tcr = get_tcr(true);
2095  handle_signal_on_foreign_stack(tcr,
2096                                 suspend_resume_handler,
2097                                 signum,
2098                                 info,
2099                                 context,
2100                                 (LispObj)__builtin_return_address(0)
2101#ifdef DARWIN_GS_HACK
2102                                 ,gs_was_tcr
2103#endif
2104                                 );
2105}
2106#endif
2107#endif
2108
2109
2110/* This should only be called when the tcr_area_lock is held */
2111void
2112empty_tcr_stacks(TCR *tcr)
2113{
2114  if (tcr) {
2115    area *a;
2116
2117    tcr->valence = TCR_STATE_FOREIGN;
2118    a = tcr->vs_area;
2119    if (a) {
2120      a->active = a->high;
2121    }
2122    a = tcr->ts_area;
2123    if (a) {
2124      a->active = a->high;
2125    }
2126    a = tcr->cs_area;
2127    if (a) {
2128      a->active = a->high;
2129    }
2130  }
2131}
2132
2133#ifdef WINDOWS
2134void
2135thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2136{
2137}
2138#else
2139void
2140thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2141{
2142#ifdef DARWIN_GS_HACK
2143  Boolean gs_was_tcr = ensure_gs_pthread();
2144#endif
2145  TCR *tcr = get_tcr(false);
2146  sigset_t mask;
2147
2148  sigemptyset(&mask);
2149
2150  empty_tcr_stacks(tcr);
2151
2152  pthread_sigmask(SIG_SETMASK,&mask,NULL);
2153  pthread_exit(NULL);
2154}
2155#endif
2156
2157#ifndef WINDOWS
2158#ifndef USE_SIGALTSTACK
2159void
2160arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2161{
2162#ifdef DARWIN_GS_HACK
2163  Boolean gs_was_tcr = ensure_gs_pthread();
2164#endif
2165  TCR *tcr = get_interrupt_tcr(false);
2166  area *vs = tcr->vs_area;
2167  BytePtr current_sp = (BytePtr) current_stack_pointer();
2168
2169  if ((current_sp >= vs->low) &&
2170      (current_sp < vs->high)) {
2171    handle_signal_on_foreign_stack(tcr,
2172                                   thread_kill_handler,
2173                                   signum,
2174                                   info,
2175                                   context,
2176                                   (LispObj)__builtin_return_address(0)
2177#ifdef DARWIN_GS_HACK
2178                                   ,gs_was_tcr
2179#endif
2180                                   );
2181  } else {
2182    /* If we're not on the value stack, we pretty much have to be on
2183       the C stack.  Just run the handler. */
2184#ifdef DARWIN_GS_HACK
2185    if (gs_was_tcr) {
2186      set_gs_address(tcr);
2187    }
2188#endif
2189    thread_kill_handler(signum, info, context);
2190  }
2191}
2192
2193
2194#else
2195void
2196altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2197{
2198#ifdef DARWIN_GS_HACK
2199  Boolean gs_was_tcr = ensure_gs_pthread();
2200#endif
2201  TCR* tcr = get_tcr(true);
2202  handle_signal_on_foreign_stack(tcr,
2203                                 thread_kill_handler,
2204                                 signum,
2205                                 info,
2206                                 context,
2207                                 (LispObj)__builtin_return_address(0)
2208#ifdef DARWIN_GS_HACK
2209                                 ,gs_was_tcr
2210#endif
2211                                 );
2212}
2213#endif
2214#endif
2215
2216#ifdef USE_SIGALTSTACK
2217#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
2218#define THREAD_KILL_HANDLER altstack_thread_kill_handler
2219#else
2220#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
2221#define THREAD_KILL_HANDLER arbstack_thread_kill_handler
2222#endif
2223
2224#ifdef WINDOWS
2225void
2226thread_signal_setup()
2227{
2228}
2229#else
2230void
2231thread_signal_setup()
2232{
2233  thread_suspend_signal = SIG_SUSPEND_THREAD;
2234  thread_kill_signal = SIG_KILL_THREAD;
2235
2236  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
2237  install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER);
2238}
2239#endif
2240
2241void
2242enable_fp_exceptions()
2243{
2244}
2245
2246void
2247exception_init()
2248{
2249  install_pmcl_exception_handlers();
2250}
2251
2252void
2253adjust_exception_pc(ExceptionInformation *xp, int delta)
2254{
2255  xpPC(xp) += delta;
2256}
2257
2258/*
2259  Lower (move toward 0) the "end" of the soft protected area associated
2260  with a by a page, if we can.
2261*/
2262
2263void
2264
2265adjust_soft_protection_limit(area *a)
2266{
2267  char *proposed_new_soft_limit = a->softlimit - 4096;
2268  protected_area_ptr p = a->softprot;
2269 
2270  if (proposed_new_soft_limit >= (p->start+16384)) {
2271    p->end = proposed_new_soft_limit;
2272    p->protsize = p->end-p->start;
2273    a->softlimit = proposed_new_soft_limit;
2274  }
2275  protect_area(p);
2276}
2277
2278void
2279restore_soft_stack_limit(unsigned restore_tsp)
2280{
2281  TCR *tcr = get_tcr(false);
2282  area *a;
2283 
2284  if (restore_tsp) {
2285    a = tcr->ts_area;
2286  } else {
2287    a = tcr->vs_area;
2288  }
2289  adjust_soft_protection_limit(a);
2290}
2291
2292
2293#ifdef USE_SIGALTSTACK
2294void
2295setup_sigaltstack(area *a)
2296{
2297  stack_t stack;
2298  stack.ss_sp = a->low;
2299  a->low += SIGSTKSZ*8;
2300  stack.ss_size = SIGSTKSZ*8;
2301  stack.ss_flags = 0;
2302  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
2303  if (sigaltstack(&stack, NULL) != 0) {
2304    perror("sigaltstack");
2305    exit(-1);
2306  }
2307}
2308#endif
2309
2310extern opcode egc_write_barrier_start, egc_write_barrier_end,
2311  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2312  egc_set_hash_key_conditional_retry,
2313  egc_store_node_conditional_success_end, egc_store_node_conditional_retry,
2314  egc_store_node_conditional_success_test,egc_store_node_conditional,
2315  egc_set_hash_key, egc_gvset, egc_rplacd;
2316
2317/* We use (extremely) rigidly defined instruction sequences for consing,
2318   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2319   while consing.
2320
2321   Note that we can usually identify which of these instructions is about
2322   to be executed by a stopped thread without comparing all of the bytes
2323   to those at the stopped program counter, but we generally need to
2324   know the sizes of each of these instructions.
2325*/
2326
2327#ifdef X8664
2328opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2329#ifdef WINDOWS
2330  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2331#else
2332  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2333#endif
2334;
2335opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2336#ifdef WINDOWS
2337  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2338#else
2339  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2340#endif
2341
2342;
2343opcode branch_around_alloc_trap_instruction[] =
2344  {0x77,0x02};
2345opcode alloc_trap_instruction[] =
2346  {0xcd,0xc5};
2347opcode clear_tcr_save_allocptr_tag_instruction[] =
2348#ifdef WINDOWS
2349  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2350#else
2351  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2352#endif
2353;
2354opcode set_allocptr_header_instruction[] =
2355  {0x48,0x89,0x43,0xf3};
2356
2357
2358alloc_instruction_id
2359recognize_alloc_instruction(pc program_counter)
2360{
2361  switch(program_counter[0]) {
2362  case 0xcd: return ID_alloc_trap_instruction;
2363  /* 0x7f is jg, which we used to use here instead of ja */
2364  case 0x7f:
2365  case 0x77: return ID_branch_around_alloc_trap_instruction;
2366  case 0x48: return ID_set_allocptr_header_instruction;
2367#ifdef WINDOWS
2368  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2369  case 0x49:
2370    switch(program_counter[1]) {
2371    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2372    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2373    }
2374#else
2375  case 0x65: 
2376    switch(program_counter[1]) {
2377    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2378    case 0x48:
2379      switch(program_counter[2]) {
2380      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2381      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2382      }
2383    }
2384#endif
2385  default: break;
2386  }
2387  return ID_unrecognized_alloc_instruction;
2388}
2389#endif
2390#ifdef X8632
2391/* The lisp assembler might use both a modrm byte and a sib byte to
2392   encode a memory operand that contains a displacement but no
2393   base or index.  Using the sib byte is necessary for 64-bit code,
2394   since the sib-less form is used to indicate %rip-relative addressing
2395   on x8664.  On x8632, it's not necessary, slightly suboptimal, and
2396   doesn't match what we expect; until that's fixed, we may need to
2397   account for this extra byte when adjusting the PC */
2398#define LISP_ASSEMBLER_EXTRA_SIB_BYTE
2399#ifdef WIN32_ES_HACK
2400/* Win32 keeps the TCR in %es */
2401#define TCR_SEG_PREFIX 0x26     /* %es: */
2402#else
2403/* Other platfroms use %fs */
2404#define TCR_SEG_PREFIX 0x64     /* %fs: */
2405#endif
2406opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2407  {TCR_SEG_PREFIX,0x8b,0x0d,0x84,0x00,0x00,0x00};  /* may have extra SIB byte */
2408opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2409  {TCR_SEG_PREFIX,0x3b,0x0d,0x88,0x00,0x00,0x00};  /* may have extra SIB byte */
2410opcode branch_around_alloc_trap_instruction[] =
2411  {0x77,0x02};                  /* no SIB byte issue */
2412opcode alloc_trap_instruction[] =
2413  {0xcd,0xc5};                  /* no SIB byte issue */
2414opcode clear_tcr_save_allocptr_tag_instruction[] =
2415  {TCR_SEG_PREFIX,0x80,0x25,0x84,0x00,0x00,0x00,0xf8}; /* maybe SIB byte */
2416opcode set_allocptr_header_instruction[] =
2417  {0x0f,0x7e,0x41,0xfa};        /* no SIB byte issue */
2418
2419alloc_instruction_id
2420recognize_alloc_instruction(pc program_counter)
2421{
2422  switch(program_counter[0]) {
2423  case 0xcd: return ID_alloc_trap_instruction;
2424  /* 0x7f is jg, which we used to use here instead of ja */
2425  case 0x7f:
2426  case 0x77: return ID_branch_around_alloc_trap_instruction;
2427  case 0x0f: return ID_set_allocptr_header_instruction;
2428  case TCR_SEG_PREFIX: 
2429    switch(program_counter[1]) {
2430    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2431    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2432    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2433    }
2434  }
2435  return ID_unrecognized_alloc_instruction;
2436}
2437#endif     
2438
2439void
2440pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2441{
2442  pc program_counter = (pc)xpPC(xp);
2443  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2444
2445  if (allocptr_tag != 0) {
2446    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2447    signed_natural
2448      disp = (allocptr_tag == fulltag_cons) ?
2449      sizeof(cons) - fulltag_cons :
2450#ifdef X8664
2451      xpGPR(xp,Iimm1)
2452#else
2453      xpGPR(xp,Iimm0)
2454#endif
2455      ;
2456    LispObj new_vector;
2457
2458    if ((state == ID_unrecognized_alloc_instruction) ||
2459        ((state == ID_set_allocptr_header_instruction) &&
2460         (allocptr_tag != fulltag_misc))) {
2461      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2462    }
2463    switch(state) {
2464    case ID_set_allocptr_header_instruction:
2465      /* We were consing a vector and we won.  Set the header of the
2466         new vector (in the allocptr register) to the header in %rax
2467         (%mm0 on ia32) and skip over this instruction, then fall into
2468         the next case. */
2469      new_vector = xpGPR(xp,Iallocptr);
2470      deref(new_vector,0) = 
2471#ifdef X8664
2472        xpGPR(xp,Iimm0)
2473#else
2474        xpMMXreg(xp,Imm0)
2475#endif
2476        ;
2477     
2478      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2479
2480      /* Fall thru */
2481    case ID_clear_tcr_save_allocptr_tag_instruction:
2482      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2483#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2484      if (((pc)(xpPC(xp)))[2] == 0x24) {
2485        xpPC(xp) += 1;
2486      }
2487#endif
2488      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2489
2490      break;
2491    case ID_alloc_trap_instruction:
2492      /* If we're looking at another thread, we're pretty much committed to
2493         taking the trap.  We don't want the allocptr register to be pointing
2494         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2495         was determined above.
2496      */
2497      if (interrupt_displacement == NULL) {
2498        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2499        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2500      } else {
2501        /* Back out, and tell the caller how to resume the allocation attempt */
2502        *interrupt_displacement = disp;
2503        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2504        tcr->save_allocptr += disp;
2505#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2506        /* This assumes that TCR_SEG_PREFIX can't appear
2507           anywhere but at the beginning of one of these
2508           magic allocation-sequence instructions. */
2509        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2510                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction));
2511        if (*((pc)(xpPC(xp))) == TCR_SEG_PREFIX) {
2512          xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2513        } else {
2514          xpPC(xp) -= (sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction) + 2);
2515        }
2516       
2517#else
2518        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2519                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2520                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2521#endif
2522      }
2523      break;
2524    case ID_branch_around_alloc_trap_instruction:
2525      /* If we'd take the branch - which is a "ja" - around the alloc trap,
2526         we might as well finish the allocation.  Otherwise, back out of the
2527         attempt. */
2528      {
2529        int flags = (int)eflags_register(xp);
2530       
2531        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2532            (!(flags & (1 << X86_CARRY_FLAG_BIT)))) {
2533          /* The branch (ja) would have been taken.  Emulate taking it. */
2534          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2535                       sizeof(alloc_trap_instruction));
2536          if (allocptr_tag == fulltag_misc) {
2537            /* Slap the header on the new uvector */
2538            new_vector = xpGPR(xp,Iallocptr);
2539            deref(new_vector,0) = xpGPR(xp,Iimm0);
2540            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2541          }
2542          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2543#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2544          if (((pc)xpPC(xp))[2] == 0x24) {
2545            xpPC(xp) += 1;
2546          }
2547#endif
2548          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2549        } else {
2550          /* Back up */
2551          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2552                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2553#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2554          if (*((pc)(xpPC(xp))) != TCR_SEG_PREFIX) {
2555            /* skipped two instructions with extra SIB byte */
2556            xpPC(xp) -= 2;
2557          }
2558#endif
2559          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2560          if (interrupt_displacement) {
2561            *interrupt_displacement = disp;
2562            tcr->save_allocptr += disp;
2563          } else {
2564            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2565          }
2566        }
2567      }
2568      break;
2569    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2570      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2571      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2572#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2573      if (*((pc)xpPC(xp)) != TCR_SEG_PREFIX) {
2574        xpPC(xp) -= 1;
2575      }
2576#endif
2577      /* Fall through */
2578    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2579      if (interrupt_displacement) {
2580        tcr->save_allocptr += disp;
2581        *interrupt_displacement = disp;
2582      } else {
2583        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2584      }
2585      break;
2586    default: 
2587      break;
2588    }
2589    return;
2590  }
2591  if ((program_counter >= &egc_write_barrier_start) &&
2592      (program_counter < &egc_write_barrier_end)) {
2593    LispObj *ea = 0, val, root = 0;
2594    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2595    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
2596
2597    if (program_counter >= &egc_set_hash_key_conditional) {
2598      if (program_counter <= &egc_set_hash_key_conditional_retry) {
2599        return;
2600      }
2601      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
2602          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2603           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2604        /* Back up the PC, try again */
2605        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry;
2606        return;
2607      }
2608      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2609      val = xpGPR(xp,Iarg_z);
2610#ifdef X8664
2611      root = xpGPR(xp,Iarg_x);
2612      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2613#else
2614      root = xpGPR(xp,Itemp1);
2615      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2616#endif
2617      need_memoize_root = true;
2618      need_store = false;
2619      xpGPR(xp,Iarg_z) = t_value;
2620    } else if (program_counter >= &egc_store_node_conditional) {
2621      if (program_counter <= &egc_store_node_conditional_retry) {
2622        return;
2623      }
2624      if ((program_counter < &egc_store_node_conditional_success_test) ||
2625          ((program_counter == &egc_store_node_conditional_success_test) &&
2626           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2627        /* Back up the PC, try again */
2628        xpPC(xp) = (LispObj) &egc_store_node_conditional_retry;
2629        return;
2630      }
2631      if (program_counter >= &egc_store_node_conditional_success_end) {
2632        return;
2633      }
2634
2635      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2636      val = xpGPR(xp,Iarg_z);
2637#ifdef X8664
2638      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2639                                                       xpGPR(xp,Itemp0))));
2640#else
2641      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2642#endif
2643      xpGPR(xp,Iarg_z) = t_value;
2644      need_store = false;
2645    } else if (program_counter >= &egc_set_hash_key) {
2646#ifdef X8664
2647      root = xpGPR(xp,Iarg_x);
2648#else
2649      root = xpGPR(xp,Itemp0);
2650#endif
2651      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2652      val = xpGPR(xp,Iarg_z);
2653      need_memoize_root = true;
2654    } else if (program_counter >= &egc_gvset) {
2655#ifdef X8664
2656      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2657#else
2658      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2659#endif
2660      val = xpGPR(xp,Iarg_z);
2661    } else if (program_counter >= &egc_rplacd) {
2662      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2663      val = xpGPR(xp,Iarg_z);
2664    } else {                      /* egc_rplaca */
2665      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2666      val = xpGPR(xp,Iarg_z);
2667    }
2668    if (need_store) {
2669      *ea = val;
2670    }
2671    if (need_check_memo) {
2672      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
2673      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
2674          ((LispObj)ea < val)) {
2675        atomic_set_bit(refbits, bitnumber);
2676        if (need_memoize_root) {
2677          bitnumber = area_dnode(root, lisp_global(HEAP_START));
2678          atomic_set_bit(refbits, bitnumber);
2679        }
2680      }
2681    }
2682    {
2683      /* These subprimitives are called via CALL/RET; need
2684         to pop the return address off the stack and set
2685         the PC there. */
2686      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2687      xpPC(xp) = ra;
2688      xpGPR(xp,Isp)=(LispObj)sp;
2689    }
2690    return;
2691  }
2692}
2693
2694
2695void
2696normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2697{
2698  void *cur_allocptr = (void *)(tcr->save_allocptr);
2699  LispObj lisprsp;
2700  area *a;
2701
2702  if (xp) {
2703    if (is_other_tcr) {
2704      pc_luser_xp(xp, tcr, NULL);
2705    }
2706    a = tcr->vs_area;
2707    lisprsp = xpGPR(xp, Isp);
2708    if (((BytePtr)lisprsp >= a->low) &&
2709        ((BytePtr)lisprsp < a->high)) {
2710      a->active = (BytePtr)lisprsp;
2711    } else {
2712      a->active = (BytePtr) tcr->save_vsp;
2713    }
2714    a = tcr->ts_area;
2715    a->active = (BytePtr) tcr->save_tsp;
2716  } else {
2717    /* In ff-call; get area active pointers from tcr */
2718    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2719    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2720  }
2721  if (cur_allocptr) {
2722    update_bytes_allocated(tcr, cur_allocptr);
2723  }
2724  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2725  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2726    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2727  }
2728}
2729
2730
2731/* Suspend and "normalize" other tcrs, then call a gc-like function
2732   in that context.  Resume the other tcrs, then return what the
2733   function returned */
2734
2735TCR *gc_tcr = NULL;
2736
2737
2738signed_natural
2739gc_like_from_xp(ExceptionInformation *xp, 
2740                signed_natural(*fun)(TCR *, signed_natural), 
2741                signed_natural param)
2742{
2743  TCR *tcr = get_tcr(false), *other_tcr;
2744  int result;
2745  signed_natural inhibit;
2746
2747  suspend_other_threads(true);
2748  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2749  if (inhibit != 0) {
2750    if (inhibit > 0) {
2751      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2752    }
2753    resume_other_threads(true);
2754    gc_deferred++;
2755    return 0;
2756  }
2757  gc_deferred = 0;
2758
2759  gc_tcr = tcr;
2760
2761  /* This is generally necessary if the current thread invoked the GC
2762     via an alloc trap, and harmless if the GC was invoked via a GC
2763     trap.  (It's necessary in the first case because the "allocptr"
2764     register - %rbx - may be pointing into the middle of something
2765     below tcr->save_allocbase, and we wouldn't want the GC to see
2766     that bogus pointer.) */
2767  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2768
2769  normalize_tcr(xp, tcr, false);
2770
2771
2772  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
2773    if (other_tcr->pending_exception_context) {
2774      other_tcr->gc_context = other_tcr->pending_exception_context;
2775    } else if (other_tcr->valence == TCR_STATE_LISP) {
2776      other_tcr->gc_context = other_tcr->suspend_context;
2777    } else {
2778      /* no pending exception, didn't suspend in lisp state:
2779         must have executed a synchronous ff-call.
2780      */
2781      other_tcr->gc_context = NULL;
2782    }
2783    normalize_tcr(other_tcr->gc_context, other_tcr, true);
2784  }
2785   
2786
2787
2788  result = fun(tcr, param);
2789
2790  other_tcr = tcr;
2791  do {
2792    other_tcr->gc_context = NULL;
2793    other_tcr = other_tcr->next;
2794  } while (other_tcr != tcr);
2795
2796  gc_tcr = NULL;
2797
2798  resume_other_threads(true);
2799
2800  return result;
2801
2802}
2803
2804signed_natural
2805purify_from_xp(ExceptionInformation *xp, signed_natural param)
2806{
2807  return gc_like_from_xp(xp, purify, param);
2808}
2809
2810signed_natural
2811impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2812{
2813  return gc_like_from_xp(xp, impurify, param);
2814}
2815
2816/* Returns #bytes freed by invoking GC */
2817
2818signed_natural
2819gc_from_tcr(TCR *tcr, signed_natural param)
2820{
2821  area *a;
2822  BytePtr oldfree, newfree;
2823  BytePtr oldend, newend;
2824
2825#if 0
2826  fprintf(dbgout, "Start GC  in 0x" LISP "\n", tcr);
2827#endif
2828  a = active_dynamic_area;
2829  oldend = a->high;
2830  oldfree = a->active;
2831  gc(tcr, param);
2832  newfree = a->active;
2833  newend = a->high;
2834#if 0
2835  fprintf(dbgout, "End GC  in 0x" LISP "\n", tcr);
2836#endif
2837  return ((oldfree-newfree)+(newend-oldend));
2838}
2839
2840signed_natural
2841gc_from_xp(ExceptionInformation *xp, signed_natural param)
2842{
2843  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
2844
2845  freeGCptrs();
2846  return status;
2847}
2848
2849#ifdef DARWIN
2850
2851#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2852#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2853
2854extern void pseudo_sigreturn(void);
2855
2856
2857
2858#define LISP_EXCEPTIONS_HANDLED_MASK \
2859 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2860
2861/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2862#define NUM_LISP_EXCEPTIONS_HANDLED 4
2863
2864typedef struct {
2865  int foreign_exception_port_count;
2866  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2867  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2868  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2869  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2870} MACH_foreign_exception_state;
2871
2872
2873
2874
2875/*
2876  Mach's exception mechanism works a little better than its signal
2877  mechanism (and, not incidentally, it gets along with GDB a lot
2878  better.
2879
2880  Initially, we install an exception handler to handle each native
2881  thread's exceptions.  This process involves creating a distinguished
2882  thread which listens for kernel exception messages on a set of
2883  0 or more thread exception ports.  As threads are created, they're
2884  added to that port set; a thread's exception port is destroyed
2885  (and therefore removed from the port set) when the thread exits.
2886
2887  A few exceptions can be handled directly in the handler thread;
2888  others require that we resume the user thread (and that the
2889  exception thread resumes listening for exceptions.)  The user
2890  thread might eventually want to return to the original context
2891  (possibly modified somewhat.)
2892
2893  As it turns out, the simplest way to force the faulting user
2894  thread to handle its own exceptions is to do pretty much what
2895  signal() does: the exception handlng thread sets up a sigcontext
2896  on the user thread's stack and forces the user thread to resume
2897  execution as if a signal handler had been called with that
2898  context as an argument.  We can use a distinguished UUO at a
2899  distinguished address to do something like sigreturn(); that'll
2900  have the effect of resuming the user thread's execution in
2901  the (pseudo-) signal context.
2902
2903  Since:
2904    a) we have miles of code in C and in Lisp that knows how to
2905    deal with Linux sigcontexts
2906    b) Linux sigcontexts contain a little more useful information
2907    (the DAR, DSISR, etc.) than their Darwin counterparts
2908    c) we have to create a sigcontext ourselves when calling out
2909    to the user thread: we aren't really generating a signal, just
2910    leveraging existing signal-handling code.
2911
2912  we create a Linux sigcontext struct.
2913
2914  Simple ?  Hopefully from the outside it is ...
2915
2916  We want the process of passing a thread's own context to it to
2917  appear to be atomic: in particular, we don't want the GC to suspend
2918  a thread that's had an exception but has not yet had its user-level
2919  exception handler called, and we don't want the thread's exception
2920  context to be modified by a GC while the Mach handler thread is
2921  copying it around.  On Linux (and on Jaguar), we avoid this issue
2922  because (a) the kernel sets up the user-level signal handler and
2923  (b) the signal handler blocks signals (including the signal used
2924  by the GC to suspend threads) until tcr->xframe is set up.
2925
2926  The GC and the Mach server thread therefore contend for the lock
2927  "mach_exception_lock".  The Mach server thread holds the lock
2928  when copying exception information between the kernel and the
2929  user thread; the GC holds this lock during most of its execution
2930  (delaying exception processing until it can be done without
2931  GC interference.)
2932
2933*/
2934
2935#ifdef PPC64
2936#define C_REDZONE_LEN           320
2937#define C_STK_ALIGN             32
2938#else
2939#define C_REDZONE_LEN           224
2940#define C_STK_ALIGN             16
2941#endif
2942#define C_PARAMSAVE_LEN         64
2943#define C_LINKAGE_LEN           48
2944
2945#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2946
2947void
2948fatal_mach_error(char *format, ...);
2949
2950#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2951
2952
2953void
2954restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2955{
2956  kern_return_t kret;
2957#if WORD_SIZE == 64
2958  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2959#else
2960  mcontext_t mc = UC_MCONTEXT(pseudosigcontext);
2961#endif
2962
2963  /* Set the thread's FP state from the pseudosigcontext */
2964#if WORD_SIZE == 64
2965  kret = thread_set_state(thread,
2966                          x86_FLOAT_STATE64,
2967                          (thread_state_t)&(mc->__fs),
2968                          x86_FLOAT_STATE64_COUNT);
2969#else
2970  kret = thread_set_state(thread,
2971                          x86_FLOAT_STATE32,
2972                          (thread_state_t)&(mc->__fs),
2973                          x86_FLOAT_STATE32_COUNT);
2974#endif
2975  MACH_CHECK_ERROR("setting thread FP state", kret);
2976
2977  /* The thread'll be as good as new ... */
2978#if WORD_SIZE == 64
2979  kret = thread_set_state(thread,
2980                          x86_THREAD_STATE64,
2981                          (thread_state_t)&(mc->__ss),
2982                          x86_THREAD_STATE64_COUNT);
2983#else
2984  kret = thread_set_state(thread, 
2985                          x86_THREAD_STATE32,
2986                          (thread_state_t)&(mc->__ss),
2987                          x86_THREAD_STATE32_COUNT);
2988#endif
2989  MACH_CHECK_ERROR("setting thread state", kret);
2990} 
2991
2992/* This code runs in the exception handling thread, in response
2993   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2994   in response to a call to pseudo_sigreturn() from the specified
2995   user thread.
2996   Find that context (the user thread's R3 points to it), then
2997   use that context to set the user thread's state.  When this
2998   function's caller returns, the Mach kernel will resume the
2999   user thread.
3000*/
3001
3002kern_return_t
3003do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
3004{
3005  ExceptionInformation *xp;
3006
3007#ifdef DEBUG_MACH_EXCEPTIONS
3008  fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr);
3009#endif
3010  xp = tcr->pending_exception_context;
3011  if (xp) {
3012    tcr->pending_exception_context = NULL;
3013    tcr->valence = TCR_STATE_LISP;
3014    restore_mach_thread_state(thread, xp);
3015    raise_pending_interrupt(tcr);
3016  } else {
3017    Bug(NULL, "no xp here!\n");
3018  }
3019#ifdef DEBUG_MACH_EXCEPTIONS
3020  fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr);
3021#endif
3022  return KERN_SUCCESS;
3023} 
3024
3025ExceptionInformation *
3026create_thread_context_frame(mach_port_t thread, 
3027                            natural *new_stack_top,
3028                            siginfo_t **info_ptr,
3029                            TCR *tcr,
3030#ifdef X8664
3031                            x86_thread_state64_t *ts
3032#else
3033                            x86_thread_state32_t *ts
3034#endif
3035                            )
3036{
3037  mach_msg_type_number_t thread_state_count;
3038  ExceptionInformation *pseudosigcontext;
3039#ifdef X8664
3040  MCONTEXT_T mc;
3041#else
3042  mcontext_t mc;
3043#endif
3044  natural stackp;
3045
3046#ifdef X8664 
3047  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
3048  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
3049#else
3050  stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr);
3051#endif
3052  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
3053  if (info_ptr) {
3054    *info_ptr = (siginfo_t *)stackp;
3055  }
3056  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
3057  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
3058
3059  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
3060  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
3061 
3062  memmove(&(mc->__ss),ts,sizeof(*ts));
3063
3064#ifdef X8664
3065  thread_state_count = x86_FLOAT_STATE64_COUNT;
3066  thread_get_state(thread,
3067                   x86_FLOAT_STATE64,
3068                   (thread_state_t)&(mc->__fs),
3069                   &thread_state_count);
3070
3071  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
3072  thread_get_state(thread,
3073                   x86_EXCEPTION_STATE64,
3074                   (thread_state_t)&(mc->__es),
3075                   &thread_state_count);
3076#else
3077  thread_state_count = x86_FLOAT_STATE32_COUNT;
3078  thread_get_state(thread,
3079                   x86_FLOAT_STATE32,
3080                   (thread_state_t)&(mc->__fs),
3081                   &thread_state_count);
3082
3083  thread_state_count = x86_EXCEPTION_STATE32_COUNT;
3084  thread_get_state(thread,
3085                   x86_EXCEPTION_STATE32,
3086                   (thread_state_t)&(mc->__es),
3087                   &thread_state_count);
3088#endif
3089
3090
3091  UC_MCONTEXT(pseudosigcontext) = mc;
3092  if (new_stack_top) {
3093    *new_stack_top = stackp;
3094  }
3095  return pseudosigcontext;
3096}
3097
3098/*
3099  This code sets up the user thread so that it executes a "pseudo-signal
3100  handler" function when it resumes.  Create a fake ucontext struct
3101  on the thread's stack and pass it as an argument to the pseudo-signal
3102  handler.
3103
3104  Things are set up so that the handler "returns to" pseudo_sigreturn(),
3105  which will restore the thread's context.
3106
3107  If the handler invokes code that throws (or otherwise never sigreturn()'s
3108  to the context), that's fine.
3109
3110  Actually, check that: throw (and variants) may need to be careful and
3111  pop the tcr's xframe list until it's younger than any frame being
3112  entered.
3113*/
3114
3115int
3116setup_signal_frame(mach_port_t thread,
3117                   void *handler_address,
3118                   int signum,
3119                   int code,
3120                   TCR *tcr,
3121#ifdef X8664
3122                   x86_thread_state64_t *ts
3123#else
3124                   x86_thread_state32_t *ts
3125#endif
3126                   )
3127{
3128#ifdef X8664
3129  x86_thread_state64_t new_ts;
3130#else
3131  x86_thread_state32_t new_ts;
3132#endif
3133  ExceptionInformation *pseudosigcontext;
3134  int  old_valence = tcr->valence;
3135  natural stackp, *stackpp;
3136  siginfo_t *info;
3137
3138#ifdef DEBUG_MACH_EXCEPTIONS
3139  fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr);
3140#endif
3141  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
3142  bzero(info, sizeof(*info));
3143  info->si_code = code;
3144  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
3145  info->si_signo = signum;
3146  pseudosigcontext->uc_onstack = 0;
3147  pseudosigcontext->uc_sigmask = (sigset_t) 0;
3148  pseudosigcontext->uc_stack.ss_sp = 0;
3149  pseudosigcontext->uc_stack.ss_size = 0;
3150  pseudosigcontext->uc_stack.ss_flags = 0;
3151  pseudosigcontext->uc_link = NULL;
3152  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
3153  tcr->pending_exception_context = pseudosigcontext;
3154  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
3155 
3156
3157  /*
3158     It seems like we've created a  sigcontext on the thread's
3159     stack.  Set things up so that we call the handler (with appropriate
3160     args) when the thread's resumed.
3161  */
3162
3163#ifdef X8664
3164  new_ts.__rip = (natural) handler_address;
3165  stackpp = (natural *)stackp;
3166  *--stackpp = (natural)pseudo_sigreturn;
3167  stackp = (natural)stackpp;
3168  new_ts.__rdi = signum;
3169  new_ts.__rsi = (natural)info;
3170  new_ts.__rdx = (natural)pseudosigcontext;
3171  new_ts.__rcx = (natural)tcr;
3172  new_ts.__r8 = (natural)old_valence;
3173  new_ts.__rsp = stackp;
3174  new_ts.__rflags = ts->__rflags;
3175#else
3176#define USER_CS 0x17
3177#define USER_DS 0x1f
3178  bzero(&new_ts, sizeof(new_ts));
3179  new_ts.__cs = ts->__cs;
3180  new_ts.__ss = ts->__ss;
3181  new_ts.__ds = ts->__ds;
3182  new_ts.__es = ts->__es;
3183  new_ts.__fs = ts->__fs;
3184  new_ts.__gs = ts->__gs;
3185
3186  new_ts.__eip = (natural)handler_address;
3187  stackpp = (natural *)stackp;
3188  *--stackpp = 0;               /* alignment */
3189  *--stackpp = 0;
3190  *--stackpp = 0;
3191  *--stackpp = (natural)old_valence;
3192  *--stackpp = (natural)tcr;
3193  *--stackpp = (natural)pseudosigcontext;
3194  *--stackpp = (natural)info;
3195  *--stackpp = (natural)signum;
3196  *--stackpp = (natural)pseudo_sigreturn;
3197  stackp = (natural)stackpp;
3198  new_ts.__esp = stackp;
3199  new_ts.__eflags = ts->__eflags;
3200#endif
3201
3202#ifdef X8664
3203  thread_set_state(thread,
3204                   x86_THREAD_STATE64,
3205                   (thread_state_t)&new_ts,
3206                   x86_THREAD_STATE64_COUNT);
3207#else
3208  thread_set_state(thread, 
3209                   x86_THREAD_STATE32,
3210                   (thread_state_t)&new_ts,
3211                   x86_THREAD_STATE32_COUNT);
3212#endif
3213#ifdef DEBUG_MACH_EXCEPTIONS
3214  fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
3215#endif
3216  return 0;
3217}
3218
3219
3220
3221
3222
3223
3224/*
3225  This function runs in the exception handling thread.  It's
3226  called (by this precise name) from the library function "exc_server()"
3227  when the thread's exception ports are set up.  (exc_server() is called
3228  via mach_msg_server(), which is a function that waits for and dispatches
3229  on exception messages from the Mach kernel.)
3230
3231  This checks to see if the exception was caused by a pseudo_sigreturn()
3232  UUO; if so, it arranges for the thread to have its state restored
3233  from the specified context.
3234
3235  Otherwise, it tries to map the exception to a signal number and
3236  arranges that the thread run a "pseudo signal handler" to handle
3237  the exception.
3238
3239  Some exceptions could and should be handled here directly.
3240*/
3241
3242/* We need the thread's state earlier on x86_64 than we did on PPC;
3243   the PC won't fit in code_vector[1].  We shouldn't try to get it
3244   lazily (via catch_exception_raise_state()); until we own the
3245   exception lock, we shouldn't have it in userspace (since a GCing
3246   thread wouldn't know that we had our hands on it.)
3247*/
3248
3249#ifdef X8664
3250#define ts_pc(t) t.__rip
3251#else
3252#define ts_pc(t) t.__eip
3253#endif
3254
3255
3256#define DARWIN_EXCEPTION_HANDLER signal_handler
3257
3258
3259kern_return_t
3260catch_exception_raise(mach_port_t exception_port,
3261                      mach_port_t thread,
3262                      mach_port_t task, 
3263                      exception_type_t exception,
3264                      exception_data_t code_vector,
3265                      mach_msg_type_number_t code_count)
3266{
3267  int signum = 0, code = *code_vector;
3268  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
3269  kern_return_t kret, call_kret;
3270#ifdef X8664
3271  x86_thread_state64_t ts;
3272#else
3273  x86_thread_state32_t ts;
3274#endif
3275  mach_msg_type_number_t thread_state_count;
3276
3277
3278
3279
3280#ifdef DEBUG_MACH_EXCEPTIONS
3281  fprintf(dbgout, "obtaining Mach exception lock in exception thread\n");
3282#endif
3283
3284
3285  if (1) {
3286#ifdef X8664
3287    do {
3288      thread_state_count = x86_THREAD_STATE64_COUNT;
3289      call_kret = thread_get_state(thread,
3290                                   x86_THREAD_STATE64,
3291                                   (thread_state_t)&ts,
3292                                   &thread_state_count);
3293    } while (call_kret == KERN_ABORTED);
3294  MACH_CHECK_ERROR("getting thread state",call_kret);
3295#else
3296    thread_state_count = x86_THREAD_STATE32_COUNT;
3297    call_kret = thread_get_state(thread,
3298                                 x86_THREAD_STATE32,
3299                                 (thread_state_t)&ts,
3300                                 &thread_state_count);
3301    MACH_CHECK_ERROR("getting thread state",call_kret);
3302#endif
3303    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
3304      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
3305    } 
3306    if ((code == EXC_I386_GPFLT) &&
3307        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
3308      kret = do_pseudo_sigreturn(thread, tcr);
3309#if 0
3310      fprintf(dbgout, "Exception return in 0x%x\n",tcr);
3311#endif
3312    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
3313      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
3314      kret = 17;
3315    } else {
3316      switch (exception) {
3317      case EXC_BAD_ACCESS:
3318        if (code == EXC_I386_GPFLT) {
3319          signum = SIGSEGV;
3320        } else {
3321          signum = SIGBUS;
3322        }
3323        break;
3324       
3325      case EXC_BAD_INSTRUCTION:
3326        if (code == EXC_I386_GPFLT) {
3327          signum = SIGSEGV;
3328        } else {
3329          signum = SIGILL;
3330        }
3331        break;
3332         
3333      case EXC_SOFTWARE:
3334        signum = SIGILL;
3335        break;
3336       
3337      case EXC_ARITHMETIC:
3338        signum = SIGFPE;
3339        break;
3340       
3341      default:
3342        break;
3343      }
3344      if (signum) {
3345        kret = setup_signal_frame(thread,
3346                                  (void *)DARWIN_EXCEPTION_HANDLER,
3347                                  signum,
3348                                  code,
3349                                  tcr, 
3350                                  &ts);
3351#if 0
3352        fprintf(dbgout, "Setup pseudosignal handling in 0x%x\n",tcr);
3353#endif
3354       
3355      } else {
3356        kret = 17;
3357      }
3358    }
3359  }
3360  return kret;
3361}
3362
3363
3364
3365
3366static mach_port_t mach_exception_thread = (mach_port_t)0;
3367
3368
3369/*
3370  The initial function for an exception-handling thread.
3371*/
3372
3373void *
3374exception_handler_proc(void *arg)
3375{
3376  extern boolean_t exc_server();
3377  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
3378
3379  mach_exception_thread = pthread_mach_thread_np(pthread_self());
3380  mach_msg_server(exc_server, 256, p, 0);
3381  /* Should never return. */
3382  abort();
3383}
3384
3385
3386
3387void
3388mach_exception_thread_shutdown()
3389{
3390  kern_return_t kret;
3391
3392  fprintf(dbgout, "terminating Mach exception thread, 'cause exit can't\n");
3393  kret = thread_terminate(mach_exception_thread);
3394  if (kret != KERN_SUCCESS) {
3395    fprintf(dbgout, "Couldn't terminate exception thread, kret = %d\n",kret);
3396  }
3397}
3398
3399
3400mach_port_t
3401mach_exception_port_set()
3402{
3403  static mach_port_t __exception_port_set = MACH_PORT_NULL;
3404  kern_return_t kret; 
3405  if (__exception_port_set == MACH_PORT_NULL) {
3406
3407    kret = mach_port_allocate(mach_task_self(),
3408                              MACH_PORT_RIGHT_PORT_SET,
3409                              &__exception_port_set);
3410    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
3411    create_system_thread(0,
3412                         NULL,
3413                         exception_handler_proc, 
3414                         (void *)((natural)__exception_port_set));
3415  }
3416  return __exception_port_set;
3417}
3418
3419/*
3420  Setup a new thread to handle those exceptions specified by
3421  the mask "which".  This involves creating a special Mach
3422  message port, telling the Mach kernel to send exception
3423  messages for the calling thread to that port, and setting
3424  up a handler thread which listens for and responds to
3425  those messages.
3426
3427*/
3428
3429/*
3430  Establish the lisp thread's TCR as its exception port, and determine
3431  whether any other ports have been established by foreign code for
3432  exceptions that lisp cares about.
3433
3434  If this happens at all, it should happen on return from foreign
3435  code and on entry to lisp code via a callback.
3436
3437  This is a lot of trouble (and overhead) to support Java, or other
3438  embeddable systems that clobber their caller's thread exception ports.
3439 
3440*/
3441kern_return_t
3442tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
3443{
3444  kern_return_t kret;
3445  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
3446  int i;
3447  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
3448  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
3449  exception_mask_t mask = 0;
3450
3451  kret = thread_swap_exception_ports(thread,
3452                                     LISP_EXCEPTIONS_HANDLED_MASK,
3453                                     lisp_port,
3454                                     EXCEPTION_DEFAULT,
3455                                     THREAD_STATE_NONE,
3456                                     fxs->masks,
3457                                     &n,
3458                                     fxs->ports,
3459                                     fxs->behaviors,
3460                                     fxs->flavors);
3461  if (kret == KERN_SUCCESS) {
3462    fxs->foreign_exception_port_count = n;
3463    for (i = 0; i < n; i ++) {
3464      foreign_port = fxs->ports[i];
3465
3466      if ((foreign_port != lisp_port) &&
3467          (foreign_port != MACH_PORT_NULL)) {
3468        mask |= fxs->masks[i];
3469      }
3470    }
3471    tcr->foreign_exception_status = (int) mask;
3472  }
3473  return kret;
3474}
3475
3476kern_return_t
3477tcr_establish_lisp_exception_port(TCR *tcr)
3478{
3479  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
3480}
3481
3482/*
3483  Do this when calling out to or returning from foreign code, if
3484  any conflicting foreign exception ports were established when we
3485  last entered lisp code.
3486*/
3487kern_return_t
3488restore_foreign_exception_ports(TCR *tcr)
3489{
3490  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
3491 
3492  if (m) {
3493    MACH_foreign_exception_state *fxs  = 
3494      (MACH_foreign_exception_state *) tcr->native_thread_info;
3495    int i, n = fxs->foreign_exception_port_count;
3496    exception_mask_t tm;
3497
3498    for (i = 0; i < n; i++) {
3499      if ((tm = fxs->masks[i]) & m) {
3500        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
3501                                   tm,
3502                                   fxs->ports[i],
3503                                   fxs->behaviors[i],
3504                                   fxs->flavors[i]);
3505      }
3506    }
3507  }
3508}
3509                                   
3510
3511/*
3512  This assumes that a Mach port (to be used as the thread's exception port) whose
3513  "name" matches the TCR's 32-bit address has already been allocated.
3514*/
3515
3516kern_return_t
3517setup_mach_exception_handling(TCR *tcr)
3518{
3519  mach_port_t
3520    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
3521    task_self = mach_task_self();
3522  kern_return_t kret;
3523
3524  kret = mach_port_insert_right(task_self,
3525                                thread_exception_port,
3526                                thread_exception_port,
3527                                MACH_MSG_TYPE_MAKE_SEND);
3528  MACH_CHECK_ERROR("adding send right to exception_port",kret);
3529
3530  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
3531  if (kret == KERN_SUCCESS) {
3532    mach_port_t exception_port_set = mach_exception_port_set();
3533
3534    kret = mach_port_move_member(task_self,
3535                                 thread_exception_port,
3536                                 exception_port_set);
3537  }
3538  return kret;
3539}
3540
3541void
3542darwin_exception_init(TCR *tcr)
3543{
3544  void tcr_monitor_exception_handling(TCR*, Boolean);
3545  kern_return_t kret;
3546  MACH_foreign_exception_state *fxs = 
3547    calloc(1, sizeof(MACH_foreign_exception_state));
3548 
3549  tcr->native_thread_info = (void *) fxs;
3550
3551  if ((kret = setup_mach_exception_handling(tcr))
3552      != KERN_SUCCESS) {
3553    fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret);
3554    terminate_lisp();
3555  }
3556  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
3557  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
3558}
3559
3560/*
3561  The tcr is the "name" of the corresponding thread's exception port.
3562  Destroying the port should remove it from all port sets of which it's
3563  a member (notably, the exception port set.)
3564*/
3565void
3566darwin_exception_cleanup(TCR *tcr)
3567{
3568  void *fxs = tcr->native_thread_info;
3569  extern Boolean use_mach_exception_handling;
3570
3571  if (fxs) {
3572    tcr->native_thread_info = NULL;
3573    free(fxs);
3574  }
3575  if (use_mach_exception_handling) {
3576    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3577    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3578  }
3579}
3580
3581
3582Boolean
3583suspend_mach_thread(mach_port_t mach_thread)
3584{
3585  kern_return_t status;
3586  Boolean aborted = false;
3587 
3588  do {
3589    aborted = false;
3590    status = thread_suspend(mach_thread);
3591    if (status == KERN_SUCCESS) {
3592      status = thread_abort_safely(mach_thread);
3593      if (status == KERN_SUCCESS) {
3594        aborted = true;
3595      } else {
3596        fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread);
3597        thread_resume(mach_thread);
3598      }
3599    } else {
3600      return false;
3601    }
3602  } while (! aborted);
3603  return true;
3604}
3605
3606/*
3607  Only do this if pthread_kill indicated that the pthread isn't
3608  listening to signals anymore, as can happen as soon as pthread_exit()
3609  is called on Darwin.  The thread could still call out to lisp as it
3610  is exiting, so we need another way to suspend it in this case.
3611*/
3612Boolean
3613mach_suspend_tcr(TCR *tcr)
3614{
3615  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
3616  ExceptionInformation *pseudosigcontext;
3617  Boolean result = false;
3618 
3619  result = suspend_mach_thread(mach_thread);
3620  if (result) {
3621    mach_msg_type_number_t thread_state_count;
3622#ifdef X8664
3623    x86_thread_state64_t ts;
3624    thread_state_count = x86_THREAD_STATE64_COUNT;
3625    thread_get_state(mach_thread,
3626                     x86_THREAD_STATE64,
3627                     (thread_state_t)&ts,
3628                     &thread_state_count);
3629#else
3630    x86_thread_state32_t ts;
3631    thread_state_count = x86_THREAD_STATE_COUNT;
3632    thread_get_state(mach_thread,
3633                     x86_THREAD_STATE,
3634                     (thread_state_t)&ts,
3635                     &thread_state_count);
3636#endif
3637
3638    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
3639    pseudosigcontext->uc_onstack = 0;
3640    pseudosigcontext->uc_sigmask = (sigset_t) 0;
3641    tcr->suspend_context = pseudosigcontext;
3642  }
3643  return result;
3644}
3645
3646void
3647mach_resume_tcr(TCR *tcr)
3648{
3649  ExceptionInformation *xp;
3650  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
3651 
3652  xp = tcr->suspend_context;
3653#ifdef DEBUG_MACH_EXCEPTIONS
3654  fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
3655          tcr, tcr->pending_exception_context);
3656#endif
3657  tcr->suspend_context = NULL;
3658  restore_mach_thread_state(mach_thread, xp);
3659#ifdef DEBUG_MACH_EXCEPTIONS
3660  fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
3661          tcr, tcr->pending_exception_context);
3662#endif
3663  thread_resume(mach_thread);
3664}
3665
3666void
3667fatal_mach_error(char *format, ...)
3668{
3669  va_list args;
3670  char s[512];
3671 
3672
3673  va_start(args, format);
3674  vsnprintf(s, sizeof(s),format, args);
3675  va_end(args);
3676
3677  Fatal("Mach error", s);
3678}
3679
3680
3681
3682
3683#endif
Note: See TracBrowser for help on using the repository browser.