source: branches/working-0711/ccl/lisp-kernel/x86-exceptions.c @ 12988

Last change on this file since 12988 was 12988, checked in by gz, 10 years ago

Cosmetic changes (r12644)

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