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

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

On x86 Darwin, use catch_exception_raise_state(); this keeps Mach from
pointlessly incrementing a port right usage count and keeps us from
having to worry about decrementing that, and also saves us a few
Mach messaging operations to get/set thread state.

Change a few related functions, remove some obsolete functions and
comments.

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