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

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

In handle_gc_trap(): when we're going to call save_application, wrap a
file descriptor around 'arg' (which is a native Windows file handle.)

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