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

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

Remove the LISP_ASSEMBLER_EXTRA_SIB_BYTE code from pc_luser_xp() and
friends. Finally closes ticket:860.

Also, the consing sequence used to branch around the alloc trap with
a "jg" instruction. We haven't done that for a long time, so don't
check for that any more, either.

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