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

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

New functions in x86-utils.[ch], moved, more-or-less,
from xlbt.c.

Use them in x86-exceptions.c, in particular in
create_exception_callback_frame().

Move the definitions of the RECOVER_FN_xxx constants
from x86-exceptions.h to the appropriate x86-constants{32,64}.h
files.

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