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

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

Split the business of emptying a TCR's stacks out from quit_handler(),
so it can be called from Windows should the need arise.

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