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

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

Try to ensure that windows exception handler (mostly) runs on C stack,
always exits via restore_win64_context().

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