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

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

Start handling exceptions on Win64. (Not thread-safe yet.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 81.7 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, i;
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#ifdef WINDOWS
1148LispObj *
1149copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1150{
1151}
1152#else
1153LispObj *
1154copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1155{
1156  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1157  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1158
1159  *dest = *context;
1160  /* Fix it up a little; where's the signal mask allocated, if indeed
1161     it is "allocated" ? */
1162#ifdef LINUX
1163  dest->uc_mcontext.fpregs = fp;
1164#endif
1165  dest->uc_stack.ss_sp = 0;
1166  dest->uc_stack.ss_size = 0;
1167  dest->uc_stack.ss_flags = 0;
1168  dest->uc_link = NULL;
1169  return (LispObj *)dest;
1170}
1171#endif
1172
1173LispObj *
1174find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1175{
1176
1177  if (((BytePtr)rsp < foreign_area->low) ||
1178      ((BytePtr)rsp > foreign_area->high)) {
1179    rsp = (LispObj)(tcr->foreign_sp);
1180  }
1181  return (LispObj *) ((rsp-128 & ~15));
1182}
1183
1184
1185#ifdef DARWIN
1186void
1187bogus_signal_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1188{
1189  if (signum == SIGSYS) {
1190    return;                     /* Leopard lossage */
1191  }
1192}
1193#endif
1194
1195void
1196handle_signal_on_foreign_stack(TCR *tcr,
1197                               void *handler, 
1198                               int signum, 
1199                               siginfo_t *info, 
1200                               ExceptionInformation *context,
1201                               LispObj return_address
1202#ifdef DARWIN_GS_HACK
1203                               , Boolean gs_was_tcr
1204#endif
1205                               )
1206{
1207#ifdef LINUX
1208  fpregset_t fpregs = NULL;
1209#else
1210  void *fpregs = NULL;
1211#endif
1212#ifdef DARWIN
1213  MCONTEXT_T mcontextp = NULL;
1214#endif
1215  siginfo_t *info_copy = NULL;
1216  ExceptionInformation *xp = NULL;
1217  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1218
1219#ifdef LINUX
1220  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1221#endif
1222#ifdef DARWIN
1223  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1224#endif
1225  foreign_rsp = copy_siginfo(info, foreign_rsp);
1226  info_copy = (siginfo_t *)foreign_rsp;
1227  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1228  xp = (ExceptionInformation *)foreign_rsp;
1229#ifdef DARWIN
1230  UC_MCONTEXT(xp) = mcontextp;
1231#endif
1232  *--foreign_rsp = return_address;
1233#ifdef DARWIN_GS_HACK
1234  if (gs_was_tcr) {
1235    set_gs_address(tcr);
1236  }
1237#endif
1238  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1239}
1240
1241
1242#ifndef USE_SIGALTSTACK
1243void
1244arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1245{
1246  TCR *tcr = get_interrupt_tcr(false);
1247#if 1
1248  if (tcr->valence != TCR_STATE_LISP) {
1249    FBug(context, "exception in foreign context");
1250  }
1251#endif
1252  {
1253    area *vs = tcr->vs_area;
1254    BytePtr current_sp = (BytePtr) current_stack_pointer();
1255
1256
1257    if ((current_sp >= vs->low) &&
1258        (current_sp < vs->high)) {
1259      handle_signal_on_foreign_stack(tcr,
1260                                     signal_handler,
1261                                     signum,
1262                                     info,
1263                                     context,
1264                                     (LispObj)__builtin_return_address(0)
1265#ifdef DARWIN_GS_HACK
1266                                     , false
1267#endif
1268
1269                                     );
1270    } else {
1271      signal_handler(signum, info, context, tcr, 0);
1272    }
1273  }
1274}
1275
1276#else
1277void
1278altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1279{
1280  TCR* tcr = get_tcr(true);
1281#if 1
1282  if (tcr->valence != TCR_STATE_LISP) {
1283    FBug(context, "exception in foreign context");
1284  }
1285#endif
1286  handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1287#ifdef DARWIN_GS_HACK
1288                                 , false
1289#endif
1290);
1291}
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 USE_SIGALTSTACK
1382void
1383arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1384{
1385#ifdef DARWIN_GS_HACK
1386  Boolean gs_was_tcr = ensure_gs_pthread();
1387#endif
1388  TCR *tcr = get_interrupt_tcr(false);
1389  area *vs = tcr->vs_area;
1390  BytePtr current_sp = (BytePtr) current_stack_pointer();
1391
1392  if ((current_sp >= vs->low) &&
1393      (current_sp < vs->high)) {
1394    handle_signal_on_foreign_stack(tcr,
1395                                   interrupt_handler,
1396                                   signum,
1397                                   info,
1398                                   context,
1399                                   (LispObj)__builtin_return_address(0)
1400#ifdef DARWIN_GS_HACK
1401                                   ,gs_was_tcr
1402#endif
1403                                   );
1404  } else {
1405    /* If we're not on the value stack, we pretty much have to be on
1406       the C stack.  Just run the handler. */
1407#ifdef DARWIN_GS_HACK
1408    if (gs_was_tcr) {
1409      set_gs_address(tcr);
1410    }
1411#endif
1412    interrupt_handler(signum, info, context);
1413  }
1414}
1415
1416#else /* altstack works */
1417 
1418void
1419altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1420{
1421#ifdef DARWIN_GS_HACK
1422  Boolean gs_was_tcr = ensure_gs_pthread();
1423#endif
1424  TCR *tcr = get_interrupt_tcr(false);
1425  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1426#ifdef DARWIN_GS_HACK
1427                                 ,gs_was_tcr
1428#endif
1429                                 );
1430}
1431
1432#endif
1433
1434#ifndef WINDOWS
1435void
1436install_signal_handler(int signo, void * handler)
1437{
1438  struct sigaction sa;
1439 
1440  sa.sa_sigaction = (void *)handler;
1441  sigfillset(&sa.sa_mask);
1442#ifdef FREEBSD
1443  /* Strange FreeBSD behavior wrt synchronous signals */
1444  sigdelset(&sa.sa_mask,SIGNUM_FOR_INTN_TRAP);
1445  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1446  sigdelset(&sa.sa_mask,SIGILL);
1447  sigdelset(&sa.sa_mask,SIGFPE);
1448  sigdelset(&sa.sa_mask,SIGSEGV);
1449#endif
1450  sa.sa_flags = 
1451    0 /* SA_RESTART */
1452#ifdef USE_SIGALTSTACK
1453    | SA_ONSTACK
1454#endif
1455    | SA_SIGINFO;
1456
1457  sigaction(signo, &sa, NULL);
1458}
1459#endif
1460
1461#ifdef WINDOWS
1462BOOL
1463ControlEventHandler(DWORD event)
1464{
1465  switch(event) {
1466  case CTRL_C_EVENT:
1467    lisp_global(INTFLAG) = (1 << fixnumshift);
1468    return TRUE;
1469    break;
1470  default:
1471    return FALSE;
1472  }
1473}
1474
1475int
1476map_windows_exception_code_to_posix_signal(DWORD code)
1477{
1478  switch (code) {
1479  case EXCEPTION_ACCESS_VIOLATION:
1480    return SIGSEGV;
1481  case EXCEPTION_FLT_DENORMAL_OPERAND:
1482  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
1483  case EXCEPTION_FLT_INEXACT_RESULT:
1484  case EXCEPTION_FLT_INVALID_OPERATION:
1485  case EXCEPTION_FLT_OVERFLOW:
1486  case EXCEPTION_FLT_STACK_CHECK:
1487  case EXCEPTION_FLT_UNDERFLOW:
1488  case EXCEPTION_INT_DIVIDE_BY_ZERO:
1489  case EXCEPTION_INT_OVERFLOW:
1490    return SIGFPE;
1491  case EXCEPTION_PRIV_INSTRUCTION:
1492  case EXCEPTION_ILLEGAL_INSTRUCTION:
1493    return SIGILL;
1494  case EXCEPTION_IN_PAGE_ERROR:
1495    return SIGBUS;
1496  default:
1497    return -1;
1498  }
1499}
1500
1501LONG
1502windows_exception_handler(EXCEPTION_POINTERS *exception_pointers)
1503{
1504  TCR *tcr = get_tcr(false);
1505  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1506  int old_valence = tcr->valence, 
1507    signal_number = map_windows_exception_code_to_posix_signal(code);
1508  ExceptionInformation *context = exception_pointers->ContextRecord;
1509    siginfo_t *info = exception_pointers->ExceptionRecord;
1510    xframe_list xframes;
1511
1512  wait_for_exception_lock_in_handler(tcr, context, &xframes);
1513 
1514  if (handle_exception(signal_number, info, context, tcr, old_valence)) {
1515    unlock_exception_lock_in_handler(tcr);
1516    return EXCEPTION_CONTINUE_EXECUTION;
1517  } else {
1518    char msg[512];
1519    Boolean foreign = (old_valence != TCR_STATE_LISP);
1520
1521    snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x%llx, context->regs at 0x%llx", signal_number, xpPC(context), (natural)xpGPRvector(context));
1522   
1523    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
1524      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1525    }
1526    return EXCEPTION_CONTINUE_EXECUTION;
1527  }
1528  return EXCEPTION_CONTINUE_SEARCH;
1529}
1530
1531void
1532install_pmcl_exception_handlers()
1533{
1534  AddVectoredExceptionHandler(1,windows_exception_handler);
1535}
1536#else
1537void
1538install_pmcl_exception_handlers()
1539{
1540#ifndef DARWIN 
1541  void *handler = (void *)
1542#ifdef USE_SIGALTSTACK
1543    altstack_signal_handler
1544#else
1545    arbstack_signal_handler;
1546#endif
1547  ;
1548  install_signal_handler(SIGILL, handler);
1549 
1550  install_signal_handler(SIGBUS, handler);
1551  install_signal_handler(SIGSEGV,handler);
1552  install_signal_handler(SIGFPE, handler);
1553#else
1554  install_signal_handler(SIGTRAP,bogus_signal_handler);
1555  install_signal_handler(SIGILL, bogus_signal_handler);
1556 
1557  install_signal_handler(SIGBUS, bogus_signal_handler);
1558  install_signal_handler(SIGSEGV,bogus_signal_handler);
1559  install_signal_handler(SIGFPE, bogus_signal_handler);
1560  /*  9.0.0d8 generates spurious SIGSYS from mach_msg_trap */
1561  install_signal_handler(SIGSYS, bogus_signal_handler);
1562#endif
1563 
1564  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT,
1565#ifdef USE_SIGALTSTACK
1566                         altstack_interrupt_handler
1567#else
1568                         arbstack_interrupt_handler
1569#endif
1570);
1571  signal(SIGPIPE, SIG_IGN);
1572}
1573#endif
1574
1575#ifndef USE_SIGALTSTACK
1576void
1577arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1578{
1579#ifdef DARWIN_GS_HACK
1580  Boolean gs_was_tcr = ensure_gs_pthread();
1581#endif
1582  TCR *tcr = get_interrupt_tcr(false);
1583  area *vs = tcr->vs_area;
1584  BytePtr current_sp = (BytePtr) current_stack_pointer();
1585
1586  if ((current_sp >= vs->low) &&
1587      (current_sp < vs->high)) {
1588    handle_signal_on_foreign_stack(tcr,
1589                                   suspend_resume_handler,
1590                                   signum,
1591                                   info,
1592                                   context,
1593                                   (LispObj)__builtin_return_address(0)
1594#ifdef DARWIN_GS_HACK
1595                                   ,gs_was_tcr
1596#endif
1597                                   );
1598  } else {
1599    /* If we're not on the value stack, we pretty much have to be on
1600       the C stack.  Just run the handler. */
1601#ifdef DARWIN_GS_HACK
1602    if (gs_was_tcr) {
1603      set_gs_address(tcr);
1604    }
1605#endif
1606    suspend_resume_handler(signum, info, context);
1607  }
1608}
1609
1610
1611#else /* altstack works */
1612void
1613altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1614{
1615#ifdef DARWIN_GS_HACK
1616  Boolean gs_was_tcr = ensure_gs_pthread();
1617#endif
1618  TCR* tcr = get_tcr(true);
1619  handle_signal_on_foreign_stack(tcr,
1620                                 suspend_resume_handler,
1621                                 signum,
1622                                 info,
1623                                 context,
1624                                 (LispObj)__builtin_return_address(0)
1625#ifdef DARWIN_GS_HACK
1626                                 ,gs_was_tcr
1627#endif
1628                                 );
1629}
1630
1631#endif
1632
1633#ifdef WINDOWS
1634void
1635quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1636{
1637}
1638#else
1639void
1640quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1641{
1642#ifdef DARWIN_GS_HACK
1643  Boolean gs_was_tcr = ensure_gs_pthread();
1644#endif
1645  TCR *tcr = get_tcr(false);
1646  area *a;
1647  sigset_t mask;
1648 
1649  sigemptyset(&mask);
1650
1651
1652  if (tcr) {
1653    tcr->valence = TCR_STATE_FOREIGN;
1654    a = tcr->vs_area;
1655    if (a) {
1656      a->active = a->high;
1657    }
1658    a = tcr->ts_area;
1659    if (a) {
1660      a->active = a->high;
1661    }
1662    a = tcr->cs_area;
1663    if (a) {
1664      a->active = a->high;
1665    }
1666  }
1667 
1668  pthread_sigmask(SIG_SETMASK,&mask,NULL);
1669  pthread_exit(NULL);
1670}
1671#endif
1672
1673#ifndef USE_SIGALTSTACK
1674arbstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1675{
1676#ifdef DARWIN_GS_HACK
1677  Boolean gs_was_tcr = ensure_gs_pthread();
1678#endif
1679  TCR *tcr = get_interrupt_tcr(false);
1680  area *vs = tcr->vs_area;
1681  BytePtr current_sp = (BytePtr) current_stack_pointer();
1682
1683  if ((current_sp >= vs->low) &&
1684      (current_sp < vs->high)) {
1685    handle_signal_on_foreign_stack(tcr,
1686                                   quit_handler,
1687                                   signum,
1688                                   info,
1689                                   context,
1690                                   (LispObj)__builtin_return_address(0)
1691#ifdef DARWIN_GS_HACK
1692                                   ,gs_was_tcr
1693#endif
1694                                   );
1695  } else {
1696    /* If we're not on the value stack, we pretty much have to be on
1697       the C stack.  Just run the handler. */
1698#ifdef DARWIN_GS_HACK
1699    if (gs_was_tcr) {
1700      set_gs_address(tcr);
1701    }
1702#endif
1703    quit_handler(signum, info, context);
1704  }
1705}
1706
1707
1708#else
1709void
1710altstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1711{
1712#ifdef DARWIN_GS_HACK
1713  Boolean gs_was_tcr = ensure_gs_pthread();
1714#endif
1715  TCR* tcr = get_tcr(true);
1716  handle_signal_on_foreign_stack(tcr,
1717                                 quit_handler,
1718                                 signum,
1719                                 info,
1720                                 context,
1721                                 (LispObj)__builtin_return_address(0)
1722#ifdef DARWIN_GS_HACK
1723                                 ,gs_was_tcr
1724#endif
1725                                 );
1726}
1727#endif
1728
1729#ifdef USE_SIGALTSTACK
1730#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
1731#define QUIT_HANDLER altstack_quit_handler
1732#else
1733#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
1734#define QUIT_HANDLER arbstack_quit_handler
1735#endif
1736
1737#ifdef WINDOWS
1738void
1739thread_signal_setup()
1740{
1741}
1742#else
1743void
1744thread_signal_setup()
1745{
1746  thread_suspend_signal = SIG_SUSPEND_THREAD;
1747
1748  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
1749  install_signal_handler(SIGQUIT, (void *)QUIT_HANDLER);
1750}
1751#endif
1752
1753void
1754enable_fp_exceptions()
1755{
1756}
1757
1758void
1759exception_init()
1760{
1761  install_pmcl_exception_handlers();
1762}
1763
1764void
1765adjust_exception_pc(ExceptionInformation *xp, int delta)
1766{
1767  xpPC(xp) += delta;
1768}
1769
1770/*
1771  Lower (move toward 0) the "end" of the soft protected area associated
1772  with a by a page, if we can.
1773*/
1774
1775void
1776
1777adjust_soft_protection_limit(area *a)
1778{
1779  char *proposed_new_soft_limit = a->softlimit - 4096;
1780  protected_area_ptr p = a->softprot;
1781 
1782  if (proposed_new_soft_limit >= (p->start+16384)) {
1783    p->end = proposed_new_soft_limit;
1784    p->protsize = p->end-p->start;
1785    a->softlimit = proposed_new_soft_limit;
1786  }
1787  protect_area(p);
1788}
1789
1790void
1791restore_soft_stack_limit(unsigned restore_tsp)
1792{
1793  TCR *tcr = get_tcr(false);
1794  area *a;
1795 
1796  if (restore_tsp) {
1797    a = tcr->ts_area;
1798  } else {
1799    a = tcr->vs_area;
1800  }
1801  adjust_soft_protection_limit(a);
1802}
1803
1804
1805#ifdef USE_SIGALTSTACK
1806void
1807setup_sigaltstack(area *a)
1808{
1809  stack_t stack;
1810  stack.ss_sp = a->low;
1811  a->low += SIGSTKSZ*8;
1812  stack.ss_size = SIGSTKSZ*8;
1813  stack.ss_flags = 0;
1814  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
1815  if (sigaltstack(&stack, NULL) != 0) {
1816    perror("sigaltstack");
1817    exit(-1);
1818  }
1819}
1820#endif
1821
1822extern opcode egc_write_barrier_start, egc_write_barrier_end,
1823  egc_store_node_conditional_success_test,egc_store_node_conditional,
1824  egc_set_hash_key, egc_gvset, egc_rplacd;
1825
1826/* We use (extremely) rigidly defined instruction sequences for consing,
1827   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
1828   while consing.
1829
1830   Note that we can usually identify which of these instructions is about
1831   to be executed by a stopped thread without comparing all of the bytes
1832   to those at the stopped program counter, but we generally need to
1833   know the sizes of each of these instructions.
1834*/
1835
1836opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
1837  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00};
1838opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
1839  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00};
1840opcode branch_around_alloc_trap_instruction[] =
1841  {0x7f,0x02};
1842opcode alloc_trap_instruction[] =
1843  {0xcd,0xc5};
1844opcode clear_tcr_save_allocptr_tag_instruction[] =
1845  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0};
1846opcode set_allocptr_header_instruction[] =
1847  {0x48,0x89,0x43,0xf3};
1848
1849
1850alloc_instruction_id
1851recognize_alloc_instruction(pc program_counter)
1852{
1853  switch(program_counter[0]) {
1854  case 0xcd: return ID_alloc_trap_instruction;
1855  case 0x7f: return ID_branch_around_alloc_trap_instruction;
1856  case 0x48: return ID_set_allocptr_header_instruction;
1857  case 0x65: 
1858    switch(program_counter[1]) {
1859    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
1860    case 0x48:
1861      switch(program_counter[2]) {
1862      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
1863      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
1864      }
1865    }
1866  }
1867  return ID_unrecognized_alloc_instruction;
1868}
1869     
1870#ifdef WINDOWS 
1871void
1872pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
1873{
1874}
1875#else
1876void
1877pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
1878{
1879  pc program_counter = (pc)xpPC(xp);
1880  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
1881
1882  if (allocptr_tag != 0) {
1883    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
1884    signed_natural
1885      disp = (allocptr_tag == fulltag_cons) ?
1886      sizeof(cons) - fulltag_cons :
1887      xpGPR(xp,Iimm1);
1888    LispObj new_vector;
1889
1890    if ((state == ID_unrecognized_alloc_instruction) ||
1891        ((state == ID_set_allocptr_header_instruction) &&
1892         (allocptr_tag != fulltag_misc))) {
1893      Bug(xp, "Can't determine state of thread 0x%lx, interrupted during memory allocation", tcr);
1894    }
1895    switch(state) {
1896    case ID_set_allocptr_header_instruction:
1897      /* We were consing a vector and we won.  Set the header of the new vector
1898         (in the allocptr register) to the header in %rax and skip over this
1899         instruction, then fall into the next case. */
1900      new_vector = xpGPR(xp,Iallocptr);
1901      deref(new_vector,0) = xpGPR(xp,Iimm0);
1902
1903      xpPC(xp) += sizeof(set_allocptr_header_instruction);
1904      /* Fall thru */
1905    case ID_clear_tcr_save_allocptr_tag_instruction:
1906      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1907      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1908      break;
1909    case ID_alloc_trap_instruction:
1910      /* If we're looking at another thread, we're pretty much committed to
1911         taking the trap.  We don't want the allocptr register to be pointing
1912         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
1913         was determined above.
1914      */
1915      if (interrupt_displacement == NULL) {
1916        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
1917        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
1918      } else {
1919        /* Back out, and tell the caller how to resume the allocation attempt */
1920        *interrupt_displacement = disp;
1921        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1922        tcr->save_allocptr += disp;
1923        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
1924                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1925                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1926      }
1927      break;
1928    case ID_branch_around_alloc_trap_instruction:
1929      /* If we'd take the branch - which is a 'jg" - around the alloc trap,
1930         we might as well finish the allocation.  Otherwise, back out of the
1931         attempt. */
1932      {
1933        int flags = (int)xpGPR(xp,Iflags);
1934       
1935        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
1936            ((flags & (1 << X86_SIGN_FLAG_BIT)) ==
1937             (flags & (1 << X86_CARRY_FLAG_BIT)))) {
1938          /* The branch (jg) would have been taken.  Emulate taking it. */
1939          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
1940                       sizeof(alloc_trap_instruction));
1941          if (allocptr_tag == fulltag_misc) {
1942            /* Slap the header on the new uvector */
1943            new_vector = xpGPR(xp,Iallocptr);
1944            deref(new_vector,0) = xpGPR(xp,Iimm0);
1945            xpPC(xp) += sizeof(set_allocptr_header_instruction);
1946          }
1947          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
1948          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
1949        } else {
1950          /* Back up */
1951          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
1952                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
1953          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1954          if (interrupt_displacement) {
1955            *interrupt_displacement = disp;
1956            tcr->save_allocptr += disp;
1957          } else {
1958            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1959          }
1960        }
1961      }
1962      break;
1963    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
1964      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
1965      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
1966      /* Fall through */
1967    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
1968      if (interrupt_displacement) {
1969        tcr->save_allocptr += disp;
1970        *interrupt_displacement = disp;
1971      } else {
1972        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
1973      }
1974      break;
1975    }
1976    return;
1977  }
1978  if ((program_counter >= &egc_write_barrier_start) &&
1979      (program_counter < &egc_write_barrier_end)) {
1980    LispObj *ea = 0, val, root;
1981    bitvector refbits = (bitvector)(lisp_global(REFBITS));
1982    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
1983
1984    if (program_counter >= &egc_store_node_conditional) {
1985      if ((program_counter < &egc_store_node_conditional_success_test) ||
1986          ((program_counter == &egc_store_node_conditional_success_test) &&
1987           !(xpGPR(xp, Iflags) & (1 << X86_ZERO_FLAG_BIT)))) {
1988        /* Back up the PC, try again */
1989        xpPC(xp) = (LispObj) &egc_store_node_conditional;
1990        return;
1991      }
1992      /* The conditional store succeeded.  Set the refbit, return to ra0 */
1993      val = xpGPR(xp,Iarg_z);
1994      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
1995                                                       xpGPR(xp,Itemp0))));
1996      xpGPR(xp,Iarg_z) = t_value;
1997      need_store = false;
1998    } else if (program_counter >= &egc_set_hash_key) {
1999      root = xpGPR(xp,Iarg_x);
2000      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2001      val = xpGPR(xp,Iarg_z);
2002      need_memoize_root = true;
2003    } else if (program_counter >= &egc_gvset) {
2004      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2005      val = xpGPR(xp,Iarg_z);
2006    } else if (program_counter >= &egc_rplacd) {
2007      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2008      val = xpGPR(xp,Iarg_z);
2009    } else {                      /* egc_rplaca */
2010      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2011      val = xpGPR(xp,Iarg_z);
2012    }
2013    if (need_store) {
2014      *ea = val;
2015    }
2016    if (need_check_memo) {
2017      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
2018      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
2019          ((LispObj)ea < val)) {
2020        atomic_set_bit(refbits, bitnumber);
2021        if (need_memoize_root) {
2022          bitnumber = area_dnode(root, lisp_global(HEAP_START));
2023          atomic_set_bit(refbits, bitnumber);
2024        }
2025      }
2026    }
2027    {
2028      /* These subprimitives are called via CALL/RET; need
2029         to pop the return address off the stack and set
2030         the PC there. */
2031      LispObj *rsp = (LispObj *)xpGPR(xp,Isp), ra = *rsp++;
2032      xpPC(xp) = ra;
2033      xpGPR(xp,Isp)=(LispObj)rsp;
2034    }
2035    return;
2036  }
2037}
2038#endif
2039
2040void
2041normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2042{
2043  void *cur_allocptr = (void *)(tcr->save_allocptr);
2044  LispObj lisprsp, lisptsp;
2045  area *a;
2046
2047  if (xp) {
2048    if (is_other_tcr) {
2049      pc_luser_xp(xp, tcr, NULL);
2050    }
2051    a = tcr->vs_area;
2052    lisprsp = xpGPR(xp, Isp);
2053    if (((BytePtr)lisprsp >= a->low) &&
2054        ((BytePtr)lisprsp < a->high)) {
2055      a->active = (BytePtr)lisprsp;
2056    } else {
2057      a->active = (BytePtr) tcr->save_vsp;
2058    }
2059    a = tcr->ts_area;
2060    a->active = (BytePtr) tcr->save_tsp;
2061  } else {
2062    /* In ff-call; get area active pointers from tcr */
2063    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2064    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2065  }
2066  if (cur_allocptr) {
2067    update_bytes_allocated(tcr, cur_allocptr);
2068  }
2069  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2070  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2071    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2072  }
2073}
2074
2075
2076/* Suspend and "normalize" other tcrs, then call a gc-like function
2077   in that context.  Resume the other tcrs, then return what the
2078   function returned */
2079
2080TCR *gc_tcr = NULL;
2081
2082
2083int
2084gc_like_from_xp(ExceptionInformation *xp, 
2085                int(*fun)(TCR *, signed_natural), 
2086                signed_natural param)
2087{
2088  TCR *tcr = get_tcr(false), *other_tcr;
2089  ExceptionInformation* other_xp;
2090  int result;
2091  signed_natural inhibit;
2092
2093  suspend_other_threads(true);
2094  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2095  if (inhibit != 0) {
2096    if (inhibit > 0) {
2097      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2098    }
2099    resume_other_threads(true);
2100    gc_deferred++;
2101    return 0;
2102  }
2103  gc_deferred = 0;
2104
2105  gc_tcr = tcr;
2106
2107  /* This is generally necessary if the current thread invoked the GC
2108     via an alloc trap, and harmless if the GC was invoked via a GC
2109     trap.  (It's necessary in the first case because the "allocptr"
2110     register - %rbx - may be pointing into the middle of something
2111     below tcr->save_allocbase, and we wouldn't want the GC to see
2112     that bogus pointer.) */
2113  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2114
2115  normalize_tcr(xp, tcr, false);
2116
2117
2118  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
2119    if (other_tcr->pending_exception_context) {
2120      other_tcr->gc_context = other_tcr->pending_exception_context;
2121    } else if (other_tcr->valence == TCR_STATE_LISP) {
2122      other_tcr->gc_context = other_tcr->suspend_context;
2123    } else {
2124      /* no pending exception, didn't suspend in lisp state:
2125         must have executed a synchronous ff-call.
2126      */
2127      other_tcr->gc_context = NULL;
2128    }
2129    normalize_tcr(other_tcr->gc_context, other_tcr, true);
2130  }
2131   
2132
2133
2134  result = fun(tcr, param);
2135
2136  other_tcr = tcr;
2137  do {
2138    other_tcr->gc_context = NULL;
2139    other_tcr = other_tcr->next;
2140  } while (other_tcr != tcr);
2141
2142  gc_tcr = NULL;
2143
2144  resume_other_threads(true);
2145
2146  return result;
2147
2148}
2149
2150int
2151purify_from_xp(ExceptionInformation *xp, signed_natural param)
2152{
2153  return gc_like_from_xp(xp, purify, param);
2154}
2155
2156int
2157impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2158{
2159  return gc_like_from_xp(xp, impurify, param);
2160}
2161
2162/* Returns #bytes freed by invoking GC */
2163
2164int
2165gc_from_tcr(TCR *tcr, signed_natural param)
2166{
2167  area *a;
2168  BytePtr oldfree, newfree;
2169  BytePtr oldend, newend;
2170
2171#if 0
2172  fprintf(stderr, "Start GC  in 0x%lx\n", tcr);
2173#endif
2174  a = active_dynamic_area;
2175  oldend = a->high;
2176  oldfree = a->active;
2177  gc(tcr, param);
2178  newfree = a->active;
2179  newend = a->high;
2180#if 0
2181  fprintf(stderr, "End GC  in 0x%lx\n", tcr);
2182#endif
2183  return ((oldfree-newfree)+(newend-oldend));
2184}
2185
2186int
2187gc_from_xp(ExceptionInformation *xp, signed_natural param)
2188{
2189  int status = gc_like_from_xp(xp, gc_from_tcr, param);
2190
2191  freeGCptrs();
2192  return status;
2193}
2194
2195#ifdef DARWIN
2196
2197#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2198#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2199
2200#if USE_MACH_EXCEPTION_LOCK
2201pthread_mutex_t _mach_exception_lock, *mach_exception_lock;
2202#endif
2203extern void pseudo_sigreturn(void);
2204
2205
2206
2207#define LISP_EXCEPTIONS_HANDLED_MASK \
2208 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2209
2210/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2211#define NUM_LISP_EXCEPTIONS_HANDLED 4
2212
2213typedef struct {
2214  int foreign_exception_port_count;
2215  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2216  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2217  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2218  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2219} MACH_foreign_exception_state;
2220
2221
2222
2223
2224/*
2225  Mach's exception mechanism works a little better than its signal
2226  mechanism (and, not incidentally, it gets along with GDB a lot
2227  better.
2228
2229  Initially, we install an exception handler to handle each native
2230  thread's exceptions.  This process involves creating a distinguished
2231  thread which listens for kernel exception messages on a set of
2232  0 or more thread exception ports.  As threads are created, they're
2233  added to that port set; a thread's exception port is destroyed
2234  (and therefore removed from the port set) when the thread exits.
2235
2236  A few exceptions can be handled directly in the handler thread;
2237  others require that we resume the user thread (and that the
2238  exception thread resumes listening for exceptions.)  The user
2239  thread might eventually want to return to the original context
2240  (possibly modified somewhat.)
2241
2242  As it turns out, the simplest way to force the faulting user
2243  thread to handle its own exceptions is to do pretty much what
2244  signal() does: the exception handlng thread sets up a sigcontext
2245  on the user thread's stack and forces the user thread to resume
2246  execution as if a signal handler had been called with that
2247  context as an argument.  We can use a distinguished UUO at a
2248  distinguished address to do something like sigreturn(); that'll
2249  have the effect of resuming the user thread's execution in
2250  the (pseudo-) signal context.
2251
2252  Since:
2253    a) we have miles of code in C and in Lisp that knows how to
2254    deal with Linux sigcontexts
2255    b) Linux sigcontexts contain a little more useful information
2256    (the DAR, DSISR, etc.) than their Darwin counterparts
2257    c) we have to create a sigcontext ourselves when calling out
2258    to the user thread: we aren't really generating a signal, just
2259    leveraging existing signal-handling code.
2260
2261  we create a Linux sigcontext struct.
2262
2263  Simple ?  Hopefully from the outside it is ...
2264
2265  We want the process of passing a thread's own context to it to
2266  appear to be atomic: in particular, we don't want the GC to suspend
2267  a thread that's had an exception but has not yet had its user-level
2268  exception handler called, and we don't want the thread's exception
2269  context to be modified by a GC while the Mach handler thread is
2270  copying it around.  On Linux (and on Jaguar), we avoid this issue
2271  because (a) the kernel sets up the user-level signal handler and
2272  (b) the signal handler blocks signals (including the signal used
2273  by the GC to suspend threads) until tcr->xframe is set up.
2274
2275  The GC and the Mach server thread therefore contend for the lock
2276  "mach_exception_lock".  The Mach server thread holds the lock
2277  when copying exception information between the kernel and the
2278  user thread; the GC holds this lock during most of its execution
2279  (delaying exception processing until it can be done without
2280  GC interference.)
2281
2282*/
2283
2284#ifdef PPC64
2285#define C_REDZONE_LEN           320
2286#define C_STK_ALIGN             32
2287#else
2288#define C_REDZONE_LEN           224
2289#define C_STK_ALIGN             16
2290#endif
2291#define C_PARAMSAVE_LEN         64
2292#define C_LINKAGE_LEN           48
2293
2294#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2295
2296void
2297fatal_mach_error(char *format, ...);
2298
2299#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2300
2301
2302void
2303restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2304{
2305  int i, j;
2306  kern_return_t kret;
2307#if WORD_SIZE == 64
2308  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2309#else
2310  struct mcontext * mc = UC_MCONTEXT(pseudosigcontext);
2311#endif
2312
2313  /* Set the thread's FP state from the pseudosigcontext */
2314  kret = thread_set_state(thread,
2315                          x86_FLOAT_STATE64,
2316                          (thread_state_t)&(mc->__fs),
2317                          x86_FLOAT_STATE64_COUNT);
2318
2319  MACH_CHECK_ERROR("setting thread FP state", kret);
2320
2321  /* The thread'll be as good as new ... */
2322#if WORD_SIZE == 64
2323  kret = thread_set_state(thread,
2324                          x86_THREAD_STATE64,
2325                          (thread_state_t)&(mc->__ss),
2326                          x86_THREAD_STATE64_COUNT);
2327#else
2328  kret = thread_set_state(thread, 
2329                          x86_THREAD_STATE32,
2330                          (thread_state_t)&(mc->__ss),
2331                          x86_THREAD_STATE32_COUNT);
2332#endif
2333  MACH_CHECK_ERROR("setting thread state", kret);
2334} 
2335
2336/* This code runs in the exception handling thread, in response
2337   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2338   in response to a call to pseudo_sigreturn() from the specified
2339   user thread.
2340   Find that context (the user thread's R3 points to it), then
2341   use that context to set the user thread's state.  When this
2342   function's caller returns, the Mach kernel will resume the
2343   user thread.
2344*/
2345
2346kern_return_t
2347do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
2348{
2349  ExceptionInformation *xp;
2350
2351#ifdef DEBUG_MACH_EXCEPTIONS
2352  fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
2353#endif
2354  xp = tcr->pending_exception_context;
2355  if (xp) {
2356    tcr->pending_exception_context = NULL;
2357    tcr->valence = TCR_STATE_LISP;
2358    restore_mach_thread_state(thread, xp);
2359    raise_pending_interrupt(tcr);
2360  } else {
2361    Bug(NULL, "no xp here!\n");
2362  }
2363#ifdef DEBUG_MACH_EXCEPTIONS
2364  fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
2365#endif
2366  return KERN_SUCCESS;
2367} 
2368
2369ExceptionInformation *
2370create_thread_context_frame(mach_port_t thread, 
2371                            natural *new_stack_top,
2372                            siginfo_t **info_ptr,
2373                            TCR *tcr,
2374#ifdef X8664
2375                            x86_thread_state64_t *ts
2376#else
2377                            x86_thread_state_t *ts
2378#endif
2379                            )
2380{
2381  mach_msg_type_number_t thread_state_count;
2382  kern_return_t result;
2383  int i,j;
2384  ExceptionInformation *pseudosigcontext;
2385#ifdef X8664
2386  MCONTEXT_T mc;
2387#else
2388  struct mcontext *mc;
2389#endif
2390  natural stackp, backlink;
2391
2392 
2393  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2394  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2395  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
2396  if (info_ptr) {
2397    *info_ptr = (siginfo_t *)stackp;
2398  }
2399  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
2400  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
2401
2402  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
2403#ifdef X8664
2404  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
2405#else
2406  mc = (struct mcontext *) ptr_from_lispobj(stackp);
2407#endif
2408 
2409  memmove(&(mc->__ss),ts,sizeof(*ts));
2410
2411  thread_state_count = x86_FLOAT_STATE64_COUNT;
2412  thread_get_state(thread,
2413                   x86_FLOAT_STATE64,
2414                   (thread_state_t)&(mc->__fs),
2415                   &thread_state_count);
2416
2417
2418#ifdef X8664
2419  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
2420#else
2421  thread_state_count = x86_EXCEPTION_STATE_COUNT;
2422#endif
2423  thread_get_state(thread,
2424#ifdef X8664
2425                   x86_EXCEPTION_STATE64,
2426#else
2427                   x86_EXCEPTION_STATE,
2428#endif
2429                   (thread_state_t)&(mc->__es),
2430                   &thread_state_count);
2431
2432
2433  UC_MCONTEXT(pseudosigcontext) = mc;
2434  if (new_stack_top) {
2435    *new_stack_top = stackp;
2436  }
2437  return pseudosigcontext;
2438}
2439
2440/*
2441  This code sets up the user thread so that it executes a "pseudo-signal
2442  handler" function when it resumes.  Create a fake ucontext struct
2443  on the thread's stack and pass it as an argument to the pseudo-signal
2444  handler.
2445
2446  Things are set up so that the handler "returns to" pseudo_sigreturn(),
2447  which will restore the thread's context.
2448
2449  If the handler invokes code that throws (or otherwise never sigreturn()'s
2450  to the context), that's fine.
2451
2452  Actually, check that: throw (and variants) may need to be careful and
2453  pop the tcr's xframe list until it's younger than any frame being
2454  entered.
2455*/
2456
2457int
2458setup_signal_frame(mach_port_t thread,
2459                   void *handler_address,
2460                   int signum,
2461                   int code,
2462                   TCR *tcr,
2463#ifdef X8664
2464                   x86_thread_state64_t *ts
2465#else
2466                   x86_thread_state_t *ts
2467#endif
2468                   )
2469{
2470#ifdef X8664
2471  x86_thread_state64_t new_ts;
2472#else
2473  x86_thread_state_t new_ts;
2474#endif
2475  ExceptionInformation *pseudosigcontext;
2476  int i, j, old_valence = tcr->valence;
2477  kern_return_t result;
2478  natural stackp, *stackpp;
2479  siginfo_t *info;
2480
2481#ifdef DEBUG_MACH_EXCEPTIONS
2482  fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
2483#endif
2484  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
2485  bzero(info, sizeof(*info));
2486  info->si_code = code;
2487  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
2488  info->si_signo = signum;
2489  pseudosigcontext->uc_onstack = 0;
2490  pseudosigcontext->uc_sigmask = (sigset_t) 0;
2491  pseudosigcontext->uc_stack.ss_sp = 0;
2492  pseudosigcontext->uc_stack.ss_size = 0;
2493  pseudosigcontext->uc_stack.ss_flags = 0;
2494  pseudosigcontext->uc_link = NULL;
2495  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
2496  tcr->pending_exception_context = pseudosigcontext;
2497  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
2498 
2499
2500  /*
2501     It seems like we've created a  sigcontext on the thread's
2502     stack.  Set things up so that we call the handler (with appropriate
2503     args) when the thread's resumed.
2504  */
2505
2506  new_ts.__rip = (natural) handler_address;
2507  stackpp = (natural *)stackp;
2508  *--stackpp = (natural)pseudo_sigreturn;
2509  stackp = (natural)stackpp;
2510  new_ts.__rdi = signum;
2511  new_ts.__rsi = (natural)info;
2512  new_ts.__rdx = (natural)pseudosigcontext;
2513  new_ts.__rcx = (natural)tcr;
2514  new_ts.__r8 = (natural)old_valence;
2515  new_ts.__rsp = stackp;
2516  new_ts.__rflags = ts->__rflags;
2517
2518
2519#ifdef X8664
2520  thread_set_state(thread,
2521                   x86_THREAD_STATE64,
2522                   (thread_state_t)&new_ts,
2523                   x86_THREAD_STATE64_COUNT);
2524#else
2525  thread_set_state(thread, 
2526                   x86_THREAD_STATE,
2527                   (thread_state_t)&new_ts,
2528                   x86_THREAD_STATE_COUNT);
2529#endif
2530#ifdef DEBUG_MACH_EXCEPTIONS
2531  fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
2532#endif
2533  return 0;
2534}
2535
2536
2537
2538
2539
2540
2541/*
2542  This function runs in the exception handling thread.  It's
2543  called (by this precise name) from the library function "exc_server()"
2544  when the thread's exception ports are set up.  (exc_server() is called
2545  via mach_msg_server(), which is a function that waits for and dispatches
2546  on exception messages from the Mach kernel.)
2547
2548  This checks to see if the exception was caused by a pseudo_sigreturn()
2549  UUO; if so, it arranges for the thread to have its state restored
2550  from the specified context.
2551
2552  Otherwise, it tries to map the exception to a signal number and
2553  arranges that the thread run a "pseudo signal handler" to handle
2554  the exception.
2555
2556  Some exceptions could and should be handled here directly.
2557*/
2558
2559/* We need the thread's state earlier on x86_64 than we did on PPC;
2560   the PC won't fit in code_vector[1].  We shouldn't try to get it
2561   lazily (via catch_exception_raise_state()); until we own the
2562   exception lock, we shouldn't have it in userspace (since a GCing
2563   thread wouldn't know that we had our hands on it.)
2564*/
2565
2566#ifdef X8664
2567#define ts_pc(t) t.__rip
2568#else
2569#define ts_pc(t) t.eip
2570#endif
2571
2572#ifdef DARWIN_USE_PSEUDO_SIGRETURN
2573#define DARWIN_EXCEPTION_HANDLER signal_handler
2574#else
2575#define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler
2576#endif
2577
2578
2579kern_return_t
2580catch_exception_raise(mach_port_t exception_port,
2581                      mach_port_t thread,
2582                      mach_port_t task, 
2583                      exception_type_t exception,
2584                      exception_data_t code_vector,
2585                      mach_msg_type_number_t code_count)
2586{
2587  int signum = 0, code = *code_vector, code1;
2588  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
2589  kern_return_t kret, call_kret;
2590#ifdef X8664
2591  x86_thread_state64_t ts;
2592#else
2593  x86_thread_state_t ts;
2594#endif
2595  mach_msg_type_number_t thread_state_count;
2596
2597
2598
2599#ifdef DEBUG_MACH_EXCEPTIONS
2600  fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
2601#endif
2602
2603
2604  if (
2605#if USE_MACH_EXCEPTION_LOCK
2606      pthread_mutex_trylock(mach_exception_lock) == 0
2607#else
2608      1
2609#endif
2610      ) {
2611#ifdef X8664
2612    do {
2613      thread_state_count = x86_THREAD_STATE64_COUNT;
2614      call_kret = thread_get_state(thread,
2615                                   x86_THREAD_STATE64,
2616                                   (thread_state_t)&ts,
2617                                   &thread_state_count);
2618    } while (call_kret == KERN_ABORTED);
2619  MACH_CHECK_ERROR("getting thread state",call_kret);
2620#else
2621    thread_state_count = x86_THREAD_STATE_COUNT;
2622    thread_get_state(thread,
2623                     x86_THREAD_STATE,
2624                     (thread_state_t)&ts,
2625                     &thread_state_count);
2626#endif
2627    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
2628      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2629    } 
2630    if ((code == EXC_I386_GPFLT) &&
2631        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
2632      kret = do_pseudo_sigreturn(thread, tcr);
2633#if 0
2634      fprintf(stderr, "Exception return in 0x%x\n",tcr);
2635#endif
2636    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
2637      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
2638      kret = 17;
2639    } else {
2640      switch (exception) {
2641      case EXC_BAD_ACCESS:
2642        if (code == EXC_I386_GPFLT) {
2643          signum = SIGSEGV;
2644        } else {
2645          signum = SIGBUS;
2646        }
2647        break;
2648       
2649      case EXC_BAD_INSTRUCTION:
2650        if (code == EXC_I386_GPFLT) {
2651          signum = SIGSEGV;
2652        } else {
2653          signum = SIGILL;
2654        }
2655        break;
2656         
2657      case EXC_SOFTWARE:
2658        signum = SIGILL;
2659        break;
2660       
2661      case EXC_ARITHMETIC:
2662        signum = SIGFPE;
2663        break;
2664       
2665      default:
2666        break;
2667      }
2668      if (signum) {
2669        kret = setup_signal_frame(thread,
2670                                  (void *)DARWIN_EXCEPTION_HANDLER,
2671                                  signum,
2672                                  code,
2673                                  tcr, 
2674                                  &ts);
2675#if 0
2676        fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
2677#endif
2678       
2679      } else {
2680        kret = 17;
2681      }
2682    }
2683#if USE_MACH_EXCEPTION_LOCK
2684#ifdef DEBUG_MACH_EXCEPTIONS
2685    fprintf(stderr, "releasing Mach exception lock in exception thread\n");
2686#endif
2687    pthread_mutex_unlock(mach_exception_lock);
2688#endif
2689  } else {
2690    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
2691     
2692#if 0
2693    fprintf(stderr, "deferring pending exception in 0x%x\n", tcr);
2694#endif
2695    kret = KERN_SUCCESS;
2696    if (tcr == gc_tcr) {
2697      int i;
2698      write(1, "exception in GC thread. Sleeping for 60 seconds\n",sizeof("exception in GC thread.  Sleeping for 60 seconds\n"));
2699      for (i = 0; i < 60; i++) {
2700        sleep(1);
2701      }
2702      _exit(EX_SOFTWARE);
2703    }
2704  }
2705  return kret;
2706}
2707
2708
2709
2710
2711static mach_port_t mach_exception_thread = (mach_port_t)0;
2712
2713
2714/*
2715  The initial function for an exception-handling thread.
2716*/
2717
2718void *
2719exception_handler_proc(void *arg)
2720{
2721  extern boolean_t exc_server();
2722  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
2723
2724  mach_exception_thread = pthread_mach_thread_np(pthread_self());
2725  mach_msg_server(exc_server, 256, p, 0);
2726  /* Should never return. */
2727  abort();
2728}
2729
2730
2731
2732void
2733mach_exception_thread_shutdown()
2734{
2735  kern_return_t kret;
2736
2737  fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
2738  kret = thread_terminate(mach_exception_thread);
2739  if (kret != KERN_SUCCESS) {
2740    fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
2741  }
2742}
2743
2744
2745mach_port_t
2746mach_exception_port_set()
2747{
2748  static mach_port_t __exception_port_set = MACH_PORT_NULL;
2749  kern_return_t kret; 
2750  if (__exception_port_set == MACH_PORT_NULL) {
2751#if USE_MACH_EXCEPTION_LOCK
2752    mach_exception_lock = &_mach_exception_lock;
2753    pthread_mutex_init(mach_exception_lock, NULL);
2754#endif
2755
2756    kret = mach_port_allocate(mach_task_self(),
2757                              MACH_PORT_RIGHT_PORT_SET,
2758                              &__exception_port_set);
2759    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
2760    create_system_thread(0,
2761                         NULL,
2762                         exception_handler_proc, 
2763                         (void *)((natural)__exception_port_set));
2764  }
2765  return __exception_port_set;
2766}
2767
2768/*
2769  Setup a new thread to handle those exceptions specified by
2770  the mask "which".  This involves creating a special Mach
2771  message port, telling the Mach kernel to send exception
2772  messages for the calling thread to that port, and setting
2773  up a handler thread which listens for and responds to
2774  those messages.
2775
2776*/
2777
2778/*
2779  Establish the lisp thread's TCR as its exception port, and determine
2780  whether any other ports have been established by foreign code for
2781  exceptions that lisp cares about.
2782
2783  If this happens at all, it should happen on return from foreign
2784  code and on entry to lisp code via a callback.
2785
2786  This is a lot of trouble (and overhead) to support Java, or other
2787  embeddable systems that clobber their caller's thread exception ports.
2788 
2789*/
2790kern_return_t
2791tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
2792{
2793  kern_return_t kret;
2794  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
2795  int i;
2796  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
2797  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
2798  exception_mask_t mask = 0;
2799
2800  kret = thread_swap_exception_ports(thread,
2801                                     LISP_EXCEPTIONS_HANDLED_MASK,
2802                                     lisp_port,
2803                                     EXCEPTION_DEFAULT,
2804                                     THREAD_STATE_NONE,
2805                                     fxs->masks,
2806                                     &n,
2807                                     fxs->ports,
2808                                     fxs->behaviors,
2809                                     fxs->flavors);
2810  if (kret == KERN_SUCCESS) {
2811    fxs->foreign_exception_port_count = n;
2812    for (i = 0; i < n; i ++) {
2813      foreign_port = fxs->ports[i];
2814
2815      if ((foreign_port != lisp_port) &&
2816          (foreign_port != MACH_PORT_NULL)) {
2817        mask |= fxs->masks[i];
2818      }
2819    }
2820    tcr->foreign_exception_status = (int) mask;
2821  }
2822  return kret;
2823}
2824
2825kern_return_t
2826tcr_establish_lisp_exception_port(TCR *tcr)
2827{
2828  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
2829}
2830
2831/*
2832  Do this when calling out to or returning from foreign code, if
2833  any conflicting foreign exception ports were established when we
2834  last entered lisp code.
2835*/
2836kern_return_t
2837restore_foreign_exception_ports(TCR *tcr)
2838{
2839  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
2840 
2841  if (m) {
2842    MACH_foreign_exception_state *fxs  = 
2843      (MACH_foreign_exception_state *) tcr->native_thread_info;
2844    int i, n = fxs->foreign_exception_port_count;
2845    exception_mask_t tm;
2846
2847    for (i = 0; i < n; i++) {
2848      if ((tm = fxs->masks[i]) & m) {
2849        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
2850                                   tm,
2851                                   fxs->ports[i],
2852                                   fxs->behaviors[i],
2853                                   fxs->flavors[i]);
2854      }
2855    }
2856  }
2857}
2858                                   
2859
2860/*
2861  This assumes that a Mach port (to be used as the thread's exception port) whose
2862  "name" matches the TCR's 32-bit address has already been allocated.
2863*/
2864
2865kern_return_t
2866setup_mach_exception_handling(TCR *tcr)
2867{
2868  mach_port_t
2869    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
2870    target_thread = pthread_mach_thread_np((pthread_t)ptr_from_lispobj(tcr->osid)),
2871    task_self = mach_task_self();
2872  kern_return_t kret;
2873
2874  kret = mach_port_insert_right(task_self,
2875                                thread_exception_port,
2876                                thread_exception_port,
2877                                MACH_MSG_TYPE_MAKE_SEND);
2878  MACH_CHECK_ERROR("adding send right to exception_port",kret);
2879
2880  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
2881  if (kret == KERN_SUCCESS) {
2882    mach_port_t exception_port_set = mach_exception_port_set();
2883
2884    kret = mach_port_move_member(task_self,
2885                                 thread_exception_port,
2886                                 exception_port_set);
2887  }
2888  return kret;
2889}
2890
2891void
2892darwin_exception_init(TCR *tcr)
2893{
2894  void tcr_monitor_exception_handling(TCR*, Boolean);
2895  kern_return_t kret;
2896  MACH_foreign_exception_state *fxs = 
2897    calloc(1, sizeof(MACH_foreign_exception_state));
2898 
2899  tcr->native_thread_info = (void *) fxs;
2900
2901  if ((kret = setup_mach_exception_handling(tcr))
2902      != KERN_SUCCESS) {
2903    fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
2904    terminate_lisp();
2905  }
2906  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
2907  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
2908}
2909
2910/*
2911  The tcr is the "name" of the corresponding thread's exception port.
2912  Destroying the port should remove it from all port sets of which it's
2913  a member (notably, the exception port set.)
2914*/
2915void
2916darwin_exception_cleanup(TCR *tcr)
2917{
2918  void *fxs = tcr->native_thread_info;
2919  extern Boolean use_mach_exception_handling;
2920
2921  if (fxs) {
2922    tcr->native_thread_info = NULL;
2923    free(fxs);
2924  }
2925  if (use_mach_exception_handling) {
2926    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2927    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
2928  }
2929}
2930
2931
2932Boolean
2933suspend_mach_thread(mach_port_t mach_thread)
2934{
2935  kern_return_t status;
2936  Boolean aborted = false;
2937 
2938  do {
2939    aborted = false;
2940    status = thread_suspend(mach_thread);
2941    if (status == KERN_SUCCESS) {
2942      status = thread_abort_safely(mach_thread);
2943      if (status == KERN_SUCCESS) {
2944        aborted = true;
2945      } else {
2946        fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
2947        thread_resume(mach_thread);
2948      }
2949    } else {
2950      return false;
2951    }
2952  } while (! aborted);
2953  return true;
2954}
2955
2956/*
2957  Only do this if pthread_kill indicated that the pthread isn't
2958  listening to signals anymore, as can happen as soon as pthread_exit()
2959  is called on Darwin.  The thread could still call out to lisp as it
2960  is exiting, so we need another way to suspend it in this case.
2961*/
2962Boolean
2963mach_suspend_tcr(TCR *tcr)
2964{
2965  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
2966  ExceptionInformation *pseudosigcontext;
2967  Boolean result = false;
2968 
2969  result = suspend_mach_thread(mach_thread);
2970  if (result) {
2971    mach_msg_type_number_t thread_state_count;
2972#ifdef X8664
2973    x86_thread_state64_t ts;
2974    thread_state_count = x86_THREAD_STATE64_COUNT;
2975    thread_get_state(mach_thread,
2976                     x86_THREAD_STATE64,
2977                     (thread_state_t)&ts,
2978                     &thread_state_count);
2979#else
2980    x86_thread_state_t ts;
2981    thread_state_count = x86_THREAD_STATE_COUNT;
2982    thread_get_state(mach_thread,
2983                     x86_THREAD_STATE,
2984                     (thread_state_t)&ts,
2985                     &thread_state_count);
2986#endif
2987
2988    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
2989    pseudosigcontext->uc_onstack = 0;
2990    pseudosigcontext->uc_sigmask = (sigset_t) 0;
2991    tcr->suspend_context = pseudosigcontext;
2992  }
2993  return result;
2994}
2995
2996void
2997mach_resume_tcr(TCR *tcr)
2998{
2999  ExceptionInformation *xp;
3000  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
3001 
3002  xp = tcr->suspend_context;
3003#ifdef DEBUG_MACH_EXCEPTIONS
3004  fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
3005          tcr, tcr->pending_exception_context);
3006#endif
3007  tcr->suspend_context = NULL;
3008  restore_mach_thread_state(mach_thread, xp);
3009#ifdef DEBUG_MACH_EXCEPTIONS
3010  fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
3011          tcr, tcr->pending_exception_context);
3012#endif
3013  thread_resume(mach_thread);
3014}
3015
3016void
3017fatal_mach_error(char *format, ...)
3018{
3019  va_list args;
3020  char s[512];
3021 
3022
3023  va_start(args, format);
3024  vsnprintf(s, sizeof(s),format, args);
3025  va_end(args);
3026
3027  Fatal("Mach error", s);
3028}
3029
3030
3031
3032
3033#endif
Note: See TracBrowser for help on using the repository browser.