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

Last change on this file since 14347 was 14295, checked in by rme, 9 years ago

Eliminate some (but not all) warnings produced when building with
"-Wall -Wno-format". Also a couple of minor changes that enable
clang to build the lisp kernel (at least on x8632 and x8664).

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