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

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

x86-exceptions.c: Ensure that SIGTRAP is defined (it's not on Win64).
lisp-kernel/win64/Makefile: Don't use the --export-dynamic linker option.

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