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

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

In create_exception_callback_frame(), try to figure out if a tra
on the top of the stack looks reasonable before dereferencing it.
Bug if it looks suspect.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 101.1 KB
Line 
1/*
2   Copyright (C) 2005-2009 Clozure Associates
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp-exceptions.h"
19#include "lisp_globals.h"
20#include "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  default:
1851    return FALSE;
1852  }
1853}
1854
1855static
1856DWORD mxcsr_bit_to_fpe_code[] = {
1857  EXCEPTION_FLT_INVALID_OPERATION, /* ie */
1858  0,                            /* de */
1859  EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */
1860  EXCEPTION_FLT_OVERFLOW,       /* oe */
1861  EXCEPTION_FLT_UNDERFLOW,      /* ue */
1862  EXCEPTION_FLT_INEXACT_RESULT  /* pe */
1863};
1864
1865#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
1866#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4
1867#endif
1868
1869#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
1870#define  STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5
1871#endif
1872
1873int
1874map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context)
1875{
1876  switch (code) {
1877#ifdef WIN_32
1878  case STATUS_FLOAT_MULTIPLE_FAULTS:
1879  case STATUS_FLOAT_MULTIPLE_TRAPS:
1880    {
1881      int xbit, maskbit;
1882      DWORD mxcsr = *(xpMXCSRptr(context));
1883
1884      for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
1885        if ((mxcsr & (1 << xbit)) &&
1886            !(mxcsr & (1 << maskbit))) {
1887          info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit];
1888          break;
1889        }
1890      }
1891    }
1892    return SIGFPE;
1893#endif
1894     
1895  case EXCEPTION_ACCESS_VIOLATION:
1896    return SIGSEGV;
1897  case EXCEPTION_FLT_DENORMAL_OPERAND:
1898  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
1899  case EXCEPTION_FLT_INEXACT_RESULT:
1900  case EXCEPTION_FLT_INVALID_OPERATION:
1901  case EXCEPTION_FLT_OVERFLOW:
1902  case EXCEPTION_FLT_STACK_CHECK:
1903  case EXCEPTION_FLT_UNDERFLOW:
1904  case EXCEPTION_INT_DIVIDE_BY_ZERO:
1905  case EXCEPTION_INT_OVERFLOW:
1906    return SIGFPE;
1907  case EXCEPTION_PRIV_INSTRUCTION:
1908  case EXCEPTION_ILLEGAL_INSTRUCTION:
1909    return SIGILL;
1910  case EXCEPTION_IN_PAGE_ERROR:
1911  case STATUS_GUARD_PAGE_VIOLATION:
1912    return SIGBUS;
1913  default:
1914    return -1;
1915  }
1916}
1917
1918
1919LONG
1920windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr)
1921{
1922  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
1923  int old_valence, signal_number;
1924  ExceptionInformation *context = exception_pointers->ContextRecord;
1925  siginfo_t *info = exception_pointers->ExceptionRecord;
1926  xframe_list xframes;
1927
1928  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1929  wait_for_exception_lock_in_handler(tcr, context, &xframes);
1930
1931  signal_number = map_windows_exception_code_to_posix_signal(code, info, context);
1932 
1933  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
1934    char msg[512];
1935    Boolean foreign = (old_valence != TCR_STATE_LISP);
1936
1937    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));
1938   
1939    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
1940      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1941    }
1942  }
1943  unlock_exception_lock_in_handler(tcr);
1944  return restore_windows_context(context, tcr, old_valence);
1945}
1946
1947void
1948setup_exception_handler_call(CONTEXT *context,
1949                             LispObj new_sp,
1950                             void *handler,
1951                             EXCEPTION_POINTERS *new_ep,
1952                             TCR *tcr)
1953{
1954  extern void windows_halt(void);
1955  LispObj *p = (LispObj *)new_sp;
1956#ifdef WIN_64
1957  p-=4;                         /* win64 abi argsave nonsense */
1958  *(--p) = (LispObj)windows_halt;
1959  context->Rsp = (DWORD64)p;
1960  context->Rip = (DWORD64)handler;
1961  context->Rcx = (DWORD64)new_ep;
1962  context->Rdx = (DWORD64)tcr;
1963#else
1964  p-=4;                          /* args on stack, stack aligned */
1965  p[0] = (LispObj)new_ep;
1966  p[1] = (LispObj)tcr;
1967  *(--p) = (LispObj)windows_halt;
1968  context->Esp = (DWORD)p;
1969  context->Eip = (DWORD)handler;
1970#endif
1971  context->EFlags &= ~0x400;  /* clear direction flag */
1972}
1973
1974void
1975prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr,
1976                                                     CONTEXT *context,
1977                                                     void *handler,
1978                                                     EXCEPTION_POINTERS *original_ep)
1979{
1980  LispObj foreign_rsp = 
1981    (LispObj) (tcr->foreign_sp - 128) & ~15;
1982  CONTEXT *new_context;
1983  siginfo_t *new_info;
1984  EXCEPTION_POINTERS *new_ep;
1985
1986  new_context = ((CONTEXT *)(foreign_rsp&~15))-1;
1987  *new_context = *context;
1988  foreign_rsp = (LispObj)new_context;
1989  new_info = ((siginfo_t *)(foreign_rsp&~15))-1;
1990  *new_info = *original_ep->ExceptionRecord;
1991  foreign_rsp = (LispObj)new_info;
1992  new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1;
1993  foreign_rsp = (LispObj)new_ep & ~15;
1994  new_ep->ContextRecord = new_context;
1995  new_ep->ExceptionRecord = new_info;
1996  setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr);
1997}
1998
1999LONG CALLBACK
2000windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers)
2001{
2002  extern void ensure_safe_for_string_operations(void);
2003  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
2004
2005
2006 
2007  if ((code & 0x80000000L) == 0) {
2008    return EXCEPTION_CONTINUE_SEARCH;
2009  } else {
2010    TCR *tcr = get_interrupt_tcr(false);
2011    area *cs = TCR_AUX(tcr)->cs_area;
2012    BytePtr current_sp = (BytePtr) current_stack_pointer();
2013    CONTEXT *context = exception_pointers->ContextRecord;
2014   
2015    ensure_safe_for_string_operations();
2016
2017    if ((current_sp >= cs->low) &&
2018        (current_sp < cs->high)) {
2019      debug_show_registers(context, exception_pointers->ExceptionRecord, 0);
2020      FBug(context, "Exception on foreign stack\n");
2021      return EXCEPTION_CONTINUE_EXECUTION;
2022    }
2023
2024    prepare_to_handle_windows_exception_on_foreign_stack(tcr,
2025                                                         context,
2026                                                         windows_exception_handler,
2027                                                         exception_pointers);
2028    return EXCEPTION_CONTINUE_EXECUTION;
2029  }
2030}
2031
2032
2033void
2034install_pmcl_exception_handlers()
2035{
2036  AddVectoredExceptionHandler(1,windows_arbstack_exception_handler);
2037}
2038#else
2039void
2040install_pmcl_exception_handlers()
2041{
2042  void *handler, *interrupt_handler;
2043
2044#ifdef USE_SIGALTSTACK
2045  handler = (void *)altstack_signal_handler;
2046  interrupt_handler = (void *)altstack_interrupt_handler;
2047#else
2048  handler = (void *)arbstack_signal_handler;
2049  interrupt_handler = (void *)arbstack_interrupt_handler;
2050#endif
2051
2052#ifndef DARWIN
2053  install_signal_handler(SIGILL, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2054  install_signal_handler(SIGBUS, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2055  install_signal_handler(SIGSEGV, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2056  install_signal_handler(SIGFPE, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2057#endif
2058 
2059  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, interrupt_handler,
2060                         RESERVE_FOR_LISP|ON_ALTSTACK);
2061  signal(SIGPIPE, SIG_IGN);
2062}
2063#endif
2064
2065#ifndef WINDOWS
2066#ifndef USE_SIGALTSTACK
2067void
2068arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
2069{
2070  TCR *tcr = get_interrupt_tcr(false);
2071  if (tcr != NULL) {
2072    area *vs = tcr->vs_area;
2073    BytePtr current_sp = (BytePtr) current_stack_pointer();
2074   
2075    if ((current_sp >= vs->low) &&
2076        (current_sp < vs->high)) {
2077      return
2078        handle_signal_on_foreign_stack(tcr,
2079                                       suspend_resume_handler,
2080                                       signum,
2081                                       info,
2082                                       context,
2083                                       (LispObj)__builtin_return_address(0)
2084                                       );
2085    } else {
2086      /* If we're not on the value stack, we pretty much have to be on
2087         the C stack.  Just run the handler. */
2088    }
2089  }
2090  suspend_resume_handler(signum, info, context);
2091}
2092
2093
2094#else /* altstack works */
2095void
2096altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
2097{
2098  TCR* tcr = get_tcr(true);
2099  handle_signal_on_foreign_stack(tcr,
2100                                 suspend_resume_handler,
2101                                 signum,
2102                                 info,
2103                                 context,
2104                                 (LispObj)__builtin_return_address(0)
2105                                 );
2106}
2107#endif
2108#endif
2109
2110
2111/* This should only be called when the tcr_area_lock is held */
2112void
2113empty_tcr_stacks(TCR *tcr)
2114{
2115  if (tcr) {
2116    area *a;
2117
2118    tcr->valence = TCR_STATE_FOREIGN;
2119    a = tcr->vs_area;
2120    if (a) {
2121      a->active = a->high;
2122    }
2123    a = tcr->ts_area;
2124    if (a) {
2125      a->active = a->high;
2126    }
2127    a = TCR_AUX(tcr)->cs_area;
2128    if (a) {
2129      a->active = a->high;
2130    }
2131  }
2132}
2133
2134#ifdef WINDOWS
2135void
2136thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2137{
2138}
2139#else
2140void
2141thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2142{
2143  TCR *tcr = get_tcr(false);
2144  sigset_t mask;
2145
2146  sigemptyset(&mask);
2147
2148  empty_tcr_stacks(tcr);
2149
2150  pthread_sigmask(SIG_SETMASK,&mask,NULL);
2151  pthread_exit(NULL);
2152}
2153#endif
2154
2155#ifndef WINDOWS
2156#ifndef USE_SIGALTSTACK
2157void
2158arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2159{
2160  TCR *tcr = get_interrupt_tcr(false);
2161  area *vs = tcr->vs_area;
2162  BytePtr current_sp = (BytePtr) current_stack_pointer();
2163
2164  if ((current_sp >= vs->low) &&
2165      (current_sp < vs->high)) {
2166    handle_signal_on_foreign_stack(tcr,
2167                                   thread_kill_handler,
2168                                   signum,
2169                                   info,
2170                                   context,
2171                                   (LispObj)__builtin_return_address(0)
2172                                   );
2173  } else {
2174    /* If we're not on the value stack, we pretty much have to be on
2175       the C stack.  Just run the handler. */
2176    thread_kill_handler(signum, info, context);
2177  }
2178}
2179
2180
2181#else
2182void
2183altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2184{
2185  TCR* tcr = get_tcr(true);
2186  handle_signal_on_foreign_stack(tcr,
2187                                 thread_kill_handler,
2188                                 signum,
2189                                 info,
2190                                 context,
2191                                 (LispObj)__builtin_return_address(0)
2192                                 );
2193}
2194#endif
2195#endif
2196
2197#ifdef USE_SIGALTSTACK
2198#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler
2199#define THREAD_KILL_HANDLER altstack_thread_kill_handler
2200#else
2201#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler
2202#define THREAD_KILL_HANDLER arbstack_thread_kill_handler
2203#endif
2204
2205#ifdef WINDOWS
2206void
2207thread_signal_setup()
2208{
2209}
2210#else
2211void
2212thread_signal_setup()
2213{
2214  thread_suspend_signal = SIG_SUSPEND_THREAD;
2215  thread_kill_signal = SIG_KILL_THREAD;
2216
2217  install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER,
2218                         RESERVE_FOR_LISP|ON_ALTSTACK|RESTART_SYSCALLS);
2219  install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER,
2220                         RESERVE_FOR_LISP|ON_ALTSTACK);
2221}
2222#endif
2223
2224void
2225enable_fp_exceptions()
2226{
2227}
2228
2229void
2230exception_init()
2231{
2232  install_pmcl_exception_handlers();
2233}
2234
2235void
2236adjust_exception_pc(ExceptionInformation *xp, int delta)
2237{
2238  xpPC(xp) += delta;
2239}
2240
2241/*
2242  Lower (move toward 0) the "end" of the soft protected area associated
2243  with a by a page, if we can.
2244*/
2245
2246void
2247
2248adjust_soft_protection_limit(area *a)
2249{
2250  char *proposed_new_soft_limit = a->softlimit - 4096;
2251  protected_area_ptr p = a->softprot;
2252 
2253  if (proposed_new_soft_limit >= (p->start+16384)) {
2254    p->end = proposed_new_soft_limit;
2255    p->protsize = p->end-p->start;
2256    a->softlimit = proposed_new_soft_limit;
2257  }
2258  protect_area(p);
2259}
2260
2261void
2262restore_soft_stack_limit(unsigned restore_tsp)
2263{
2264  TCR *tcr = get_tcr(false);
2265  area *a;
2266 
2267  if (restore_tsp) {
2268    a = tcr->ts_area;
2269  } else {
2270    a = tcr->vs_area;
2271  }
2272  adjust_soft_protection_limit(a);
2273}
2274
2275
2276#ifdef USE_SIGALTSTACK
2277void
2278setup_sigaltstack(area *a)
2279{
2280  stack_t stack;
2281  stack.ss_sp = a->low;
2282  a->low += SIGSTKSZ*8;
2283  stack.ss_size = SIGSTKSZ*8;
2284  stack.ss_flags = 0;
2285  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
2286#ifdef LINUX
2287  /* The ucontext pushed on the altstack may not contain the (largish)
2288     __fpregs_mem field; copy_ucontext() wants to copy what it thinks
2289     is a pointer to a full ucontext.  That'll touch a page beyond the
2290     bottom of the altstack, and when this happens on the initial
2291     thread's stack on a recent (2.6.32+?) kernel, we'll SIGBUS instead
2292     of mapping that page.
2293     It's easier to just reserve that page here than it would be to
2294     change copy_ucontext().
2295  */
2296  stack.ss_size -= sizeof(struct ucontext);
2297#endif
2298  if (sigaltstack(&stack, NULL) != 0) {
2299    perror("sigaltstack");
2300    exit(-1);
2301  }
2302}
2303#endif
2304
2305extern opcode egc_write_barrier_start, egc_write_barrier_end,
2306  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2307  egc_set_hash_key_conditional_retry,
2308  egc_store_node_conditional_success_end, egc_store_node_conditional_retry,
2309  egc_store_node_conditional_success_test,egc_store_node_conditional,
2310  egc_set_hash_key, egc_gvset, egc_rplacd;
2311
2312/* We use (extremely) rigidly defined instruction sequences for consing,
2313   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2314   while consing.
2315
2316   Note that we can usually identify which of these instructions is about
2317   to be executed by a stopped thread without comparing all of the bytes
2318   to those at the stopped program counter, but we generally need to
2319   know the sizes of each of these instructions.
2320*/
2321
2322#ifdef X8664
2323opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2324#ifdef TCR_IN_GPR
2325  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2326#else
2327  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2328#endif
2329;
2330opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2331#ifdef TCR_IN_GPR
2332  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2333#else
2334  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2335#endif
2336
2337;
2338opcode branch_around_alloc_trap_instruction[] =
2339  {0x77,0x02};
2340opcode alloc_trap_instruction[] =
2341  {0xcd,0xc5};
2342opcode clear_tcr_save_allocptr_tag_instruction[] =
2343#ifdef TCR_IN_GPR
2344  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2345#else
2346  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2347#endif
2348;
2349opcode set_allocptr_header_instruction[] =
2350  {0x48,0x89,0x43,0xf3};
2351
2352
2353alloc_instruction_id
2354recognize_alloc_instruction(pc program_counter)
2355{
2356  switch(program_counter[0]) {
2357  case 0xcd: return ID_alloc_trap_instruction;
2358  /* 0x7f is jg, which we used to use here instead of ja */
2359  case 0x7f:
2360  case 0x77: return ID_branch_around_alloc_trap_instruction;
2361  case 0x48: return ID_set_allocptr_header_instruction;
2362#ifdef TCR_IN_GPR
2363  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2364  case 0x49:
2365    switch(program_counter[1]) {
2366    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2367    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2368    }
2369#else
2370  case 0x65: 
2371    switch(program_counter[1]) {
2372    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2373    case 0x48:
2374      switch(program_counter[2]) {
2375      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2376      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2377      }
2378    }
2379#endif
2380  default: break;
2381  }
2382  return ID_unrecognized_alloc_instruction;
2383}
2384#endif
2385#ifdef X8632
2386#define TCR_SEG_PREFIX 0x64
2387
2388#ifdef WIN_32
2389#define SAVE_ALLOCPTR 0x9c,0x0e,0x0,0x0
2390#define SAVE_ALLOCBASE 0x98,0x0e,0x0,0x0
2391#else
2392#define SAVE_ALLOCPTR 0x84,0x0,0x0,0x0
2393#define SAVE_ALLOCBASE 0x88,0x0,0x0,0x0
2394#endif
2395
2396opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2397  {TCR_SEG_PREFIX,0x8b,0x0d,SAVE_ALLOCPTR};
2398opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2399  {TCR_SEG_PREFIX,0x3b,0x0d,SAVE_ALLOCBASE};
2400opcode branch_around_alloc_trap_instruction[] =
2401  {0x77,0x02};
2402opcode alloc_trap_instruction[] =
2403  {0xcd,0xc5};
2404opcode clear_tcr_save_allocptr_tag_instruction[] =
2405  {TCR_SEG_PREFIX,0x80,0x25,SAVE_ALLOCPTR,0xf8};
2406opcode set_allocptr_header_instruction[] =
2407  {0x0f,0x7e,0x41,0xfa};
2408
2409alloc_instruction_id
2410recognize_alloc_instruction(pc program_counter)
2411{
2412  switch(program_counter[0]) {
2413  case 0xcd: return ID_alloc_trap_instruction;
2414  case 0x77: return ID_branch_around_alloc_trap_instruction;
2415  case 0x0f: return ID_set_allocptr_header_instruction;
2416  case 0x64: 
2417    switch(program_counter[1]) {
2418    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2419    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2420    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2421    }
2422  }
2423  return ID_unrecognized_alloc_instruction;
2424}
2425#endif     
2426
2427void
2428pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2429{
2430  pc program_counter = (pc)xpPC(xp);
2431  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2432
2433  if (allocptr_tag != 0) {
2434    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2435    signed_natural
2436      disp = (allocptr_tag == fulltag_cons) ?
2437      sizeof(cons) - fulltag_cons :
2438#ifdef X8664
2439      xpGPR(xp,Iimm1)
2440#else
2441      xpGPR(xp,Iimm0)
2442#endif
2443      ;
2444    LispObj new_vector;
2445
2446    if ((state == ID_unrecognized_alloc_instruction) ||
2447        ((state == ID_set_allocptr_header_instruction) &&
2448         (allocptr_tag != fulltag_misc))) {
2449      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2450    }
2451    switch(state) {
2452    case ID_set_allocptr_header_instruction:
2453      /* We were consing a vector and we won.  Set the header of the
2454         new vector (in the allocptr register) to the header in %rax
2455         (%mm0 on ia32) and skip over this instruction, then fall into
2456         the next case. */
2457      new_vector = xpGPR(xp,Iallocptr);
2458      deref(new_vector,0) = 
2459#ifdef X8664
2460        xpGPR(xp,Iimm0)
2461#else
2462        xpMMXreg(xp,Imm0)
2463#endif
2464        ;
2465     
2466      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2467
2468      /* Fall thru */
2469    case ID_clear_tcr_save_allocptr_tag_instruction:
2470      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2471      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2472
2473      break;
2474    case ID_alloc_trap_instruction:
2475      /* If we're looking at another thread, we're pretty much committed to
2476         taking the trap.  We don't want the allocptr register to be pointing
2477         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2478         was determined above.
2479      */
2480      if (interrupt_displacement == NULL) {
2481        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2482        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2483      } else {
2484        /* Back out, and tell the caller how to resume the allocation attempt */
2485        *interrupt_displacement = disp;
2486        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2487        tcr->save_allocptr += disp;
2488        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2489                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2490                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2491      }
2492      break;
2493    case ID_branch_around_alloc_trap_instruction:
2494      /* If we'd take the branch - which is a "ja" - around the alloc trap,
2495         we might as well finish the allocation.  Otherwise, back out of the
2496         attempt. */
2497      {
2498        int flags = (int)eflags_register(xp);
2499       
2500        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2501            (!(flags & (1 << X86_CARRY_FLAG_BIT)))) {
2502          /* The branch (ja) would have been taken.  Emulate taking it. */
2503          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2504                       sizeof(alloc_trap_instruction));
2505          if (allocptr_tag == fulltag_misc) {
2506            /* Slap the header on the new uvector */
2507            new_vector = xpGPR(xp,Iallocptr);
2508#ifdef X8664
2509            deref(new_vector,0) = xpGPR(xp,Iimm0);
2510#else
2511            deref(new_vector,0) = xpMMXreg(xp,Imm0);
2512#endif
2513            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2514          }
2515          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2516          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2517        } else {
2518          /* Back up */
2519          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2520                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2521          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2522          if (interrupt_displacement) {
2523            *interrupt_displacement = disp;
2524            tcr->save_allocptr += disp;
2525          } else {
2526            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2527          }
2528        }
2529      }
2530      break;
2531    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2532      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2533      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2534      /* Fall through */
2535    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2536      if (interrupt_displacement) {
2537        tcr->save_allocptr += disp;
2538        *interrupt_displacement = disp;
2539      } else {
2540        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2541      }
2542      break;
2543    default: 
2544      break;
2545    }
2546    return;
2547  }
2548  if ((program_counter >= &egc_write_barrier_start) &&
2549      (program_counter < &egc_write_barrier_end)) {
2550    LispObj *ea = 0, val, root = 0;
2551    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2552    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
2553
2554    if (program_counter >= &egc_set_hash_key_conditional) {
2555      if (program_counter <= &egc_set_hash_key_conditional_retry) {
2556        return;
2557      }
2558      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
2559          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2560           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2561        /* Back up the PC, try again */
2562        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry;
2563        return;
2564      }
2565      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2566      val = xpGPR(xp,Iarg_z);
2567#ifdef X8664
2568      root = xpGPR(xp,Iarg_x);
2569      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2570#else
2571      root = xpGPR(xp,Itemp1);
2572      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2573#endif
2574      need_memoize_root = true;
2575      need_store = false;
2576      xpGPR(xp,Iarg_z) = t_value;
2577    } else if (program_counter >= &egc_store_node_conditional) {
2578      if (program_counter <= &egc_store_node_conditional_retry) {
2579        return;
2580      }
2581      if ((program_counter < &egc_store_node_conditional_success_test) ||
2582          ((program_counter == &egc_store_node_conditional_success_test) &&
2583           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2584        /* Back up the PC, try again */
2585        xpPC(xp) = (LispObj) &egc_store_node_conditional_retry;
2586        return;
2587      }
2588      if (program_counter >= &egc_store_node_conditional_success_end) {
2589        return;
2590      }
2591
2592      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2593      val = xpGPR(xp,Iarg_z);
2594#ifdef X8664
2595      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2596                                                       xpGPR(xp,Itemp0))));
2597#else
2598      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2599#endif
2600      xpGPR(xp,Iarg_z) = t_value;
2601      need_store = false;
2602    } else if (program_counter >= &egc_set_hash_key) {
2603#ifdef X8664
2604      root = xpGPR(xp,Iarg_x);
2605#else
2606      root = xpGPR(xp,Itemp0);
2607#endif
2608      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2609      val = xpGPR(xp,Iarg_z);
2610      need_memoize_root = true;
2611    } else if (program_counter >= &egc_gvset) {
2612#ifdef X8664
2613      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2614#else
2615      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2616#endif
2617      val = xpGPR(xp,Iarg_z);
2618    } else if (program_counter >= &egc_rplacd) {
2619      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2620      val = xpGPR(xp,Iarg_z);
2621    } else {                      /* egc_rplaca */
2622      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2623      val = xpGPR(xp,Iarg_z);
2624    }
2625    if (need_store) {
2626      *ea = val;
2627    }
2628    if (need_check_memo) {
2629      natural  bitnumber = area_dnode(ea, lisp_global(REF_BASE));
2630      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
2631          ((LispObj)ea < val)) {
2632        atomic_set_bit(refbits, bitnumber);
2633        if (need_memoize_root) {
2634          bitnumber = area_dnode(root, lisp_global(REF_BASE));
2635          atomic_set_bit(refbits, bitnumber);
2636        }
2637      }
2638    }
2639    {
2640      /* These subprimitives are called via CALL/RET; need
2641         to pop the return address off the stack and set
2642         the PC there. */
2643      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2644      xpPC(xp) = ra;
2645      xpGPR(xp,Isp)=(LispObj)sp;
2646    }
2647    return;
2648  }
2649}
2650
2651
2652void
2653normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2654{
2655  void *cur_allocptr = (void *)(tcr->save_allocptr);
2656  LispObj lisprsp;
2657  area *a;
2658
2659  if (xp) {
2660    if (is_other_tcr) {
2661      pc_luser_xp(xp, tcr, NULL);
2662    }
2663    a = tcr->vs_area;
2664    lisprsp = xpGPR(xp, Isp);
2665    if (((BytePtr)lisprsp >= a->low) &&
2666        ((BytePtr)lisprsp < a->high)) {
2667      a->active = (BytePtr)lisprsp;
2668    } else {
2669      a->active = (BytePtr) tcr->save_vsp;
2670    }
2671    a = tcr->ts_area;
2672    a->active = (BytePtr) tcr->save_tsp;
2673  } else {
2674    /* In ff-call; get area active pointers from tcr */
2675    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2676    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2677  }
2678  if (cur_allocptr) {
2679    update_bytes_allocated(tcr, cur_allocptr);
2680  }
2681  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2682  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2683    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2684  }
2685}
2686
2687
2688/* Suspend and "normalize" other tcrs, then call a gc-like function
2689   in that context.  Resume the other tcrs, then return what the
2690   function returned */
2691
2692TCR *gc_tcr = NULL;
2693
2694
2695signed_natural
2696gc_like_from_xp(ExceptionInformation *xp, 
2697                signed_natural(*fun)(TCR *, signed_natural), 
2698                signed_natural param)
2699{
2700  TCR *tcr = get_tcr(false), *other_tcr;
2701  int result;
2702  signed_natural inhibit;
2703
2704  suspend_other_threads(true);
2705  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2706  if (inhibit != 0) {
2707    if (inhibit > 0) {
2708      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2709    }
2710    resume_other_threads(true);
2711    gc_deferred++;
2712    return 0;
2713  }
2714  gc_deferred = 0;
2715
2716  gc_tcr = tcr;
2717
2718  /* This is generally necessary if the current thread invoked the GC
2719     via an alloc trap, and harmless if the GC was invoked via a GC
2720     trap.  (It's necessary in the first case because the "allocptr"
2721     register - %rbx - may be pointing into the middle of something
2722     below tcr->save_allocbase, and we wouldn't want the GC to see
2723     that bogus pointer.) */
2724  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2725
2726  normalize_tcr(xp, tcr, false);
2727
2728
2729  for (other_tcr = TCR_AUX(tcr)->next; other_tcr != tcr;
2730       other_tcr = TCR_AUX(other_tcr)->next) {
2731    if (other_tcr->pending_exception_context) {
2732      TCR_AUX(other_tcr)->gc_context = other_tcr->pending_exception_context;
2733    } else if (other_tcr->valence == TCR_STATE_LISP) {
2734      TCR_AUX(other_tcr)->gc_context = TCR_AUX(other_tcr)->suspend_context;
2735    } else {
2736      /* no pending exception, didn't suspend in lisp state:
2737         must have executed a synchronous ff-call.
2738      */
2739      TCR_AUX(other_tcr)->gc_context = NULL;
2740    }
2741    normalize_tcr(TCR_AUX(other_tcr)->gc_context, other_tcr, true);
2742  }
2743   
2744
2745
2746  result = fun(tcr, param);
2747
2748  other_tcr = tcr;
2749  do {
2750    TCR_AUX(other_tcr)->gc_context = NULL;
2751    other_tcr = TCR_AUX(other_tcr)->next;
2752  } while (other_tcr != tcr);
2753
2754  gc_tcr = NULL;
2755
2756  resume_other_threads(true);
2757
2758  return result;
2759
2760}
2761
2762signed_natural
2763purify_from_xp(ExceptionInformation *xp, signed_natural param)
2764{
2765  return gc_like_from_xp(xp, purify, param);
2766}
2767
2768signed_natural
2769impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2770{
2771  return gc_like_from_xp(xp, impurify, param);
2772}
2773
2774/* Returns #bytes freed by invoking GC */
2775
2776signed_natural
2777gc_from_tcr(TCR *tcr, signed_natural param)
2778{
2779  area *a;
2780  BytePtr oldfree, newfree;
2781  BytePtr oldend, newend;
2782
2783#if 0
2784  fprintf(dbgout, "Start GC  in 0x" LISP "\n", tcr);
2785#endif
2786  a = active_dynamic_area;
2787  oldend = a->high;
2788  oldfree = a->active;
2789  gc(tcr, param);
2790  newfree = a->active;
2791  newend = a->high;
2792#if 0
2793  fprintf(dbgout, "End GC  in 0x" LISP "\n", tcr);
2794#endif
2795  return ((oldfree-newfree)+(newend-oldend));
2796}
2797
2798signed_natural
2799gc_from_xp(ExceptionInformation *xp, signed_natural param)
2800{
2801  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
2802
2803  freeGCptrs();
2804  return status;
2805}
2806
2807#ifdef DARWIN
2808
2809#ifdef X8664
2810#define ts_pc(t) t->__rip
2811typedef x86_thread_state64_t native_thread_state_t;
2812#define NATIVE_THREAD_STATE_COUNT x86_THREAD_STATE64_COUNT
2813#define NATIVE_THREAD_STATE_FLAVOR x86_THREAD_STATE64
2814typedef x86_float_state64_t native_float_state_t;
2815#define NATIVE_FLOAT_STATE_COUNT x86_FLOAT_STATE64_COUNT
2816#define NATIVE_FLOAT_STATE_FLAVOR x86_FLOAT_STATE64
2817typedef x86_exception_state64_t native_exception_state_t;
2818#define NATIVE_EXCEPTION_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
2819#define NATIVE_EXCEPTION_STATE_FLAVOR x86_EXCEPTION_STATE64
2820#else
2821#define ts_pc(t) t->__eip
2822typedef x86_thread_state32_t native_thread_state_t;
2823#define NATIVE_THREAD_STATE_COUNT x86_THREAD_STATE32_COUNT
2824#define NATIVE_THREAD_STATE_FLAVOR x86_THREAD_STATE32
2825typedef x86_float_state32_t native_float_state_t;
2826#define NATIVE_FLOAT_STATE_COUNT x86_FLOAT_STATE32_COUNT
2827#define NATIVE_FLOAT_STATE_FLAVOR x86_FLOAT_STATE32
2828typedef x86_exception_state32_t native_exception_state_t;
2829#define NATIVE_EXCEPTION_STATE_COUNT x86_EXCEPTION_STATE32_COUNT
2830#define NATIVE_EXCEPTION_STATE_FLAVOR x86_EXCEPTION_STATE32
2831#endif
2832
2833#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2834#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2835
2836extern void pseudo_sigreturn(void);
2837
2838
2839
2840#define LISP_EXCEPTIONS_HANDLED_MASK \
2841 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2842
2843/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2844#define NUM_LISP_EXCEPTIONS_HANDLED 4
2845
2846typedef struct {
2847  int foreign_exception_port_count;
2848  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2849  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2850  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2851  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2852} MACH_foreign_exception_state;
2853
2854
2855
2856
2857/*
2858  Mach's exception mechanism works a little better than its signal
2859  mechanism (and, not incidentally, it gets along with GDB a lot
2860  better.
2861
2862  Initially, we install an exception handler to handle each native
2863  thread's exceptions.  This process involves creating a distinguished
2864  thread which listens for kernel exception messages on a set of
2865  0 or more thread exception ports.  As threads are created, they're
2866  added to that port set; a thread's exception port is destroyed
2867  (and therefore removed from the port set) when the thread exits.
2868
2869  A few exceptions can be handled directly in the handler thread;
2870  others require that we resume the user thread (and that the
2871  exception thread resumes listening for exceptions.)  The user
2872  thread might eventually want to return to the original context
2873  (possibly modified somewhat.)
2874
2875  As it turns out, the simplest way to force the faulting user
2876  thread to handle its own exceptions is to do pretty much what
2877  signal() does: the exception handlng thread sets up a sigcontext
2878  on the user thread's stack and forces the user thread to resume
2879  execution as if a signal handler had been called with that
2880  context as an argument.  We can use a distinguished UUO at a
2881  distinguished address to do something like sigreturn(); that'll
2882  have the effect of resuming the user thread's execution in
2883  the (pseudo-) signal context.
2884
2885  Since:
2886    a) we have miles of code in C and in Lisp that knows how to
2887    deal with Linux sigcontexts
2888    b) Linux sigcontexts contain a little more useful information
2889    (the DAR, DSISR, etc.) than their Darwin counterparts
2890    c) we have to create a sigcontext ourselves when calling out
2891    to the user thread: we aren't really generating a signal, just
2892    leveraging existing signal-handling code.
2893
2894  we create a Linux sigcontext struct.
2895
2896  Simple ?  Hopefully from the outside it is ...
2897
2898  We want the process of passing a thread's own context to it to
2899  appear to be atomic: in particular, we don't want the GC to suspend
2900  a thread that's had an exception but has not yet had its user-level
2901  exception handler called, and we don't want the thread's exception
2902  context to be modified by a GC while the Mach handler thread is
2903  copying it around.  On Linux (and on Jaguar), we avoid this issue
2904  because (a) the kernel sets up the user-level signal handler and
2905  (b) the signal handler blocks signals (including the signal used
2906  by the GC to suspend threads) until tcr->xframe is set up.
2907
2908  The GC and the Mach server thread therefore contend for the lock
2909  "mach_exception_lock".  The Mach server thread holds the lock
2910  when copying exception information between the kernel and the
2911  user thread; the GC holds this lock during most of its execution
2912  (delaying exception processing until it can be done without
2913  GC interference.)
2914
2915*/
2916
2917#ifdef PPC64
2918#define C_REDZONE_LEN           320
2919#define C_STK_ALIGN             32
2920#else
2921#define C_REDZONE_LEN           224
2922#define C_STK_ALIGN             16
2923#endif
2924#define C_PARAMSAVE_LEN         64
2925#define C_LINKAGE_LEN           48
2926
2927#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
2928
2929void
2930fatal_mach_error(char *format, ...);
2931
2932#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
2933
2934
2935void
2936restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext, native_thread_state_t *ts)
2937{
2938  kern_return_t kret;
2939#if WORD_SIZE == 64
2940  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
2941#else
2942  mcontext_t mc = UC_MCONTEXT(pseudosigcontext);
2943#endif
2944
2945  /* Set the thread's FP state from the pseudosigcontext */
2946  kret = thread_set_state(thread,
2947                          NATIVE_FLOAT_STATE_FLAVOR,
2948                          (thread_state_t)&(mc->__fs),
2949                          NATIVE_FLOAT_STATE_COUNT);
2950  MACH_CHECK_ERROR("setting thread FP state", kret);
2951  *ts = mc->__ss;
2952} 
2953
2954kern_return_t
2955do_pseudo_sigreturn(mach_port_t thread, TCR *tcr, native_thread_state_t *out)
2956{
2957  ExceptionInformation *xp;
2958
2959#ifdef DEBUG_MACH_EXCEPTIONS
2960  fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr);
2961#endif
2962  xp = tcr->pending_exception_context;
2963  if (xp) {
2964    tcr->pending_exception_context = NULL;
2965    tcr->valence = TCR_STATE_LISP;
2966    restore_mach_thread_state(thread, xp, out);
2967    raise_pending_interrupt(tcr);
2968  } else {
2969    Bug(NULL, "no xp here!\n");
2970  }
2971#ifdef DEBUG_MACH_EXCEPTIONS
2972  fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr);
2973#endif
2974  return KERN_SUCCESS;
2975} 
2976
2977ExceptionInformation *
2978create_thread_context_frame(mach_port_t thread, 
2979                            natural *new_stack_top,
2980                            siginfo_t **info_ptr,
2981                            TCR *tcr,
2982                            native_thread_state_t *ts
2983                            )
2984{
2985  mach_msg_type_number_t thread_state_count;
2986  ExceptionInformation *pseudosigcontext;
2987#ifdef X8664
2988  MCONTEXT_T mc;
2989#else
2990  mcontext_t mc;
2991#endif
2992  natural stackp;
2993
2994#ifdef X8664 
2995  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
2996  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
2997#else
2998  stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr);
2999#endif
3000  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
3001  if (info_ptr) {
3002    *info_ptr = (siginfo_t *)stackp;
3003  }
3004  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
3005  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
3006
3007  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
3008  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
3009 
3010  memmove(&(mc->__ss),ts,sizeof(*ts));
3011
3012  thread_state_count = NATIVE_FLOAT_STATE_COUNT;
3013  thread_get_state(thread,
3014                   NATIVE_FLOAT_STATE_FLAVOR,
3015                   (thread_state_t)&(mc->__fs),
3016                   &thread_state_count);
3017
3018  thread_state_count = NATIVE_EXCEPTION_STATE_COUNT;
3019  thread_get_state(thread,
3020                   NATIVE_EXCEPTION_STATE_FLAVOR,
3021                   (thread_state_t)&(mc->__es),
3022                   &thread_state_count);
3023
3024
3025  UC_MCONTEXT(pseudosigcontext) = mc;
3026  if (new_stack_top) {
3027    *new_stack_top = stackp;
3028  }
3029  return pseudosigcontext;
3030}
3031
3032/*
3033  This code sets up the user thread so that it executes a "pseudo-signal
3034  handler" function when it resumes.  Create a fake ucontext struct
3035  on the thread's stack and pass it as an argument to the pseudo-signal
3036  handler.
3037
3038  Things are set up so that the handler "returns to" pseudo_sigreturn(),
3039  which will restore the thread's context.
3040
3041  If the handler invokes code that throws (or otherwise never sigreturn()'s
3042  to the context), that's fine.
3043
3044  Actually, check that: throw (and variants) may need to be careful and
3045  pop the tcr's xframe list until it's younger than any frame being
3046  entered.
3047*/
3048
3049int
3050setup_signal_frame(mach_port_t thread,
3051                   void *handler_address,
3052                   int signum,
3053                   int code,
3054                   TCR *tcr,
3055                   native_thread_state_t *ts,
3056                   native_thread_state_t *new_ts
3057                   )
3058{
3059  ExceptionInformation *pseudosigcontext;
3060  int  old_valence = tcr->valence;
3061  natural stackp, *stackpp;
3062  siginfo_t *info;
3063
3064#ifdef DEBUG_MACH_EXCEPTIONS
3065  fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr);
3066#endif
3067  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
3068  bzero(info, sizeof(*info));
3069  info->si_code = code;
3070  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
3071  info->si_signo = signum;
3072  pseudosigcontext->uc_onstack = 0;
3073  pseudosigcontext->uc_sigmask = (sigset_t) 0;
3074  pseudosigcontext->uc_stack.ss_sp = 0;
3075  pseudosigcontext->uc_stack.ss_size = 0;
3076  pseudosigcontext->uc_stack.ss_flags = 0;
3077  pseudosigcontext->uc_link = NULL;
3078  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
3079  tcr->pending_exception_context = pseudosigcontext;
3080  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
3081 
3082
3083  /*
3084     It seems like we've created a  sigcontext on the thread's
3085     stack.  Set things up so that we call the handler (with appropriate
3086     args) when the thread's resumed.
3087  */
3088
3089#ifdef X8664
3090  new_ts->__rip = (natural) handler_address;
3091  stackpp = (natural *)stackp;
3092  *--stackpp = (natural)pseudo_sigreturn;
3093  stackp = (natural)stackpp;
3094  new_ts->__rdi = signum;
3095  new_ts->__rsi = (natural)info;
3096  new_ts->__rdx = (natural)pseudosigcontext;
3097  new_ts->__rcx = (natural)tcr;
3098  new_ts->__r8 = (natural)old_valence;
3099  new_ts->__rsp = stackp;
3100  new_ts->__rflags = ts->__rflags;
3101#else
3102  bzero(new_ts, sizeof(*new_ts));
3103  new_ts->__cs = ts->__cs;
3104  new_ts->__ss = ts->__ss;
3105  new_ts->__ds = ts->__ds;
3106  new_ts->__es = ts->__es;
3107  new_ts->__fs = ts->__fs;
3108  new_ts->__gs = ts->__gs;
3109
3110  new_ts->__eip = (natural)handler_address;
3111  stackpp = (natural *)stackp;
3112  *--stackpp = 0;               /* alignment */
3113  *--stackpp = 0;
3114  *--stackpp = 0;
3115  *--stackpp = (natural)old_valence;
3116  *--stackpp = (natural)tcr;
3117  *--stackpp = (natural)pseudosigcontext;
3118  *--stackpp = (natural)info;
3119  *--stackpp = (natural)signum;
3120  *--stackpp = (natural)pseudo_sigreturn;
3121  stackp = (natural)stackpp;
3122  new_ts->__esp = stackp;
3123  new_ts->__eflags = ts->__eflags;
3124#endif
3125#ifdef DEBUG_MACH_EXCEPTIONS
3126  fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
3127#endif
3128  return 0;
3129}
3130
3131
3132
3133
3134
3135
3136/*
3137  This function runs in the exception handling thread.  It's
3138  called (by this precise name) from the library function "exc_server()"
3139  when the thread's exception ports are set up.  (exc_server() is called
3140  via mach_msg_server(), which is a function that waits for and dispatches
3141  on exception messages from the Mach kernel.)
3142
3143  This checks to see if the exception was caused by a pseudo_sigreturn()
3144  UUO; if so, it arranges for the thread to have its state restored
3145  from the specified context.
3146
3147  Otherwise, it tries to map the exception to a signal number and
3148  arranges that the thread run a "pseudo signal handler" to handle
3149  the exception.
3150
3151  Some exceptions could and should be handled here directly.
3152*/
3153
3154
3155
3156
3157#define DARWIN_EXCEPTION_HANDLER signal_handler
3158
3159
3160kern_return_t
3161catch_exception_raise_state(mach_port_t exception_port,
3162                            exception_type_t exception,
3163                            exception_data_t code_vector,
3164                            mach_msg_type_number_t code_count,
3165                            int * flavor,
3166                            thread_state_t in_state,
3167                            mach_msg_type_number_t in_state_count,
3168                            thread_state_t out_state,
3169                            mach_msg_type_number_t * out_state_count)
3170{
3171  int signum = 0, code = *code_vector;
3172  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
3173  mach_port_t thread = (mach_port_t)((natural)tcr->native_thread_id);
3174  kern_return_t kret, call_kret;
3175
3176  native_thread_state_t
3177    *ts = (native_thread_state_t *)in_state,
3178    *out_ts = (native_thread_state_t*)out_state;
3179  mach_msg_type_number_t thread_state_count;
3180
3181
3182
3183  if (1) {
3184    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
3185      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
3186    } 
3187    if ((code == EXC_I386_GPFLT) &&
3188        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
3189      kret = do_pseudo_sigreturn(thread, tcr, out_ts);
3190#if 0
3191      fprintf(dbgout, "Exception return in 0x%x\n",tcr);
3192#endif
3193    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
3194      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
3195      kret = 17;
3196    } else {
3197      switch (exception) {
3198      case EXC_BAD_ACCESS:
3199        if (code == EXC_I386_GPFLT) {
3200          signum = SIGSEGV;
3201        } else {
3202          signum = SIGBUS;
3203        }
3204        break;
3205       
3206      case EXC_BAD_INSTRUCTION:
3207        if (code == EXC_I386_GPFLT) {
3208          signum = SIGSEGV;
3209        } else {
3210          signum = SIGILL;
3211        }
3212        break;
3213         
3214      case EXC_SOFTWARE:
3215        signum = SIGILL;
3216        break;
3217       
3218      case EXC_ARITHMETIC:
3219        signum = SIGFPE;
3220        if (code == EXC_I386_DIV)
3221          code = FPE_INTDIV;
3222        break;
3223       
3224      default:
3225        break;
3226      }
3227#if WORD_SIZE==64
3228      if ((signum==SIGFPE) && 
3229          (code != FPE_INTDIV) && 
3230          (tcr->valence != TCR_STATE_LISP)) {
3231        mach_msg_type_number_t thread_state_count = x86_FLOAT_STATE64_COUNT;
3232        x86_float_state64_t fs;
3233
3234        thread_get_state(thread,
3235                         x86_FLOAT_STATE64,
3236                         (thread_state_t)&fs,
3237                         &thread_state_count);
3238       
3239        if (! (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN_FPE))) {
3240          tcr->flags |= (1<<TCR_FLAG_BIT_FOREIGN_FPE);
3241          tcr->lisp_mxcsr = (fs.__fpu_mxcsr & ~MXCSR_STATUS_MASK);
3242        }
3243        fs.__fpu_mxcsr &= ~MXCSR_STATUS_MASK;
3244        fs.__fpu_mxcsr |= MXCSR_CONTROL_MASK;
3245        thread_set_state(thread,
3246                         x86_FLOAT_STATE64,
3247                         (thread_state_t)&fs,
3248                         x86_FLOAT_STATE64_COUNT);
3249        *out_state_count = NATIVE_THREAD_STATE_COUNT;
3250        *out_ts = *ts;
3251        return KERN_SUCCESS;
3252      }
3253#endif
3254      if (signum) {
3255        kret = setup_signal_frame(thread,
3256                                  (void *)DARWIN_EXCEPTION_HANDLER,
3257                                  signum,
3258                                  code,
3259                                  tcr, 
3260                                  ts,
3261                                  out_ts);
3262       
3263      } else {
3264        kret = 17;
3265      }
3266    }
3267  }
3268  if (kret) {
3269    *out_state_count = 0;
3270    *flavor = 0;
3271  } else {
3272    *out_state_count = NATIVE_THREAD_STATE_COUNT;
3273  }
3274  return kret;
3275}
3276
3277
3278
3279
3280static mach_port_t mach_exception_thread = (mach_port_t)0;
3281
3282
3283/*
3284  The initial function for an exception-handling thread.
3285*/
3286
3287void *
3288exception_handler_proc(void *arg)
3289{
3290  extern boolean_t exc_server();
3291  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
3292
3293  mach_exception_thread = pthread_mach_thread_np(pthread_self());
3294  mach_msg_server(exc_server, 256, p, 0);
3295  /* Should never return. */
3296  abort();
3297}
3298
3299
3300
3301void
3302mach_exception_thread_shutdown()
3303{
3304  kern_return_t kret;
3305
3306  fprintf(dbgout, "terminating Mach exception thread, 'cause exit can't\n");
3307  kret = thread_terminate(mach_exception_thread);
3308  if (kret != KERN_SUCCESS) {
3309    fprintf(dbgout, "Couldn't terminate exception thread, kret = %d\n",kret);
3310  }
3311}
3312
3313
3314mach_port_t
3315mach_exception_port_set()
3316{
3317  static mach_port_t __exception_port_set = MACH_PORT_NULL;
3318  kern_return_t kret; 
3319  if (__exception_port_set == MACH_PORT_NULL) {
3320
3321    kret = mach_port_allocate(mach_task_self(),
3322                              MACH_PORT_RIGHT_PORT_SET,
3323                              &__exception_port_set);
3324    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
3325    create_system_thread(0,
3326                         NULL,
3327                         exception_handler_proc, 
3328                         (void *)((natural)__exception_port_set));
3329  }
3330  return __exception_port_set;
3331}
3332
3333/*
3334  Setup a new thread to handle those exceptions specified by
3335  the mask "which".  This involves creating a special Mach
3336  message port, telling the Mach kernel to send exception
3337  messages for the calling thread to that port, and setting
3338  up a handler thread which listens for and responds to
3339  those messages.
3340
3341*/
3342
3343/*
3344  Establish the lisp thread's TCR as its exception port, and determine
3345  whether any other ports have been established by foreign code for
3346  exceptions that lisp cares about.
3347
3348  If this happens at all, it should happen on return from foreign
3349  code and on entry to lisp code via a callback.
3350
3351  This is a lot of trouble (and overhead) to support Java, or other
3352  embeddable systems that clobber their caller's thread exception ports.
3353 
3354*/
3355kern_return_t
3356tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
3357{
3358  kern_return_t kret;
3359  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
3360  int i;
3361  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
3362  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
3363  exception_mask_t mask = 0;
3364
3365  kret = thread_swap_exception_ports(thread,
3366                                     LISP_EXCEPTIONS_HANDLED_MASK,
3367                                     lisp_port,
3368                                     EXCEPTION_STATE,
3369#if WORD_SIZE==64
3370                                     x86_THREAD_STATE64,
3371#else
3372                                     x86_THREAD_STATE32,
3373#endif
3374                                     fxs->masks,
3375                                     &n,
3376                                     fxs->ports,
3377                                     fxs->behaviors,
3378                                     fxs->flavors);
3379  if (kret == KERN_SUCCESS) {
3380    fxs->foreign_exception_port_count = n;
3381    for (i = 0; i < n; i ++) {
3382      foreign_port = fxs->ports[i];
3383
3384      if ((foreign_port != lisp_port) &&
3385          (foreign_port != MACH_PORT_NULL)) {
3386        mask |= fxs->masks[i];
3387      }
3388    }
3389    tcr->foreign_exception_status = (int) mask;
3390  }
3391  return kret;
3392}
3393
3394kern_return_t
3395tcr_establish_lisp_exception_port(TCR *tcr)
3396{
3397  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
3398}
3399
3400/*
3401  Do this when calling out to or returning from foreign code, if
3402  any conflicting foreign exception ports were established when we
3403  last entered lisp code.
3404*/
3405kern_return_t
3406restore_foreign_exception_ports(TCR *tcr)
3407{
3408  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
3409  kern_return_t kret;
3410
3411  if (m) {
3412    MACH_foreign_exception_state *fxs  = 
3413      (MACH_foreign_exception_state *) tcr->native_thread_info;
3414    int i, n = fxs->foreign_exception_port_count;
3415    exception_mask_t tm;
3416
3417    for (i = 0; i < n; i++) {
3418      if ((tm = fxs->masks[i]) & m) {
3419        kret = thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
3420                                   tm,
3421                                   fxs->ports[i],
3422                                   fxs->behaviors[i],
3423                                   fxs->flavors[i]);
3424        MACH_CHECK_ERROR("restoring thread exception ports", kret);
3425      }
3426    }
3427  }
3428  return KERN_SUCCESS;
3429}
3430                                   
3431
3432/*
3433  This assumes that a Mach port (to be used as the thread's exception port) whose
3434  "name" matches the TCR's 32-bit address has already been allocated.
3435*/
3436
3437kern_return_t
3438setup_mach_exception_handling(TCR *tcr)
3439{
3440  mach_port_t
3441    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
3442    task_self = mach_task_self();
3443  kern_return_t kret;
3444
3445  kret = mach_port_insert_right(task_self,
3446                                thread_exception_port,
3447                                thread_exception_port,
3448                                MACH_MSG_TYPE_MAKE_SEND);
3449  MACH_CHECK_ERROR("adding send right to exception_port",kret);
3450
3451  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
3452  if (kret == KERN_SUCCESS) {
3453    mach_port_t exception_port_set = mach_exception_port_set();
3454
3455    kret = mach_port_move_member(task_self,
3456                                 thread_exception_port,
3457                                 exception_port_set);
3458  }
3459  return kret;
3460}
3461
3462void
3463darwin_exception_init(TCR *tcr)
3464{
3465  void tcr_monitor_exception_handling(TCR*, Boolean);
3466  kern_return_t kret;
3467  MACH_foreign_exception_state *fxs = 
3468    calloc(1, sizeof(MACH_foreign_exception_state));
3469 
3470  tcr->native_thread_info = (void *) fxs;
3471
3472  if ((kret = setup_mach_exception_handling(tcr))
3473      != KERN_SUCCESS) {
3474    fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret);
3475    terminate_lisp();
3476  }
3477}
3478
3479/*
3480  The tcr is the "name" of the corresponding thread's exception port.
3481  Destroying the port should remove it from all port sets of which it's
3482  a member (notably, the exception port set.)
3483*/
3484void
3485darwin_exception_cleanup(TCR *tcr)
3486{
3487  void *fxs = tcr->native_thread_info;
3488  extern Boolean use_mach_exception_handling;
3489
3490  if (fxs) {
3491    tcr->native_thread_info = NULL;
3492    free(fxs);
3493  }
3494  if (use_mach_exception_handling) {
3495    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3496    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3497  }
3498}
3499
3500
3501
3502
3503void
3504fatal_mach_error(char *format, ...)
3505{
3506  va_list args;
3507  char s[512];
3508 
3509
3510  va_start(args, format);
3511  vsnprintf(s, sizeof(s),format, args);
3512  va_end(args);
3513
3514  Fatal("Mach error", s);
3515}
3516
3517
3518
3519
3520#endif
3521
3522/* watchpoint stuff */
3523
3524area *
3525new_watched_area(natural size)
3526{
3527  char *p;
3528
3529  p = MapMemory(NULL, size, MEMPROTECT_RWX);
3530  if ((signed_natural)p == -1) {
3531    allocation_failure(true, size);
3532  }
3533  return new_area(p, p + size, AREA_WATCHED);
3534}
3535
3536void
3537delete_watched_area(area *a, TCR *tcr)
3538{
3539  natural nbytes = a->high - a->low;
3540  char *base = a->low;
3541
3542  condemn_area_holding_area_lock(a);
3543
3544  if (nbytes) {
3545    int err;
3546
3547    err = UnMapMemory(base, nbytes);
3548    if (err != 0)
3549      Fatal("munmap in delete_watched_area", "");
3550  }
3551}
3552
3553natural
3554uvector_total_size_in_bytes(LispObj *u)
3555{
3556  LispObj header = header_of(u);
3557  natural header_tag = fulltag_of(header);
3558  natural subtag = header_subtag(header);
3559  natural element_count = header_element_count(header);
3560  natural nbytes = 0;
3561
3562#ifdef X8632
3563  if ((nodeheader_tag_p(header_tag)) ||
3564      (subtag <= max_32_bit_ivector_subtag)) {
3565    nbytes = element_count << 2;
3566  } else if (subtag <= max_8_bit_ivector_subtag) {
3567    nbytes = element_count;
3568  } else if (subtag <= max_16_bit_ivector_subtag) {
3569    nbytes = element_count << 1;
3570  } else if (subtag == subtag_double_float_vector) {
3571    nbytes = element_count << 3;
3572  } else {
3573    nbytes = (element_count + 7) >> 3;
3574  }
3575  /* add 4 byte header and round up to multiple of 8 bytes */
3576  return ~7 & (4 + nbytes + 7);
3577#endif
3578#ifdef X8664
3579  if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) {
3580    nbytes = element_count << 3;
3581  } else if (header_tag == ivector_class_32_bit) {
3582    nbytes = element_count << 2;
3583  } else {
3584    /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */
3585    if (subtag == subtag_bit_vector) {
3586      nbytes = (element_count + 7) >> 3;
3587    } else if (subtag >= min_8_bit_ivector_subtag) {
3588      nbytes = element_count;
3589    } else {
3590      nbytes = element_count << 1;
3591    }
3592  }
3593  /* add 8 byte header and round up to multiple of 16 bytes */
3594  return ~15 & (8 + nbytes + 15);
3595#endif
3596}
3597
3598extern void wp_update_references(TCR *, LispObj, LispObj);
3599
3600/*
3601 * Other threads are suspended and pc-lusered.
3602 *
3603 * param contains a tagged pointer to a uvector or a cons cell
3604 */
3605signed_natural
3606watch_object(TCR *tcr, signed_natural param)
3607{
3608  LispObj object = (LispObj)param;
3609  unsigned tag = fulltag_of(object);
3610  LispObj *noderef = (LispObj *)untag(object);
3611  area *object_area = area_containing((BytePtr)noderef);
3612  natural size;
3613
3614  if (tag == fulltag_cons)
3615    size = 2 * node_size;
3616  else
3617    size = uvector_total_size_in_bytes(noderef);
3618
3619  if (object_area && object_area->code == AREA_DYNAMIC) {
3620    area *a = new_watched_area(size);
3621    LispObj old = object;
3622    LispObj new = (LispObj)((natural)a->low + tag);
3623
3624    add_area_holding_area_lock(a);
3625
3626    /* move object to watched area */
3627    memcpy(a->low, noderef, size);
3628    ProtectMemory(a->low, size);
3629    memset(noderef, 0, size);
3630    wp_update_references(tcr, old, new);
3631    check_all_areas(tcr);
3632    return 1;
3633  }
3634  return 0;
3635}
3636
3637/*
3638 * We expect the watched object in arg_y, and the new uninitialized
3639 * object (which is just zeroed) in arg_z.
3640 */
3641signed_natural
3642unwatch_object(TCR *tcr, signed_natural param)
3643{
3644  ExceptionInformation *xp = tcr->xframe->curr;
3645  LispObj old = xpGPR(xp, Iarg_y);
3646  unsigned tag = fulltag_of(old);
3647  LispObj new = xpGPR(xp, Iarg_z);
3648  LispObj *oldnode = (LispObj *)untag(old);
3649  LispObj *newnode = (LispObj *)untag(new);
3650  area *a = area_containing((BytePtr)old);
3651  extern void update_managed_refs(area *, BytePtr, natural);
3652
3653  if (a && a->code == AREA_WATCHED) {
3654    natural size;
3655
3656    if (tag == fulltag_cons)
3657      size = 2 * node_size;
3658    else
3659      size = uvector_total_size_in_bytes(oldnode);
3660
3661    memcpy(newnode, oldnode, size);
3662    delete_watched_area(a, tcr);
3663    wp_update_references(tcr, old, new);
3664    /* because wp_update_references doesn't update refbits */
3665    tenure_to_area(tenured_area);
3666    /* Unwatching can (re-)introduce managed_static->dynamic references */
3667    zero_bits(managed_static_area->refbits,managed_static_area->ndnodes);
3668    update_managed_refs(managed_static_area, low_markable_address, area_dnode(active_dynamic_area->active, low_markable_address));
3669    check_all_areas(tcr);
3670    xpGPR(xp, Iarg_z) = new;
3671  }
3672  return 0;
3673}
3674
3675Boolean
3676handle_watch_trap(ExceptionInformation *xp, TCR *tcr)
3677{
3678  LispObj selector = xpGPR(xp,Iimm0);
3679  LispObj object = xpGPR(xp, Iarg_z);
3680  signed_natural result;
3681 
3682  switch (selector) {
3683    case WATCH_TRAP_FUNCTION_WATCH:
3684      result = gc_like_from_xp(xp, watch_object, object);
3685      if (result == 0)
3686        xpGPR(xp,Iarg_z) = lisp_nil;
3687      break;
3688    case WATCH_TRAP_FUNCTION_UNWATCH:
3689      gc_like_from_xp(xp, unwatch_object, 0);
3690      break;
3691    default:
3692      break;
3693  }
3694  return true;
3695}
3696
Note: See TracBrowser for help on using the repository browser.