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

Last change on this file since 12198 was 12198, checked in by gz, 10 years ago

Merge with trunk kernel (and a few compiler changes to match): a few bug fixes, a lot of changes for other platforms.

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