source: branches/rme-fpe/lisp-kernel/x86-exceptions.c @ 13940

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

Only avoid saving/restoring the MXCSR around FF calls on x8664,
at least for now.

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