source: branches/working-0711/ccl/lisp-kernel/x86-exceptions.c @ 11507

Last change on this file since 11507 was 11507, checked in by gz, 12 years ago

SIGQUIT fix (from r11499/r11500)

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