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

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

Gak. Explicitly return true after handling XUUO_KILL case in
handle_exception(), rather than getting lost and (apparently) returning
a random value. (On Solaris, the random value often looks enough
like 'false' to make it appear that the exception isn't handled; this
rarely seemed to happen on other platforms.)

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