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

Last change on this file since 15164 was 15164, checked in by rme, 8 years ago

On Windows, treat typing Control-Break in a console window
as a user-generated quit signal.

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