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

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

Set result (in %imm0) when calling kill_tcr via trap.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 93.6 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      case XUUO_KILL:
1087        xpGPR(context,Iimm0) = (LispObj)kill_tcr(target);
1088        xpPC(context)+=3;
1089        break;
1090      default:
1091        return false;
1092      }
1093    } else {
1094      return false;
1095    }
1096    break;
1097   
1098  case SIGFPE:
1099#ifdef FREEBSD
1100    /* As of 6.1, FreeBSD/AMD64 doesn't seem real comfortable
1101       with this newfangled XMM business (and therefore info->si_code
1102       is often 0 on an XMM FP exception.
1103       Try to figure out what really happened by decoding mxcsr
1104       bits.
1105    */
1106    freebsd_decode_vector_fp_exception(info,context);
1107#endif
1108#ifdef DARWIN
1109    /* Same general problem with Darwin as of 8.7.2 */
1110    darwin_decode_vector_fp_exception(info,context);
1111#endif
1112
1113    return handle_floating_point_exception(tcr, context, info);
1114
1115#if SIGBUS != SIGNUM_FOR_INTN_TRAP
1116  case SIGBUS:
1117    return handle_fault(tcr, context, info, old_valence);
1118#endif
1119   
1120#if SIGSEGV != SIGNUM_FOR_INTN_TRAP
1121  case SIGSEGV:
1122    return handle_fault(tcr, context, info, old_valence);
1123#endif   
1124   
1125  default:
1126    return false;
1127  }
1128}
1129
1130
1131/*
1132   Current thread has all signals masked.  Before unmasking them,
1133   make it appear that the current thread has been suspended.
1134   (This is to handle the case where another thread is trying
1135   to GC before this thread is able to seize the exception lock.)
1136*/
1137int
1138prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context)
1139{
1140  int old_valence = tcr->valence;
1141
1142  tcr->pending_exception_context = context;
1143  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
1144
1145#ifdef WINDOWS
1146  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1147    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1148    SEM_RAISE(tcr->suspend);
1149    SEM_WAIT_FOREVER(tcr->resume);
1150  }
1151#else
1152  ALLOW_EXCEPTIONS(context);
1153#endif
1154  return old_valence;
1155} 
1156
1157void
1158wait_for_exception_lock_in_handler(TCR *tcr, 
1159                                   ExceptionInformation *context,
1160                                   xframe_list *xf)
1161{
1162
1163  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
1164#if 0
1165  fprintf(stderr, "0x" LISP " has exception lock\n", tcr);
1166#endif
1167  xf->curr = context;
1168#ifdef X8632
1169  xf->node_regs_mask = tcr->node_regs_mask;
1170#endif
1171  xf->prev = tcr->xframe;
1172  tcr->xframe =  xf;
1173  tcr->pending_exception_context = NULL;
1174  tcr->valence = TCR_STATE_FOREIGN; 
1175}
1176
1177void
1178unlock_exception_lock_in_handler(TCR *tcr)
1179{
1180  tcr->pending_exception_context = tcr->xframe->curr;
1181#ifdef X8632
1182  tcr->node_regs_mask = tcr->xframe->node_regs_mask;
1183#endif
1184  tcr->xframe = tcr->xframe->prev;
1185  tcr->valence = TCR_STATE_EXCEPTION_RETURN;
1186  UNLOCK(lisp_global(EXCEPTION_LOCK),tcr);
1187#if 0
1188  fprintf(stderr, "0x" LISP " released exception lock\n", tcr);
1189#endif
1190}
1191
1192/*
1193   If an interrupt is pending on exception exit, try to ensure
1194   that the thread sees it as soon as it's able to run.
1195*/
1196#ifdef WINDOWS
1197void
1198raise_pending_interrupt(TCR *tcr)
1199{
1200}
1201void
1202exit_signal_handler(TCR *tcr, int old_valence)
1203{
1204}
1205void
1206signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1207{
1208}
1209#else
1210void
1211raise_pending_interrupt(TCR *tcr)
1212{
1213  if ((TCR_INTERRUPT_LEVEL(tcr) >= 0) &&
1214      (tcr->interrupt_pending)) {
1215    pthread_kill((pthread_t)(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT);
1216  }
1217}
1218
1219void
1220exit_signal_handler(TCR *tcr, int old_valence)
1221{
1222  sigset_t mask;
1223  sigfillset(&mask);
1224 
1225  pthread_sigmask(SIG_SETMASK,&mask, NULL);
1226  tcr->valence = old_valence;
1227  tcr->pending_exception_context = NULL;
1228}
1229
1230void
1231signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1232{
1233#ifdef DARWIN_GS_HACK
1234  Boolean gs_was_tcr = ensure_gs_pthread();
1235#endif
1236  xframe_list xframe_link;
1237#ifndef DARWIN
1238  tcr = get_tcr(false);
1239
1240  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1241#endif
1242  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1243    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1244    pthread_kill(pthread_self(), thread_suspend_signal);
1245  }
1246  wait_for_exception_lock_in_handler(tcr,context, &xframe_link);
1247
1248
1249  if (! handle_exception(signum, info, context, tcr, old_valence)) {
1250    char msg[512];
1251    Boolean foreign = (old_valence != TCR_STATE_LISP);
1252
1253    snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x" LISP ", context->regs at #x" LISP "", signum, xpPC(context), (natural)xpGPRvector(context));
1254   
1255    if (lisp_Debugger(context, info, signum,  foreign, msg)) {
1256      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1257    }
1258  }
1259  unlock_exception_lock_in_handler(tcr);
1260#ifndef DARWIN_USE_PSEUDO_SIGRETURN
1261  exit_signal_handler(tcr, old_valence);
1262#endif
1263  /* raise_pending_interrupt(tcr); */
1264#ifdef DARWIN_GS_HACK
1265  if (gs_was_tcr) {
1266    set_gs_address(tcr);
1267  }
1268#endif
1269#ifndef DARWIN_USE_PSEUDO_SIGRETURN
1270  SIGRETURN(context);
1271#endif
1272}
1273#endif
1274
1275#ifdef DARWIN
1276void
1277pseudo_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1278{
1279  sigset_t mask;
1280
1281  sigfillset(&mask);
1282
1283  pthread_sigmask(SIG_SETMASK,&mask,&(context->uc_sigmask));
1284  signal_handler(signum, info, context, tcr, old_valence);
1285}
1286#endif
1287
1288
1289
1290#ifdef LINUX
1291/* type of pointer to saved fp state */
1292#ifdef X8664
1293typedef fpregset_t FPREGS;
1294#else
1295typedef struct _fpstate *FPREGS;
1296#endif
1297LispObj *
1298copy_fpregs(ExceptionInformation *xp, LispObj *current, FPREGS *destptr)
1299{
1300  FPREGS src = (FPREGS)(xp->uc_mcontext.fpregs), dest;
1301 
1302  if (src) {
1303    dest = ((FPREGS)current)-1;
1304    *dest = *src;
1305    *destptr = dest;
1306    current = (LispObj *) dest;
1307  }
1308  return current;
1309}
1310#endif
1311
1312#ifdef DARWIN
1313LispObj *
1314copy_darwin_mcontext(MCONTEXT_T context, 
1315                     LispObj *current, 
1316                     MCONTEXT_T *out)
1317{
1318  MCONTEXT_T dest = ((MCONTEXT_T)current)-1;
1319  dest = (MCONTEXT_T) (((LispObj)dest) & ~15);
1320
1321  *dest = *context;
1322  *out = dest;
1323  return (LispObj *)dest;
1324}
1325#endif
1326
1327LispObj *
1328copy_siginfo(siginfo_t *info, LispObj *current)
1329{
1330  siginfo_t *dest = ((siginfo_t *)current) - 1;
1331#if !defined(LINUX) || !defined(X8632)
1332  dest = (siginfo_t *) (((LispObj)dest)&~15);
1333#endif
1334  *dest = *info;
1335  return (LispObj *)dest;
1336}
1337
1338#ifdef LINUX
1339typedef FPREGS copy_ucontext_last_arg_t;
1340#else
1341typedef void * copy_ucontext_last_arg_t;
1342#endif
1343
1344#ifndef WINDOWS
1345LispObj *
1346copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1347{
1348  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1349#if !defined(LINUX) || !defined(X8632)
1350  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1351#endif
1352
1353  *dest = *context;
1354  /* Fix it up a little; where's the signal mask allocated, if indeed
1355     it is "allocated" ? */
1356#ifdef LINUX
1357  dest->uc_mcontext.fpregs = (fpregset_t)fp;
1358#endif
1359  dest->uc_stack.ss_sp = 0;
1360  dest->uc_stack.ss_size = 0;
1361  dest->uc_stack.ss_flags = 0;
1362  dest->uc_link = NULL;
1363  return (LispObj *)dest;
1364}
1365#endif
1366
1367
1368LispObj *
1369find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1370{
1371
1372  if (((BytePtr)rsp < foreign_area->low) ||
1373      ((BytePtr)rsp > foreign_area->high)) {
1374    rsp = (LispObj)(tcr->foreign_sp);
1375  }
1376  return (LispObj *) (((rsp-128) & ~15));
1377}
1378
1379#ifdef X8632
1380#ifdef LINUX
1381/* This is here for debugging.  On entry to a signal handler that
1382   receives info and context arguments, the stack should look exactly
1383   like this.  The "pretcode field" of the structure is the address
1384   of code that does an rt_sigreturn syscall, and rt_sigreturn expects
1385   %esp at the time of that syscall to be pointing just past the
1386   pretcode field.
1387   handle_signal_on_foreign_stack() and helpers have to be very
1388   careful to duplicate this "structure" exactly.
1389   Note that on x8664 Linux, rt_sigreturn expects a ucontext to
1390   be on top of the stack (with a siginfo_t underneath it.)
1391   It sort of half-works to do sigreturn via setcontext() on
1392   x8632 Linux, but (a) it may not be available on some distributions
1393   and (b) even a relatively modern version of it uses "fldenv" to
1394   restore FP context, and "fldenv" isn't nearly good enough.
1395*/
1396
1397struct rt_sigframe {
1398        char *pretcode;
1399        int sig;
1400        siginfo_t  *pinfo;
1401        void  *puc;
1402        siginfo_t info;
1403        struct ucontext uc;
1404        struct _fpstate fpstate;
1405        char retcode[8];
1406};
1407struct rt_sigframe *rtsf = 0;
1408
1409#endif
1410#endif
1411
1412#ifdef DARWIN
1413void
1414bogus_signal_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1415{
1416  if (signum == SIGSYS) {
1417    return;                     /* Leopard lossage */
1418  }
1419}
1420#endif
1421
1422#ifndef WINDOWS
1423/* x8632 Linux requires that the stack-allocated siginfo is nearer
1424   the top of stack than the stack-allocated ucontext.  If other
1425   platforms care, they expect the ucontext to be nearer the top
1426   of stack.
1427*/
1428
1429#if defined(LINUX) && defined(X8632)
1430#define UCONTEXT_ON_TOP_OF_STACK 0
1431#else
1432#define UCONTEXT_ON_TOP_OF_STACK 1
1433#endif
1434void
1435handle_signal_on_foreign_stack(TCR *tcr,
1436                               void *handler, 
1437                               int signum, 
1438                               siginfo_t *info, 
1439                               ExceptionInformation *context,
1440                               LispObj return_address
1441#ifdef DARWIN_GS_HACK
1442                               , Boolean gs_was_tcr
1443#endif
1444                               )
1445{
1446#ifdef LINUX
1447  FPREGS fpregs = NULL;
1448#else
1449  void *fpregs = NULL;
1450#endif
1451#ifdef DARWIN
1452  MCONTEXT_T mcontextp = NULL;
1453#endif
1454  siginfo_t *info_copy = NULL;
1455  ExceptionInformation *xp = NULL;
1456  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1457
1458#ifdef LINUX
1459  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1460#endif
1461#ifdef DARWIN
1462  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1463#endif
1464#if UCONTEXT_ON_TOP_OF_STACK
1465  /* copy info first */
1466  foreign_rsp = copy_siginfo(info, foreign_rsp);
1467  info_copy = (siginfo_t *)foreign_rsp;
1468  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1469  xp = (ExceptionInformation *)foreign_rsp;
1470#else
1471  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1472  xp = (ExceptionInformation *)foreign_rsp;
1473  foreign_rsp = copy_siginfo(info, foreign_rsp);
1474  info_copy = (siginfo_t *)foreign_rsp;
1475#endif
1476#ifdef DARWIN
1477  UC_MCONTEXT(xp) = mcontextp;
1478#endif
1479  *--foreign_rsp = return_address;
1480#ifdef DARWIN_GS_HACK
1481  if (gs_was_tcr) {
1482    set_gs_address(tcr);
1483  }
1484#endif
1485  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1486}
1487#endif
1488
1489
1490#ifndef WINDOWS
1491#ifndef USE_SIGALTSTACK
1492void
1493arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1494{
1495  TCR *tcr = get_interrupt_tcr(false);
1496#if 1
1497  if (tcr->valence != TCR_STATE_LISP) {
1498    FBug(context, "exception in foreign context");
1499  }
1500#endif
1501  {
1502    area *vs = tcr->vs_area;
1503    BytePtr current_sp = (BytePtr) current_stack_pointer();
1504
1505
1506    if ((current_sp >= vs->low) &&
1507        (current_sp < vs->high)) {
1508      handle_signal_on_foreign_stack(tcr,
1509                                     signal_handler,
1510                                     signum,
1511                                     info,
1512                                     context,
1513                                     (LispObj)__builtin_return_address(0)
1514#ifdef DARWIN_GS_HACK
1515                                     , false
1516#endif
1517
1518                                     );
1519    } else {
1520      signal_handler(signum, info, context, tcr, 0);
1521    }
1522  }
1523}
1524
1525#else
1526void
1527altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1528{
1529  TCR* tcr = get_tcr(true);
1530#if 1
1531  if (tcr->valence != TCR_STATE_LISP) {
1532    FBug(context, "exception in foreign context");
1533  }
1534#endif
1535  handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1536#ifdef DARWIN_GS_HACK
1537                                 , false
1538#endif
1539);
1540}
1541#endif
1542#endif
1543
1544Boolean
1545stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr)
1546{
1547  area *a = tcr->vs_area;
1548 
1549  return (((BytePtr)stack_pointer <= a->high) &&
1550          ((BytePtr)stack_pointer > a->low));
1551}
1552
1553
1554#ifdef WINDOWS
1555extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int);
1556#endif
1557
1558void
1559interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1560{
1561#ifdef DARWIN_GS_HACK
1562  Boolean gs_was_tcr = ensure_gs_pthread();
1563#endif
1564  TCR *tcr = get_interrupt_tcr(false);
1565  int old_valence = tcr->valence;
1566
1567  if (tcr) {
1568    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1569        (tcr->valence != TCR_STATE_LISP) ||
1570        (tcr->unwinding != 0) ||
1571        ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) ||
1572#ifdef X8664
1573        ! stack_pointer_on_vstack_p(xpGPR(context,Irbp), tcr)) {
1574#else
1575        ! stack_pointer_on_vstack_p(xpGPR(context,Iebp), tcr)) {
1576#endif
1577      tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1)));
1578    } else {
1579      LispObj cmain = nrs_CMAIN.vcell;
1580
1581      if ((fulltag_of(cmain) == fulltag_misc) &&
1582          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1583        /*
1584           This thread can (allegedly) take an interrupt now.
1585        */
1586
1587        xframe_list xframe_link;
1588        signed_natural alloc_displacement = 0;
1589        LispObj
1590          *next_tsp = tcr->next_tsp,
1591          *save_tsp = tcr->save_tsp,
1592          *p,
1593          q;
1594        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1595
1596        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1597           
1598        if (next_tsp != save_tsp) {
1599          tcr->next_tsp = save_tsp;
1600        } else {
1601          next_tsp = NULL;
1602        }
1603        /* have to do this before allowing interrupts */
1604        pc_luser_xp(context, tcr, &alloc_displacement);
1605        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1606        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1607        handle_exception(signum, info, context, tcr, old_valence);
1608        if (alloc_displacement) {
1609          tcr->save_allocptr -= alloc_displacement;
1610        }
1611        if (next_tsp) {
1612          tcr->next_tsp = next_tsp;
1613          p = next_tsp;
1614          while (p != save_tsp) {
1615            *p++ = 0;
1616          }
1617          q = (LispObj)save_tsp;
1618          *next_tsp = q;
1619        }
1620        tcr->flags |= old_foreign_exception;
1621        unlock_exception_lock_in_handler(tcr);
1622#ifndef WINDOWS
1623        exit_signal_handler(tcr, old_valence);
1624#endif
1625      }
1626    }
1627  }
1628#ifdef DARWIN_GS_HACK
1629  if (gs_was_tcr) {
1630    set_gs_address(tcr);
1631  }
1632#endif
1633#ifdef WINDOWS
1634  restore_windows_context(context,tcr,old_valence);
1635#else
1636  SIGRETURN(context);
1637#endif
1638}
1639
1640
1641#ifndef WINDOWS
1642#ifndef USE_SIGALTSTACK
1643void
1644arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1645{
1646#ifdef DARWIN_GS_HACK
1647  Boolean gs_was_tcr = ensure_gs_pthread();
1648#endif
1649  TCR *tcr = get_interrupt_tcr(false);
1650  area *vs = tcr->vs_area;
1651  BytePtr current_sp = (BytePtr) current_stack_pointer();
1652
1653  if ((current_sp >= vs->low) &&
1654      (current_sp < vs->high)) {
1655    handle_signal_on_foreign_stack(tcr,
1656                                   interrupt_handler,
1657                                   signum,
1658                                   info,
1659                                   context,
1660                                   (LispObj)__builtin_return_address(0)
1661#ifdef DARWIN_GS_HACK
1662                                   ,gs_was_tcr
1663#endif
1664                                   );
1665  } else {
1666    /* If we're not on the value stack, we pretty much have to be on
1667       the C stack.  Just run the handler. */
1668#ifdef DARWIN_GS_HACK
1669    if (gs_was_tcr) {
1670      set_gs_address(tcr);
1671    }
1672#endif
1673    interrupt_handler(signum, info, context);
1674  }
1675}
1676
1677#else /* altstack works */
1678 
1679void
1680altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1681{
1682#ifdef DARWIN_GS_HACK
1683  Boolean gs_was_tcr = ensure_gs_pthread();
1684#endif
1685  TCR *tcr = get_interrupt_tcr(false);
1686  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1687#ifdef DARWIN_GS_HACK
1688                                 ,gs_was_tcr
1689#endif
1690                                 );
1691}
1692
1693#endif
1694#endif
1695
1696#ifndef WINDOWS
1697void
1698install_signal_handler(int signo, void * handler)
1699{
1700  struct sigaction sa;
1701 
1702  sa.sa_sigaction = (void *)handler;
1703  sigfillset(&sa.sa_mask);
1704#ifdef FREEBSD
1705  /* Strange FreeBSD behavior wrt synchronous signals */
1706  sigdelset(&sa.sa_mask,SIGNUM_FOR_INTN_TRAP);
1707  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1708  sigdelset(&sa.sa_mask,SIGILL);
1709  sigdelset(&sa.sa_mask,SIGFPE);
1710  sigdelset(&sa.sa_mask,SIGSEGV);
1711#endif
1712  sa.sa_flags = 
1713    0 /* SA_RESTART */
1714#ifdef USE_SIGALTSTACK
1715    | SA_ONSTACK
1716#endif
1717    | SA_SIGINFO;
1718
1719  sigaction(signo, &sa, NULL);
1720}
1721#endif
1722
1723#ifdef WINDOWS
1724BOOL
1725CALLBACK ControlEventHandler(DWORD event)
1726{
1727  switch(event) {
1728  case CTRL_C_EVENT:
1729    lisp_global(INTFLAG) = (1 << fixnumshift);
1730    return TRUE;
1731    break;
1732  default:
1733    return FALSE;
1734  }
1735}
1736
1737int
1738map_windows_exception_code_to_posix_signal(DWORD code)
1739{
1740  switch (code) {
1741  case EXCEPTION_ACCESS_VIOLATION:
1742    return SIGSEGV;
1743  case EXCEPTION_FLT_DENORMAL_OPERAND:
1744  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
1745  case EXCEPTION_FLT_INEXACT_RESULT:
1746  case EXCEPTION_FLT_INVALID_OPERATION:
1747  case EXCEPTION_FLT_OVERFLOW:
1748  case EXCEPTION_FLT_STACK_CHECK:
1749  case EXCEPTION_FLT_UNDERFLOW:
1750  case EXCEPTION_INT_DIVIDE_BY_ZERO:
1751  case EXCEPTION_INT_OVERFLOW:
1752    return SIGFPE;
1753  case EXCEPTION_PRIV_INSTRUCTION:
1754  case EXCEPTION_ILLEGAL_INSTRUCTION:
1755    return SIGILL;
1756  case EXCEPTION_IN_PAGE_ERROR:
1757    return SIGBUS;
1758  default:
1759    return -1;
1760  }
1761}
1762
1763
1764LONG
1765windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr)
1766{
1767  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1768  int old_valence, signal_number;
1769  ExceptionInformation *context = exception_pointers->ContextRecord;
1770  siginfo_t *info = exception_pointers->ExceptionRecord;
1771  xframe_list xframes;
1772
1773  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1774  wait_for_exception_lock_in_handler(tcr, context, &xframes);
1775
1776  signal_number = map_windows_exception_code_to_posix_signal(code);
1777 
1778  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
1779    char msg[512];
1780    Boolean foreign = (old_valence != TCR_STATE_LISP);
1781
1782    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));
1783   
1784    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
1785      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1786    }
1787  }
1788  unlock_exception_lock_in_handler(tcr);
1789  return restore_windows_context(context, tcr, old_valence);
1790}
1791
1792void
1793setup_exception_handler_call(CONTEXT *context,
1794                             LispObj new_sp,
1795                             void *handler,
1796                             EXCEPTION_POINTERS *new_ep,
1797                             TCR *tcr)
1798{
1799  extern void windows_halt(void);
1800  LispObj *p = (LispObj *)new_sp;
1801#ifdef WIN_64
1802  p-=4;                         /* win64 abi argsave nonsense */
1803  *(--p) = (LispObj)windows_halt;
1804  context->Rsp = (DWORD64)p;
1805  context->Rip = (DWORD64)handler;
1806  context->Rcx = (DWORD64)new_ep;
1807  context->Rdx = (DWORD64)tcr;
1808#else
1809  p-=4;                          /* args on stack, stack aligned */
1810  p[0] = (LispObj)new_ep;
1811  p[1] = (LispObj)tcr;
1812  *(--p) = (LispObj)windows_halt;
1813  context->Esp = (DWORD)p;
1814  context->Eip = (DWORD)handler;
1815#ifdef WIN32_ES_HACK
1816  context->SegEs = context->SegDs;
1817#endif
1818#endif
1819  context->EFlags &= ~0x400;  /* clear direction flag */
1820}
1821
1822void
1823prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr,
1824                                                     CONTEXT *context,
1825                                                     void *handler,
1826                                                     EXCEPTION_POINTERS *original_ep)
1827{
1828  LispObj foreign_rsp = 
1829    (LispObj) (tcr->foreign_sp - 128) & ~15;
1830  CONTEXT *new_context;
1831  siginfo_t *new_info;
1832  EXCEPTION_POINTERS *new_ep;
1833
1834  new_context = ((CONTEXT *)(foreign_rsp&~15))-1;
1835  *new_context = *context;
1836  foreign_rsp = (LispObj)new_context;
1837  new_info = ((siginfo_t *)(foreign_rsp&~15))-1;
1838  *new_info = *original_ep->ExceptionRecord;
1839  foreign_rsp = (LispObj)new_info;
1840  new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1;
1841  foreign_rsp = (LispObj)new_ep & ~15;
1842  new_ep->ContextRecord = new_context;
1843  new_ep->ExceptionRecord = new_info;
1844  setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr);
1845}
1846
1847LONG CALLBACK
1848windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers)
1849{
1850  extern void ensure_safe_for_string_operations(void);
1851  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1852
1853
1854 
1855  if ((code & 0x80000000L) == 0) {
1856    return EXCEPTION_CONTINUE_SEARCH;
1857  } else {
1858    TCR *tcr = get_interrupt_tcr(false);
1859    area *cs = tcr->cs_area;
1860    BytePtr current_sp = (BytePtr) current_stack_pointer();
1861    CONTEXT *context = exception_pointers->ContextRecord;
1862   
1863    ensure_safe_for_string_operations();
1864
1865    if ((current_sp >= cs->low) &&
1866        (current_sp < cs->high)) {
1867      debug_show_registers(context, exception_pointers->ExceptionRecord, 0);
1868      FBug(context, "Exception on foreign stack\n");
1869      return EXCEPTION_CONTINUE_EXECUTION;
1870    }
1871
1872    prepare_to_handle_windows_exception_on_foreign_stack(tcr,
1873                                                         context,
1874                                                         windows_exception_handler,
1875                                                         exception_pointers);
1876    return EXCEPTION_CONTINUE_EXECUTION;
1877  }
1878}
1879
1880
1881void
1882install_pmcl_exception_handlers()
1883{
1884  AddVectoredExceptionHandler(1,windows_arbstack_exception_handler);
1885}
1886#else
1887void
1888install_pmcl_exception_handlers()
1889{
1890#ifndef DARWIN 
1891  void *handler = (void *)
1892#ifdef USE_SIGALTSTACK
1893    altstack_signal_handler
1894#else
1895    arbstack_signal_handler;
1896#endif
1897  ;
1898  install_signal_handler(SIGILL, handler);
1899 
1900  install_signal_handler(SIGBUS, handler);
1901  install_signal_handler(SIGSEGV,handler);
1902  install_signal_handler(SIGFPE, handler);
1903#else
1904  install_signal_handler(SIGTRAP,bogus_signal_handler);
1905  install_signal_handler(SIGILL, bogus_signal_handler);
1906 
1907  install_signal_handler(SIGBUS, bogus_signal_handler);
1908  install_signal_handler(SIGSEGV,bogus_signal_handler);
1909  install_signal_handler(SIGFPE, bogus_signal_handler);
1910  /*  9.0.0d8 generates spurious SIGSYS from mach_msg_trap */
1911  install_signal_handler(SIGSYS, bogus_signal_handler);
1912#endif
1913 
1914  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT,
1915#ifdef USE_SIGALTSTACK
1916                         altstack_interrupt_handler
1917#else
1918                         arbstack_interrupt_handler
1919#endif
1920);
1921  signal(SIGPIPE, SIG_IGN);
1922}
1923#endif
1924
1925#ifndef WINDOWS
1926#ifndef USE_SIGALTSTACK
1927void
1928arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1929{
1930#ifdef DARWIN_GS_HACK
1931  Boolean gs_was_tcr = ensure_gs_pthread();
1932#endif
1933  TCR *tcr = get_interrupt_tcr(false);
1934  area *vs = tcr->vs_area;
1935  BytePtr current_sp = (BytePtr) current_stack_pointer();
1936
1937  if ((current_sp >= vs->low) &&
1938      (current_sp < vs->high)) {
1939    handle_signal_on_foreign_stack(tcr,
1940                                   suspend_resume_handler,
1941                                   signum,
1942                                   info,
1943                                   context,
1944                                   (LispObj)__builtin_return_address(0)
1945#ifdef DARWIN_GS_HACK
1946                                   ,gs_was_tcr
1947#endif
1948                                   );
1949  } else {
1950    /* If we're not on the value stack, we pretty much have to be on
1951       the C stack.  Just run the handler. */
1952#ifdef DARWIN_GS_HACK
1953    if (gs_was_tcr) {
1954      set_gs_address(tcr);
1955    }
1956#endif
1957    suspend_resume_handler(signum, info, context);
1958  }
1959}
1960
1961
1962#else /* altstack works */
1963void
1964altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1965{
1966#ifdef DARWIN_GS_HACK
1967  Boolean gs_was_tcr = ensure_gs_pthread();
1968#endif
1969  TCR* tcr = get_tcr(true);
1970  handle_signal_on_foreign_stack(tcr,
1971                                 suspend_resume_handler,
1972                                 signum,
1973                                 info,
1974                                 context,
1975                                 (LispObj)__builtin_return_address(0)
1976#ifdef DARWIN_GS_HACK
1977                                 ,gs_was_tcr
1978#endif
1979                                 );
1980}
1981#endif
1982#endif
1983
1984#ifdef WINDOWS
1985void
1986quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1987{
1988}
1989#else
1990void
1991quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
1992{
1993#ifdef DARWIN_GS_HACK
1994  Boolean gs_was_tcr = ensure_gs_pthread();
1995#endif
1996  TCR *tcr = get_tcr(false);
1997  area *a;
1998  sigset_t mask;
1999 
2000  sigemptyset(&mask);
2001
2002
2003  if (tcr) {
2004    tcr->valence = TCR_STATE_FOREIGN;
2005    a = tcr->vs_area;
2006    if (a) {
2007      a->active = a->high;
2008    }
2009    a = tcr->ts_area;
2010    if (a) {
2011      a->active = a->high;
2012    }
2013    a = tcr->cs_area;
2014    if (a) {
2015      a->active = a->high;
2016    }
2017  }
2018 
2019  pthread_sigmask(SIG_SETMASK,&mask,NULL);
2020  pthread_exit(NULL);
2021}
2022#endif
2023
2024#ifndef WINDOWS
2025#ifndef USE_SIGALTSTACK
2026void
2027arbstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2028{
2029#ifdef DARWIN_GS_HACK
2030  Boolean gs_was_tcr = ensure_gs_pthread();
2031#endif
2032  TCR *tcr = get_interrupt_tcr(false);
2033  area *vs = tcr->vs_area;
2034  BytePtr current_sp = (BytePtr) current_stack_pointer();
2035
2036  if ((current_sp >= vs->low) &&
2037      (current_sp < vs->high)) {
2038    handle_signal_on_foreign_stack(tcr,
2039                                   quit_handler,
2040                                   signum,
2041                                   info,
2042                                   context,
2043                                   (LispObj)__builtin_return_address(0)
2044#ifdef DARWIN_GS_HACK
2045                                   ,gs_was_tcr
2046#endif
2047                                   );
2048  } else {
2049    /* If we're not on the value stack, we pretty much have to be on
2050       the C stack.  Just run the handler. */
2051#ifdef DARWIN_GS_HACK
2052    if (gs_was_tcr) {
2053      set_gs_address(tcr);
2054    }
2055#endif
2056    quit_handler(signum, info, context);
2057  }
2058}
2059
2060
2061#else
2062void
2063altstack_quit_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2064{
2065#ifdef DARWIN_GS_HACK
2066  Boolean gs_was_tcr = ensure_gs_pthread();
2067#endif
2068  TCR* tcr = get_tcr(true);
2069  handle_signal_on_foreign_stack(tcr,
2070                                 quit_handler,
2071                                 signum,
2072                                 info,
2073                                 context,
2074                                 (LispObj)__builtin_return_address(0)
2075#ifdef DARWIN_GS_HACK
2076                                 ,gs_was_tcr
2077#endif
2078                                 );
2079}
2080#endif
2081#endif
2082
2083#ifdef USE_SIGALTSTACK
2084#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
2085#define QUIT_HANDLER altstack_quit_handler
2086#else
2087#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
2088#define QUIT_HANDLER arbstack_quit_handler
2089#endif
2090
2091#ifdef WINDOWS
2092void
2093thread_signal_setup()
2094{
2095}
2096#else
2097void
2098thread_signal_setup()
2099{
2100  thread_suspend_signal = SIG_SUSPEND_THREAD;
2101
2102  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER);
2103  install_signal_handler(SIGQUIT, (void *)QUIT_HANDLER);
2104}
2105#endif
2106
2107void
2108enable_fp_exceptions()
2109{
2110}
2111
2112void
2113exception_init()
2114{
2115  install_pmcl_exception_handlers();
2116}
2117
2118void
2119adjust_exception_pc(ExceptionInformation *xp, int delta)
2120{
2121  xpPC(xp) += delta;
2122}
2123
2124/*
2125  Lower (move toward 0) the "end" of the soft protected area associated
2126  with a by a page, if we can.
2127*/
2128
2129void
2130
2131adjust_soft_protection_limit(area *a)
2132{
2133  char *proposed_new_soft_limit = a->softlimit - 4096;
2134  protected_area_ptr p = a->softprot;
2135 
2136  if (proposed_new_soft_limit >= (p->start+16384)) {
2137    p->end = proposed_new_soft_limit;
2138    p->protsize = p->end-p->start;
2139    a->softlimit = proposed_new_soft_limit;
2140  }
2141  protect_area(p);
2142}
2143
2144void
2145restore_soft_stack_limit(unsigned restore_tsp)
2146{
2147  TCR *tcr = get_tcr(false);
2148  area *a;
2149 
2150  if (restore_tsp) {
2151    a = tcr->ts_area;
2152  } else {
2153    a = tcr->vs_area;
2154  }
2155  adjust_soft_protection_limit(a);
2156}
2157
2158
2159#ifdef USE_SIGALTSTACK
2160void
2161setup_sigaltstack(area *a)
2162{
2163  stack_t stack;
2164  stack.ss_sp = a->low;
2165  a->low += SIGSTKSZ*8;
2166  stack.ss_size = SIGSTKSZ*8;
2167  stack.ss_flags = 0;
2168  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
2169  if (sigaltstack(&stack, NULL) != 0) {
2170    perror("sigaltstack");
2171    exit(-1);
2172  }
2173}
2174#endif
2175
2176extern opcode egc_write_barrier_start, egc_write_barrier_end,
2177  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2178  egc_store_node_conditional_success_end,
2179  egc_store_node_conditional_success_test,egc_store_node_conditional,
2180  egc_set_hash_key, egc_gvset, egc_rplacd;
2181
2182/* We use (extremely) rigidly defined instruction sequences for consing,
2183   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2184   while consing.
2185
2186   Note that we can usually identify which of these instructions is about
2187   to be executed by a stopped thread without comparing all of the bytes
2188   to those at the stopped program counter, but we generally need to
2189   know the sizes of each of these instructions.
2190*/
2191
2192#ifdef X8664
2193opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2194#ifdef WINDOWS
2195  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2196#else
2197  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2198#endif
2199;
2200opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2201#ifdef WINDOWS
2202  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2203#else
2204  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2205#endif
2206
2207;
2208opcode branch_around_alloc_trap_instruction[] =
2209  {0x7f,0x02};
2210opcode alloc_trap_instruction[] =
2211  {0xcd,0xc5};
2212opcode clear_tcr_save_allocptr_tag_instruction[] =
2213#ifdef WINDOWS
2214  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2215#else
2216  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2217#endif
2218;
2219opcode set_allocptr_header_instruction[] =
2220  {0x48,0x89,0x43,0xf3};
2221
2222
2223alloc_instruction_id
2224recognize_alloc_instruction(pc program_counter)
2225{
2226  switch(program_counter[0]) {
2227  case 0xcd: return ID_alloc_trap_instruction;
2228  case 0x7f: return ID_branch_around_alloc_trap_instruction;
2229  case 0x48: return ID_set_allocptr_header_instruction;
2230#ifdef WINDOWS
2231  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2232  case 0x49:
2233    switch(program_counter[1]) {
2234    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2235    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2236    }
2237#else
2238  case 0x65: 
2239    switch(program_counter[1]) {
2240    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2241    case 0x48:
2242      switch(program_counter[2]) {
2243      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2244      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2245      }
2246    }
2247#endif
2248  default: break;
2249  }
2250  return ID_unrecognized_alloc_instruction;
2251}
2252#endif
2253#ifdef X8632
2254opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2255  {0x64,0x8b,0x0d,0x84,0x00,0x00,0x00};
2256opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2257  {0x64,0x3b,0x0d,0x88,0x00,0x00,0x00};
2258opcode branch_around_alloc_trap_instruction[] =
2259  {0x7f,0x02};
2260opcode alloc_trap_instruction[] =
2261  {0xcd,0xc5};
2262opcode clear_tcr_save_allocptr_tag_instruction[] =
2263  {0x64,0x80,0x25,0x84,0x00,0x00,0x00,0xf8};
2264opcode set_allocptr_header_instruction[] =
2265  {0x0f,0x7e,0x41,0xfa};
2266
2267alloc_instruction_id
2268recognize_alloc_instruction(pc program_counter)
2269{
2270  switch(program_counter[0]) {
2271  case 0xcd: return ID_alloc_trap_instruction;
2272  case 0x7f: return ID_branch_around_alloc_trap_instruction;
2273  case 0x0f: return ID_set_allocptr_header_instruction;
2274  case 0x64: 
2275    switch(program_counter[1]) {
2276    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2277    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2278    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2279    }
2280  }
2281  return ID_unrecognized_alloc_instruction;
2282}
2283#endif     
2284
2285void
2286pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2287{
2288  pc program_counter = (pc)xpPC(xp);
2289  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2290
2291  if (allocptr_tag != 0) {
2292    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2293#ifdef X8664
2294    signed_natural
2295      disp = (allocptr_tag == fulltag_cons) ?
2296      sizeof(cons) - fulltag_cons :
2297      xpGPR(xp,Iimm1);
2298#else
2299      signed_natural disp = (allocptr_tag == fulltag_cons) ?
2300      sizeof(cons) - fulltag_cons :
2301      xpMMXreg(xp,Imm0);
2302#endif
2303    LispObj new_vector;
2304
2305    if ((state == ID_unrecognized_alloc_instruction) ||
2306        ((state == ID_set_allocptr_header_instruction) &&
2307         (allocptr_tag != fulltag_misc))) {
2308      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2309    }
2310    switch(state) {
2311    case ID_set_allocptr_header_instruction:
2312      /* We were consing a vector and we won.  Set the header of the new vector
2313         (in the allocptr register) to the header in %rax and skip over this
2314         instruction, then fall into the next case. */
2315      new_vector = xpGPR(xp,Iallocptr);
2316      deref(new_vector,0) = xpGPR(xp,Iimm0);
2317
2318      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2319      /* Fall thru */
2320    case ID_clear_tcr_save_allocptr_tag_instruction:
2321      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2322      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2323      break;
2324    case ID_alloc_trap_instruction:
2325      /* If we're looking at another thread, we're pretty much committed to
2326         taking the trap.  We don't want the allocptr register to be pointing
2327         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2328         was determined above.
2329      */
2330      if (interrupt_displacement == NULL) {
2331        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2332        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2333      } else {
2334        /* Back out, and tell the caller how to resume the allocation attempt */
2335        *interrupt_displacement = disp;
2336        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2337        tcr->save_allocptr += disp;
2338        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2339                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2340                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2341      }
2342      break;
2343    case ID_branch_around_alloc_trap_instruction:
2344      /* If we'd take the branch - which is a "jg" - around the alloc trap,
2345         we might as well finish the allocation.  Otherwise, back out of the
2346         attempt. */
2347      {
2348        int flags = (int)eflags_register(xp);
2349       
2350        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2351            ((flags & (1 << X86_SIGN_FLAG_BIT)) ==
2352             (flags & (1 << X86_CARRY_FLAG_BIT)))) {
2353          /* The branch (jg) would have been taken.  Emulate taking it. */
2354          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2355                       sizeof(alloc_trap_instruction));
2356          if (allocptr_tag == fulltag_misc) {
2357            /* Slap the header on the new uvector */
2358            new_vector = xpGPR(xp,Iallocptr);
2359            deref(new_vector,0) = xpGPR(xp,Iimm0);
2360            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2361          }
2362          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2363          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2364        } else {
2365          /* Back up */
2366          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2367                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2368          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2369          if (interrupt_displacement) {
2370            *interrupt_displacement = disp;
2371            tcr->save_allocptr += disp;
2372          } else {
2373            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2374          }
2375        }
2376      }
2377      break;
2378    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2379      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2380      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2381      /* Fall through */
2382    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2383      if (interrupt_displacement) {
2384        tcr->save_allocptr += disp;
2385        *interrupt_displacement = disp;
2386      } else {
2387        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2388      }
2389      break;
2390    default: 
2391      break;
2392    }
2393    return;
2394  }
2395  if ((program_counter >= &egc_write_barrier_start) &&
2396      (program_counter < &egc_write_barrier_end)) {
2397    LispObj *ea = 0, val, root = 0;
2398    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2399    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
2400
2401    if (program_counter >= &egc_set_hash_key_conditional) {
2402      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
2403          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2404           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2405        /* Back up the PC, try again */
2406        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional;
2407        return;
2408      }
2409      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2410      val = xpGPR(xp,Iarg_z);
2411#ifdef X8664
2412      root = xpGPR(xp,Iarg_x);
2413      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2414#else
2415      root = xpGPR(xp,Itemp1);
2416      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2417#endif
2418      need_memoize_root = true;
2419      need_store = false;
2420      xpGPR(xp,Iarg_z) = t_value;
2421    } else if (program_counter >= &egc_store_node_conditional) {
2422      if ((program_counter < &egc_store_node_conditional_success_test) ||
2423          ((program_counter == &egc_store_node_conditional_success_test) &&
2424           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2425        /* Back up the PC, try again */
2426        xpPC(xp) = (LispObj) &egc_store_node_conditional;
2427        return;
2428      }
2429      if (program_counter >= &egc_store_node_conditional_success_end) {
2430        return;
2431      }
2432
2433      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2434      val = xpGPR(xp,Iarg_z);
2435#ifdef X8664
2436      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2437                                                       xpGPR(xp,Itemp0))));
2438#else
2439      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2440#endif
2441      xpGPR(xp,Iarg_z) = t_value;
2442      need_store = false;
2443    } else if (program_counter >= &egc_set_hash_key) {
2444#ifdef X8664
2445      root = xpGPR(xp,Iarg_x);
2446#else
2447      root = xpGPR(xp,Itemp0);
2448#endif
2449      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2450      val = xpGPR(xp,Iarg_z);
2451      need_memoize_root = true;
2452    } else if (program_counter >= &egc_gvset) {
2453#ifdef X8664
2454      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2455#else
2456      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2457#endif
2458      val = xpGPR(xp,Iarg_z);
2459    } else if (program_counter >= &egc_rplacd) {
2460      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2461      val = xpGPR(xp,Iarg_z);
2462    } else {                      /* egc_rplaca */
2463      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2464      val = xpGPR(xp,Iarg_z);
2465    }
2466    if (need_store) {
2467      *ea = val;
2468    }
2469    if (need_check_memo) {
2470      natural  bitnumber = area_dnode(ea, lisp_global(HEAP_START));
2471      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
2472          ((LispObj)ea < val)) {
2473        atomic_set_bit(refbits, bitnumber);
2474        if (need_memoize_root) {
2475          bitnumber = area_dnode(root, lisp_global(HEAP_START));
2476          atomic_set_bit(refbits, bitnumber);
2477        }
2478      }
2479    }
2480    {
2481      /* These subprimitives are called via CALL/RET; need
2482         to pop the return address off the stack and set
2483         the PC there. */
2484      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2485      xpPC(xp) = ra;
2486      xpGPR(xp,Isp)=(LispObj)sp;
2487    }
2488    return;
2489  }
2490}
2491
2492
2493void
2494normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2495{
2496  void *cur_allocptr = (void *)(tcr->save_allocptr);
2497  LispObj lisprsp;
2498  area *a;
2499
2500  if (xp) {
2501    if (is_other_tcr) {
2502      pc_luser_xp(xp, tcr, NULL);
2503    }
2504    a = tcr->vs_area;
2505    lisprsp = xpGPR(xp, Isp);
2506    if (((BytePtr)lisprsp >= a->low) &&
2507        ((BytePtr)lisprsp < a->high)) {
2508      a->active = (BytePtr)lisprsp;
2509    } else {
2510      a->active = (BytePtr) tcr->save_vsp;
2511    }
2512    a = tcr->ts_area;
2513    a->active = (BytePtr) tcr->save_tsp;
2514  } else {
2515    /* In ff-call; get area active pointers from tcr */
2516    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2517    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2518  }
2519  if (cur_allocptr) {
2520    update_bytes_allocated(tcr, cur_allocptr);
2521  }
2522  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2523  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2524    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2525  }
2526}
2527
2528
2529/* Suspend and "normalize" other tcrs, then call a gc-like function
2530   in that context.  Resume the other tcrs, then return what the
2531   function returned */
2532
2533TCR *gc_tcr = NULL;
2534
2535
2536int
2537gc_like_from_xp(ExceptionInformation *xp, 
2538                int(*fun)(TCR *, signed_natural), 
2539                signed_natural param)
2540{
2541  TCR *tcr = get_tcr(false), *other_tcr;
2542  int result;
2543  signed_natural inhibit;
2544
2545  suspend_other_threads(true);
2546  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2547  if (inhibit != 0) {
2548    if (inhibit > 0) {
2549      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2550    }
2551    resume_other_threads(true);
2552    gc_deferred++;
2553    return 0;
2554  }
2555  gc_deferred = 0;
2556
2557  gc_tcr = tcr;
2558
2559  /* This is generally necessary if the current thread invoked the GC
2560     via an alloc trap, and harmless if the GC was invoked via a GC
2561     trap.  (It's necessary in the first case because the "allocptr"
2562     register - %rbx - may be pointing into the middle of something
2563     below tcr->save_allocbase, and we wouldn't want the GC to see
2564     that bogus pointer.) */
2565  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2566
2567  normalize_tcr(xp, tcr, false);
2568
2569
2570  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
2571    if (other_tcr->pending_exception_context) {
2572      other_tcr->gc_context = other_tcr->pending_exception_context;
2573    } else if (other_tcr->valence == TCR_STATE_LISP) {
2574      other_tcr->gc_context = other_tcr->suspend_context;
2575    } else {
2576      /* no pending exception, didn't suspend in lisp state:
2577         must have executed a synchronous ff-call.
2578      */
2579      other_tcr->gc_context = NULL;
2580    }
2581    normalize_tcr(other_tcr->gc_context, other_tcr, true);
2582  }
2583   
2584
2585
2586  result = fun(tcr, param);
2587
2588  other_tcr = tcr;
2589  do {
2590    other_tcr->gc_context = NULL;
2591    other_tcr = other_tcr->next;
2592  } while (other_tcr != tcr);
2593
2594  gc_tcr = NULL;
2595
2596  resume_other_threads(true);
2597
2598  return result;
2599
2600}
2601
2602int
2603purify_from_xp(ExceptionInformation *xp, signed_natural param)
2604{
2605  return gc_like_from_xp(xp, purify, param);
2606}
2607
2608int
2609impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2610{
2611  return gc_like_from_xp(xp, impurify, param);
2612}
2613
2614/* Returns #bytes freed by invoking GC */
2615
2616int
2617gc_from_tcr(TCR *tcr, signed_natural param)
2618{
2619  area *a;
2620  BytePtr oldfree, newfree;
2621  BytePtr oldend, newend;
2622
2623#if 0
2624  fprintf(stderr, "Start GC  in 0x" LISP "\n", tcr);
2625#endif
2626  a = active_dynamic_area;
2627  oldend = a->high;
2628  oldfree = a->active;
2629  gc(tcr, param);
2630  newfree = a->active;
2631  newend = a->high;
2632#if 0
2633  fprintf(stderr, "End GC  in 0x" LISP "\n", tcr);
2634#endif
2635  return ((oldfree-newfree)+(newend-oldend));
2636}
2637
2638int
2639gc_from_xp(ExceptionInformation *xp, signed_natural param)
2640{
2641  int status = gc_like_from_xp(xp, gc_from_tcr, param);
2642
2643  freeGCptrs();
2644  return status;
2645}
2646
2647#ifdef DARWIN
2648
2649#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2650#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2651
2652extern void pseudo_sigreturn(void);
2653
2654
2655
2656#define LISP_EXCEPTIONS_HANDLED_MASK \
2657 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2658
2659/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2660#define NUM_LISP_EXCEPTIONS_HANDLED 4
2661
2662typedef struct {
2663  int foreign_exception_port_count;
2664  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2665  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2666  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2667  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2668} MACH_foreign_exception_state;
2669
2670
2671
2672
2673/*
2674  Mach's exception mechanism works a little better than its signal
2675  mechanism (and, not incidentally, it gets along with GDB a lot
2676  better.
2677
2678  Initially, we install an exception handler to handle each native
2679  thread's exceptions.  This process involves creating a distinguished
2680  thread which listens for kernel exception messages on a set of
2681  0 or more thread exception ports.  As threads are created, they're
2682  added to that port set; a thread's exception port is destroyed
2683  (and therefore removed from the port set) when the thread exits.
2684
2685  A few exceptions can be handled directly in the handler thread;
2686  others require that we resume the user thread (and that the
2687  exception thread resumes listening for exceptions.)  The user
2688  thread might eventually want to return to the original context
2689  (possibly modified somewhat.)
2690
2691  As it turns out, the simplest way to force the faulting user
2692  thread to handle its own exceptions is to do pretty much what
2693  signal() does: the exception handlng thread sets up a sigcontext
2694  on the user thread's stack and forces the user thread to resume
2695  execution as if a signal handler had been called with that
2696  context as an argument.  We can use a distinguished UUO at a
2697  distinguished address to do something like sigreturn(); that'll
2698  have the effect of resuming the user thread's execution in
2699  the (pseudo-) signal context.
2700
2701  Since:
2702    a) we have miles of code in C and in Lisp that knows how to
2703    deal with Linux sigcontexts
2704    b) Linux sigcontexts contain a little more useful information
2705    (the DAR, DSISR, etc.) than their Darwin counterparts
2706    c) we have to create a sigcontext ourselves when calling out
2707    to the user thread: we aren't really generating a signal, just
2708    leveraging existing signal-handling code.
2709
2710  we create a Linux sigcontext struct.
2711
2712  Simple ?  Hopefully from the outside it is ...
2713
2714  We want the process of passing a thread's own context to it to
2715  appear to be atomic: in particular, we don't want the GC to suspend
2716  a thread that's had an exception but has not yet had its user-level
2717  exception handler called, and we don't want the thread's exception
2718  context to be modified by a GC while the Mach handler thread is
2719  copying it around.  On Linux (and on Jaguar), we avoid this issue
2720  because (a) the kernel sets up the user-level signal handler and
2721  (b) the signal handler blocks signals (including the signal used
2722  by the GC to suspend threads) until tcr->xframe is set up.
2723
2724  The GC and the Mach server thread therefore contend for the lock
2725  "mach_exception_lock".  The Mach server thread holds the lock
2726  when copying exception information between the kernel and the
2727  user thread; the GC holds this lock during most of its execution
2728  (delaying exception processing until it can be done without
2729  GC interference.)
2730
2731*/
2732
2733#ifdef PPC64
2734#define C_REDZONE_LEN           320
2735#define C_STK_ALIGN             32
2736#else
2737#define C_REDZONE_LEN           224
2738#define C_STK_ALIGN             16
2739#endif
2740#define C_PARAMSAVE_LEN         64
2741#define C_LINKAGE_LEN           48
2742
2743#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2744
2745void
2746fatal_mach_error(char *format, ...);
2747
2748#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2749
2750
2751void
2752restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
2753{
2754  kern_return_t kret;
2755#if WORD_SIZE == 64
2756  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2757#else
2758  mcontext_t mc = UC_MCONTEXT(pseudosigcontext);
2759#endif
2760
2761  /* Set the thread's FP state from the pseudosigcontext */
2762#if WORD_SIZE == 64
2763  kret = thread_set_state(thread,
2764                          x86_FLOAT_STATE64,
2765                          (thread_state_t)&(mc->__fs),
2766                          x86_FLOAT_STATE64_COUNT);
2767#else
2768  kret = thread_set_state(thread,
2769                          x86_FLOAT_STATE32,
2770                          (thread_state_t)&(mc->__fs),
2771                          x86_FLOAT_STATE32_COUNT);
2772#endif
2773  MACH_CHECK_ERROR("setting thread FP state", kret);
2774
2775  /* The thread'll be as good as new ... */
2776#if WORD_SIZE == 64
2777  kret = thread_set_state(thread,
2778                          x86_THREAD_STATE64,
2779                          (thread_state_t)&(mc->__ss),
2780                          x86_THREAD_STATE64_COUNT);
2781#else
2782  kret = thread_set_state(thread, 
2783                          x86_THREAD_STATE32,
2784                          (thread_state_t)&(mc->__ss),
2785                          x86_THREAD_STATE32_COUNT);
2786#endif
2787  MACH_CHECK_ERROR("setting thread state", kret);
2788} 
2789
2790/* This code runs in the exception handling thread, in response
2791   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
2792   in response to a call to pseudo_sigreturn() from the specified
2793   user thread.
2794   Find that context (the user thread's R3 points to it), then
2795   use that context to set the user thread's state.  When this
2796   function's caller returns, the Mach kernel will resume the
2797   user thread.
2798*/
2799
2800kern_return_t
2801do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
2802{
2803  ExceptionInformation *xp;
2804
2805#ifdef DEBUG_MACH_EXCEPTIONS
2806  fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
2807#endif
2808  xp = tcr->pending_exception_context;
2809  if (xp) {
2810    tcr->pending_exception_context = NULL;
2811    tcr->valence = TCR_STATE_LISP;
2812    restore_mach_thread_state(thread, xp);
2813    raise_pending_interrupt(tcr);
2814  } else {
2815    Bug(NULL, "no xp here!\n");
2816  }
2817#ifdef DEBUG_MACH_EXCEPTIONS
2818  fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
2819#endif
2820  return KERN_SUCCESS;
2821} 
2822
2823ExceptionInformation *
2824create_thread_context_frame(mach_port_t thread, 
2825                            natural *new_stack_top,
2826                            siginfo_t **info_ptr,
2827                            TCR *tcr,
2828#ifdef X8664
2829                            x86_thread_state64_t *ts
2830#else
2831                            x86_thread_state32_t *ts
2832#endif
2833                            )
2834{
2835  mach_msg_type_number_t thread_state_count;
2836  ExceptionInformation *pseudosigcontext;
2837#ifdef X8664
2838  MCONTEXT_T mc;
2839#else
2840  mcontext_t mc;
2841#endif
2842  natural stackp;
2843
2844#ifdef X8664 
2845  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2846  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2847#else
2848  stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr);
2849#endif
2850  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
2851  if (info_ptr) {
2852    *info_ptr = (siginfo_t *)stackp;
2853  }
2854  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
2855  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
2856
2857  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
2858  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
2859 
2860  memmove(&(mc->__ss),ts,sizeof(*ts));
2861
2862#ifdef X8664
2863  thread_state_count = x86_FLOAT_STATE64_COUNT;
2864  thread_get_state(thread,
2865                   x86_FLOAT_STATE64,
2866                   (thread_state_t)&(mc->__fs),
2867                   &thread_state_count);
2868
2869  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
2870  thread_get_state(thread,
2871                   x86_EXCEPTION_STATE64,
2872                   (thread_state_t)&(mc->__es),
2873                   &thread_state_count);
2874#else
2875  thread_state_count = x86_FLOAT_STATE32_COUNT;
2876  thread_get_state(thread,
2877                   x86_FLOAT_STATE32,
2878                   (thread_state_t)&(mc->__fs),
2879                   &thread_state_count);
2880
2881  thread_state_count = x86_EXCEPTION_STATE32_COUNT;
2882  thread_get_state(thread,
2883                   x86_EXCEPTION_STATE32,
2884                   (thread_state_t)&(mc->__es),
2885                   &thread_state_count);
2886#endif
2887
2888
2889  UC_MCONTEXT(pseudosigcontext) = mc;
2890  if (new_stack_top) {
2891    *new_stack_top = stackp;
2892  }
2893  return pseudosigcontext;
2894}
2895
2896/*
2897  This code sets up the user thread so that it executes a "pseudo-signal
2898  handler" function when it resumes.  Create a fake ucontext struct
2899  on the thread's stack and pass it as an argument to the pseudo-signal
2900  handler.
2901
2902  Things are set up so that the handler "returns to" pseudo_sigreturn(),
2903  which will restore the thread's context.
2904
2905  If the handler invokes code that throws (or otherwise never sigreturn()'s
2906  to the context), that's fine.
2907
2908  Actually, check that: throw (and variants) may need to be careful and
2909  pop the tcr's xframe list until it's younger than any frame being
2910  entered.
2911*/
2912
2913int
2914setup_signal_frame(mach_port_t thread,
2915                   void *handler_address,
2916                   int signum,
2917                   int code,
2918                   TCR *tcr,
2919#ifdef X8664
2920                   x86_thread_state64_t *ts
2921#else
2922                   x86_thread_state32_t *ts
2923#endif
2924                   )
2925{
2926#ifdef X8664
2927  x86_thread_state64_t new_ts;
2928#else
2929  x86_thread_state32_t new_ts;
2930#endif
2931  ExceptionInformation *pseudosigcontext;
2932  int  old_valence = tcr->valence;
2933  natural stackp, *stackpp;
2934  siginfo_t *info;
2935
2936#ifdef DEBUG_MACH_EXCEPTIONS
2937  fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
2938#endif
2939  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
2940  bzero(info, sizeof(*info));
2941  info->si_code = code;
2942  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
2943  info->si_signo = signum;
2944  pseudosigcontext->uc_onstack = 0;
2945  pseudosigcontext->uc_sigmask = (sigset_t) 0;
2946  pseudosigcontext->uc_stack.ss_sp = 0;
2947  pseudosigcontext->uc_stack.ss_size = 0;
2948  pseudosigcontext->uc_stack.ss_flags = 0;
2949  pseudosigcontext->uc_link = NULL;
2950  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
2951  tcr->pending_exception_context = pseudosigcontext;
2952  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
2953 
2954
2955  /*
2956     It seems like we've created a  sigcontext on the thread's
2957     stack.  Set things up so that we call the handler (with appropriate
2958     args) when the thread's resumed.
2959  */
2960
2961#ifdef X8664
2962  new_ts.__rip = (natural) handler_address;
2963  stackpp = (natural *)stackp;
2964  *--stackpp = (natural)pseudo_sigreturn;
2965  stackp = (natural)stackpp;
2966  new_ts.__rdi = signum;
2967  new_ts.__rsi = (natural)info;
2968  new_ts.__rdx = (natural)pseudosigcontext;
2969  new_ts.__rcx = (natural)tcr;
2970  new_ts.__r8 = (natural)old_valence;
2971  new_ts.__rsp = stackp;
2972  new_ts.__rflags = ts->__rflags;
2973#else
2974#define USER_CS 0x17
2975#define USER_DS 0x1f
2976  bzero(&new_ts, sizeof(new_ts));
2977  new_ts.__cs = ts->__cs;
2978  new_ts.__ss = ts->__ss;
2979  new_ts.__ds = ts->__ds;
2980  new_ts.__es = ts->__es;
2981  new_ts.__fs = ts->__fs;
2982  new_ts.__gs = ts->__gs;
2983
2984  new_ts.__eip = (natural)handler_address;
2985  stackpp = (natural *)stackp;
2986  *--stackpp = 0;               /* alignment */
2987  *--stackpp = 0;
2988  *--stackpp = 0;
2989  *--stackpp = (natural)old_valence;
2990  *--stackpp = (natural)tcr;
2991  *--stackpp = (natural)pseudosigcontext;
2992  *--stackpp = (natural)info;
2993  *--stackpp = (natural)signum;
2994  *--stackpp = (natural)pseudo_sigreturn;
2995  stackp = (natural)stackpp;
2996  new_ts.__esp = stackp;
2997  new_ts.__eflags = ts->__eflags;
2998#endif
2999
3000#ifdef X8664
3001  thread_set_state(thread,
3002                   x86_THREAD_STATE64,
3003                   (thread_state_t)&new_ts,
3004                   x86_THREAD_STATE64_COUNT);
3005#else
3006  thread_set_state(thread, 
3007                   x86_THREAD_STATE32,
3008                   (thread_state_t)&new_ts,
3009                   x86_THREAD_STATE32_COUNT);
3010#endif
3011#ifdef DEBUG_MACH_EXCEPTIONS
3012  fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
3013#endif
3014  return 0;
3015}
3016
3017
3018
3019
3020
3021
3022/*
3023  This function runs in the exception handling thread.  It's
3024  called (by this precise name) from the library function "exc_server()"
3025  when the thread's exception ports are set up.  (exc_server() is called
3026  via mach_msg_server(), which is a function that waits for and dispatches
3027  on exception messages from the Mach kernel.)
3028
3029  This checks to see if the exception was caused by a pseudo_sigreturn()
3030  UUO; if so, it arranges for the thread to have its state restored
3031  from the specified context.
3032
3033  Otherwise, it tries to map the exception to a signal number and
3034  arranges that the thread run a "pseudo signal handler" to handle
3035  the exception.
3036
3037  Some exceptions could and should be handled here directly.
3038*/
3039
3040/* We need the thread's state earlier on x86_64 than we did on PPC;
3041   the PC won't fit in code_vector[1].  We shouldn't try to get it
3042   lazily (via catch_exception_raise_state()); until we own the
3043   exception lock, we shouldn't have it in userspace (since a GCing
3044   thread wouldn't know that we had our hands on it.)
3045*/
3046
3047#ifdef X8664
3048#define ts_pc(t) t.__rip
3049#else
3050#define ts_pc(t) t.__eip
3051#endif
3052
3053#ifdef DARWIN_USE_PSEUDO_SIGRETURN
3054#define DARWIN_EXCEPTION_HANDLER signal_handler
3055#else
3056#define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler
3057#endif
3058
3059
3060kern_return_t
3061catch_exception_raise(mach_port_t exception_port,
3062                      mach_port_t thread,
3063                      mach_port_t task, 
3064                      exception_type_t exception,
3065                      exception_data_t code_vector,
3066                      mach_msg_type_number_t code_count)
3067{
3068  int signum = 0, code = *code_vector;
3069  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
3070  kern_return_t kret, call_kret;
3071#ifdef X8664
3072  x86_thread_state64_t ts;
3073#else
3074  x86_thread_state32_t ts;
3075#endif
3076  mach_msg_type_number_t thread_state_count;
3077
3078
3079
3080#ifdef DEBUG_MACH_EXCEPTIONS
3081  fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
3082#endif
3083
3084
3085  if (1) {
3086#ifdef X8664
3087    do {
3088      thread_state_count = x86_THREAD_STATE64_COUNT;
3089      call_kret = thread_get_state(thread,
3090                                   x86_THREAD_STATE64,
3091                                   (thread_state_t)&ts,
3092                                   &thread_state_count);
3093    } while (call_kret == KERN_ABORTED);
3094  MACH_CHECK_ERROR("getting thread state",call_kret);
3095#else
3096    thread_state_count = x86_THREAD_STATE32_COUNT;
3097    call_kret = thread_get_state(thread,
3098                                 x86_THREAD_STATE32,
3099                                 (thread_state_t)&ts,
3100                                 &thread_state_count);
3101    MACH_CHECK_ERROR("getting thread state",call_kret);
3102#endif
3103    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
3104      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
3105    } 
3106    if ((code == EXC_I386_GPFLT) &&
3107        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
3108      kret = do_pseudo_sigreturn(thread, tcr);
3109#if 0
3110      fprintf(stderr, "Exception return in 0x%x\n",tcr);
3111#endif
3112    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
3113      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
3114      kret = 17;
3115    } else {
3116      switch (exception) {
3117      case EXC_BAD_ACCESS:
3118        if (code == EXC_I386_GPFLT) {
3119          signum = SIGSEGV;
3120        } else {
3121          signum = SIGBUS;
3122        }
3123        break;
3124       
3125      case EXC_BAD_INSTRUCTION:
3126        if (code == EXC_I386_GPFLT) {
3127          signum = SIGSEGV;
3128        } else {
3129          signum = SIGILL;
3130        }
3131        break;
3132         
3133      case EXC_SOFTWARE:
3134        signum = SIGILL;
3135        break;
3136       
3137      case EXC_ARITHMETIC:
3138        signum = SIGFPE;
3139        break;
3140       
3141      default:
3142        break;
3143      }
3144      if (signum) {
3145        kret = setup_signal_frame(thread,
3146                                  (void *)DARWIN_EXCEPTION_HANDLER,
3147                                  signum,
3148                                  code,
3149                                  tcr, 
3150                                  &ts);
3151#if 0
3152        fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
3153#endif
3154       
3155      } else {
3156        kret = 17;
3157      }
3158    }
3159  }
3160  return kret;
3161}
3162
3163
3164
3165
3166static mach_port_t mach_exception_thread = (mach_port_t)0;
3167
3168
3169/*
3170  The initial function for an exception-handling thread.
3171*/
3172
3173void *
3174exception_handler_proc(void *arg)
3175{
3176  extern boolean_t exc_server();
3177  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
3178
3179  mach_exception_thread = pthread_mach_thread_np(pthread_self());
3180  mach_msg_server(exc_server, 256, p, 0);
3181  /* Should never return. */
3182  abort();
3183}
3184
3185
3186
3187void
3188mach_exception_thread_shutdown()
3189{
3190  kern_return_t kret;
3191
3192  fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
3193  kret = thread_terminate(mach_exception_thread);
3194  if (kret != KERN_SUCCESS) {
3195    fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
3196  }
3197}
3198
3199
3200mach_port_t
3201mach_exception_port_set()
3202{
3203  static mach_port_t __exception_port_set = MACH_PORT_NULL;
3204  kern_return_t kret; 
3205  if (__exception_port_set == MACH_PORT_NULL) {
3206
3207    kret = mach_port_allocate(mach_task_self(),
3208                              MACH_PORT_RIGHT_PORT_SET,
3209                              &__exception_port_set);
3210    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
3211    create_system_thread(0,
3212                         NULL,
3213                         exception_handler_proc, 
3214                         (void *)((natural)__exception_port_set));
3215  }
3216  return __exception_port_set;
3217}
3218
3219/*
3220  Setup a new thread to handle those exceptions specified by
3221  the mask "which".  This involves creating a special Mach
3222  message port, telling the Mach kernel to send exception
3223  messages for the calling thread to that port, and setting
3224  up a handler thread which listens for and responds to
3225  those messages.
3226
3227*/
3228
3229/*
3230  Establish the lisp thread's TCR as its exception port, and determine
3231  whether any other ports have been established by foreign code for
3232  exceptions that lisp cares about.
3233
3234  If this happens at all, it should happen on return from foreign
3235  code and on entry to lisp code via a callback.
3236
3237  This is a lot of trouble (and overhead) to support Java, or other
3238  embeddable systems that clobber their caller's thread exception ports.
3239 
3240*/
3241kern_return_t
3242tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
3243{
3244  kern_return_t kret;
3245  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
3246  int i;
3247  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
3248  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
3249  exception_mask_t mask = 0;
3250
3251  kret = thread_swap_exception_ports(thread,
3252                                     LISP_EXCEPTIONS_HANDLED_MASK,
3253                                     lisp_port,
3254                                     EXCEPTION_DEFAULT,
3255                                     THREAD_STATE_NONE,
3256                                     fxs->masks,
3257                                     &n,
3258                                     fxs->ports,
3259                                     fxs->behaviors,
3260                                     fxs->flavors);
3261  if (kret == KERN_SUCCESS) {
3262    fxs->foreign_exception_port_count = n;
3263    for (i = 0; i < n; i ++) {
3264      foreign_port = fxs->ports[i];
3265
3266      if ((foreign_port != lisp_port) &&
3267          (foreign_port != MACH_PORT_NULL)) {
3268        mask |= fxs->masks[i];
3269      }
3270    }
3271    tcr->foreign_exception_status = (int) mask;
3272  }
3273  return kret;
3274}
3275
3276kern_return_t
3277tcr_establish_lisp_exception_port(TCR *tcr)
3278{
3279  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
3280}
3281
3282/*
3283  Do this when calling out to or returning from foreign code, if
3284  any conflicting foreign exception ports were established when we
3285  last entered lisp code.
3286*/
3287kern_return_t
3288restore_foreign_exception_ports(TCR *tcr)
3289{
3290  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
3291 
3292  if (m) {
3293    MACH_foreign_exception_state *fxs  = 
3294      (MACH_foreign_exception_state *) tcr->native_thread_info;
3295    int i, n = fxs->foreign_exception_port_count;
3296    exception_mask_t tm;
3297
3298    for (i = 0; i < n; i++) {
3299      if ((tm = fxs->masks[i]) & m) {
3300        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
3301                                   tm,
3302                                   fxs->ports[i],
3303                                   fxs->behaviors[i],
3304                                   fxs->flavors[i]);
3305      }
3306    }
3307  }
3308}
3309                                   
3310
3311/*
3312  This assumes that a Mach port (to be used as the thread's exception port) whose
3313  "name" matches the TCR's 32-bit address has already been allocated.
3314*/
3315
3316kern_return_t
3317setup_mach_exception_handling(TCR *tcr)
3318{
3319  mach_port_t
3320    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
3321    task_self = mach_task_self();
3322  kern_return_t kret;
3323
3324  kret = mach_port_insert_right(task_self,
3325                                thread_exception_port,
3326                                thread_exception_port,
3327                                MACH_MSG_TYPE_MAKE_SEND);
3328  MACH_CHECK_ERROR("adding send right to exception_port",kret);
3329
3330  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
3331  if (kret == KERN_SUCCESS) {
3332    mach_port_t exception_port_set = mach_exception_port_set();
3333
3334    kret = mach_port_move_member(task_self,
3335                                 thread_exception_port,
3336                                 exception_port_set);
3337  }
3338  return kret;
3339}
3340
3341void
3342darwin_exception_init(TCR *tcr)
3343{
3344  void tcr_monitor_exception_handling(TCR*, Boolean);
3345  kern_return_t kret;
3346  MACH_foreign_exception_state *fxs = 
3347    calloc(1, sizeof(MACH_foreign_exception_state));
3348 
3349  tcr->native_thread_info = (void *) fxs;
3350
3351  if ((kret = setup_mach_exception_handling(tcr))
3352      != KERN_SUCCESS) {
3353    fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
3354    terminate_lisp();
3355  }
3356  lisp_global(LISP_EXIT_HOOK) = (LispObj) restore_foreign_exception_ports;
3357  lisp_global(LISP_RETURN_HOOK) = (LispObj) tcr_establish_lisp_exception_port;
3358}
3359
3360/*
3361  The tcr is the "name" of the corresponding thread's exception port.
3362  Destroying the port should remove it from all port sets of which it's
3363  a member (notably, the exception port set.)
3364*/
3365void
3366darwin_exception_cleanup(TCR *tcr)
3367{
3368  void *fxs = tcr->native_thread_info;
3369  extern Boolean use_mach_exception_handling;
3370
3371  if (fxs) {
3372    tcr->native_thread_info = NULL;
3373    free(fxs);
3374  }
3375  if (use_mach_exception_handling) {
3376    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3377    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3378  }
3379}
3380
3381
3382Boolean
3383suspend_mach_thread(mach_port_t mach_thread)
3384{
3385  kern_return_t status;
3386  Boolean aborted = false;
3387 
3388  do {
3389    aborted = false;
3390    status = thread_suspend(mach_thread);
3391    if (status == KERN_SUCCESS) {
3392      status = thread_abort_safely(mach_thread);
3393      if (status == KERN_SUCCESS) {
3394        aborted = true;
3395      } else {
3396        fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
3397        thread_resume(mach_thread);
3398      }
3399    } else {
3400      return false;
3401    }
3402  } while (! aborted);
3403  return true;
3404}
3405
3406/*
3407  Only do this if pthread_kill indicated that the pthread isn't
3408  listening to signals anymore, as can happen as soon as pthread_exit()
3409  is called on Darwin.  The thread could still call out to lisp as it
3410  is exiting, so we need another way to suspend it in this case.
3411*/
3412Boolean
3413mach_suspend_tcr(TCR *tcr)
3414{
3415  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
3416  ExceptionInformation *pseudosigcontext;
3417  Boolean result = false;
3418 
3419  result = suspend_mach_thread(mach_thread);
3420  if (result) {
3421    mach_msg_type_number_t thread_state_count;
3422#ifdef X8664
3423    x86_thread_state64_t ts;
3424    thread_state_count = x86_THREAD_STATE64_COUNT;
3425    thread_get_state(mach_thread,
3426                     x86_THREAD_STATE64,
3427                     (thread_state_t)&ts,
3428                     &thread_state_count);
3429#else
3430    x86_thread_state32_t ts;
3431    thread_state_count = x86_THREAD_STATE_COUNT;
3432    thread_get_state(mach_thread,
3433                     x86_THREAD_STATE,
3434                     (thread_state_t)&ts,
3435                     &thread_state_count);
3436#endif
3437
3438    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
3439    pseudosigcontext->uc_onstack = 0;
3440    pseudosigcontext->uc_sigmask = (sigset_t) 0;
3441    tcr->suspend_context = pseudosigcontext;
3442  }
3443  return result;
3444}
3445
3446void
3447mach_resume_tcr(TCR *tcr)
3448{
3449  ExceptionInformation *xp;
3450  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
3451 
3452  xp = tcr->suspend_context;
3453#ifdef DEBUG_MACH_EXCEPTIONS
3454  fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
3455          tcr, tcr->pending_exception_context);
3456#endif
3457  tcr->suspend_context = NULL;
3458  restore_mach_thread_state(mach_thread, xp);
3459#ifdef DEBUG_MACH_EXCEPTIONS
3460  fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
3461          tcr, tcr->pending_exception_context);
3462#endif
3463  thread_resume(mach_thread);
3464}
3465
3466void
3467fatal_mach_error(char *format, ...)
3468{
3469  va_list args;
3470  char s[512];
3471 
3472
3473  va_start(args, format);
3474  vsnprintf(s, sizeof(s),format, args);
3475  va_end(args);
3476
3477  Fatal("Mach error", s);
3478}
3479
3480
3481
3482
3483#endif
Note: See TracBrowser for help on using the repository browser.