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

Last change on this file since 13002 was 13002, checked in by rme, 11 years ago

In handle_fault(), pass the watched object on the lisp stack
underneath the xcf rather than as an (integer) callback parameter.
Compute and pass an offset to the written address (reckoned from the
tagged object pointer).

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