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

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

When an exception occurs and we call out to lisp, if the PC doesn't
seem to be relative to some lisp function -don't- try to pass it
as a fixnum in a single word (that can't work if the PC is high
in the address space, as it certainly can be.) Split it into two
fixnums (in the xcf.relative-pc and xcf.tra slots) instead, and
reassemble it on the lisp side.

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