source: release/1.6/source/lisp-kernel/x86-exceptions.c @ 14433

Last change on this file since 14433 was 14433, checked in by rme, 9 years ago

Merge r14425 through r14432 from trunk.

Addresses:

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