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

Last change on this file since 13882 was 13882, checked in by gb, 9 years ago

When setting GC nofitication threshold, reset our notion of whether or
not we've done a GC notification since the last full GC.

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