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

Last change on this file since 11803 was 11803, checked in by rme, 10 years ago

callback_to_lisp(): on x8632, preserve tcr.unboxed0 and tcr.unboxed1.

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