source: branches/win64/lisp-kernel/x86-exceptions.c @ 9308

Last change on this file since 9308 was 9308, checked in by gb, 13 years ago

Try to get more things working.

Recognize stylized instruction sequences used for consing on Windows
(with TCR in a GPR.)

Make windows exception handler interact with suspend_tcr() mechanisms.

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