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

Last change on this file since 11113 was 11113, checked in by gb, 12 years ago

If we get a foreign exception in the low-level Windows handler, try
to continue from it after calling FBug (so that we can maybe set
a breakpoint ...)

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