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

Last change on this file since 14826 was 14826, checked in by gb, 10 years ago

propagate r14825 to 1.6 branch; fixes ticket:868 in 1.6

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 108.0 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#ifdef LINUX
2378  /* The ucontext pushed on the altstack may not contain the (largish)
2379     __fpregs_mem field; copy_ucontext() wants to copy what it thinks
2380     is a pointer to a full ucontext.  That'll touch a page beyond the
2381     bottom of the altstack, and when this happens on the initial
2382     thread's stack on a recent (2.6.32+?) kernel, we'll SIGBUS instead
2383     of mapping that page.
2384     It's easier to just reserve that page here than it would be to
2385     change copy_ucontext().
2386  */
2387  stack.ss_size -= sizeof(struct ucontext);
2388#endif
2389  if (sigaltstack(&stack, NULL) != 0) {
2390    perror("sigaltstack");
2391    exit(-1);
2392  }
2393}
2394#endif
2395
2396extern opcode egc_write_barrier_start, egc_write_barrier_end,
2397  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2398  egc_set_hash_key_conditional_retry,
2399  egc_store_node_conditional_success_end, egc_store_node_conditional_retry,
2400  egc_store_node_conditional_success_test,egc_store_node_conditional,
2401  egc_set_hash_key, egc_gvset, egc_rplacd;
2402
2403/* We use (extremely) rigidly defined instruction sequences for consing,
2404   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2405   while consing.
2406
2407   Note that we can usually identify which of these instructions is about
2408   to be executed by a stopped thread without comparing all of the bytes
2409   to those at the stopped program counter, but we generally need to
2410   know the sizes of each of these instructions.
2411*/
2412
2413#ifdef X8664
2414opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2415#ifdef TCR_IN_GPR
2416  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2417#else
2418  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2419#endif
2420;
2421opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2422#ifdef TCR_IN_GPR
2423  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2424#else
2425  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2426#endif
2427
2428;
2429opcode branch_around_alloc_trap_instruction[] =
2430  {0x77,0x02};
2431opcode alloc_trap_instruction[] =
2432  {0xcd,0xc5};
2433opcode clear_tcr_save_allocptr_tag_instruction[] =
2434#ifdef TCR_IN_GPR
2435  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2436#else
2437  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2438#endif
2439;
2440opcode set_allocptr_header_instruction[] =
2441  {0x48,0x89,0x43,0xf3};
2442
2443
2444alloc_instruction_id
2445recognize_alloc_instruction(pc program_counter)
2446{
2447  switch(program_counter[0]) {
2448  case 0xcd: return ID_alloc_trap_instruction;
2449  /* 0x7f is jg, which we used to use here instead of ja */
2450  case 0x7f:
2451  case 0x77: return ID_branch_around_alloc_trap_instruction;
2452  case 0x48: return ID_set_allocptr_header_instruction;
2453#ifdef TCR_IN_GPR
2454  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2455  case 0x49:
2456    switch(program_counter[1]) {
2457    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2458    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2459    }
2460#else
2461  case 0x65: 
2462    switch(program_counter[1]) {
2463    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2464    case 0x48:
2465      switch(program_counter[2]) {
2466      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2467      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2468      }
2469    }
2470#endif
2471  default: break;
2472  }
2473  return ID_unrecognized_alloc_instruction;
2474}
2475#endif
2476#ifdef X8632
2477/* The lisp assembler might use both a modrm byte and a sib byte to
2478   encode a memory operand that contains a displacement but no
2479   base or index.  Using the sib byte is necessary for 64-bit code,
2480   since the sib-less form is used to indicate %rip-relative addressing
2481   on x8664.  On x8632, it's not necessary, slightly suboptimal, and
2482   doesn't match what we expect; until that's fixed, we may need to
2483   account for this extra byte when adjusting the PC */
2484#define LISP_ASSEMBLER_EXTRA_SIB_BYTE
2485#ifdef WIN32_ES_HACK
2486/* Win32 keeps the TCR in %es */
2487#define TCR_SEG_PREFIX 0x26     /* %es: */
2488#else
2489/* Other platfroms use %fs */
2490#define TCR_SEG_PREFIX 0x64     /* %fs: */
2491#endif
2492opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2493  {TCR_SEG_PREFIX,0x8b,0x0d,0x84,0x00,0x00,0x00};  /* may have extra SIB byte */
2494opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2495  {TCR_SEG_PREFIX,0x3b,0x0d,0x88,0x00,0x00,0x00};  /* may have extra SIB byte */
2496opcode branch_around_alloc_trap_instruction[] =
2497  {0x77,0x02};                  /* no SIB byte issue */
2498opcode alloc_trap_instruction[] =
2499  {0xcd,0xc5};                  /* no SIB byte issue */
2500opcode clear_tcr_save_allocptr_tag_instruction[] =
2501  {TCR_SEG_PREFIX,0x80,0x25,0x84,0x00,0x00,0x00,0xf8}; /* maybe SIB byte */
2502opcode set_allocptr_header_instruction[] =
2503  {0x0f,0x7e,0x41,0xfa};        /* no SIB byte issue */
2504
2505alloc_instruction_id
2506recognize_alloc_instruction(pc program_counter)
2507{
2508  switch(program_counter[0]) {
2509  case 0xcd: return ID_alloc_trap_instruction;
2510  /* 0x7f is jg, which we used to use here instead of ja */
2511  case 0x7f:
2512  case 0x77: return ID_branch_around_alloc_trap_instruction;
2513  case 0x0f: return ID_set_allocptr_header_instruction;
2514  case TCR_SEG_PREFIX: 
2515    switch(program_counter[1]) {
2516    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2517    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2518    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2519    }
2520  }
2521  return ID_unrecognized_alloc_instruction;
2522}
2523#endif     
2524
2525void
2526pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2527{
2528  pc program_counter = (pc)xpPC(xp);
2529  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2530
2531  if (allocptr_tag != 0) {
2532    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2533    signed_natural
2534      disp = (allocptr_tag == fulltag_cons) ?
2535      sizeof(cons) - fulltag_cons :
2536#ifdef X8664
2537      xpGPR(xp,Iimm1)
2538#else
2539      xpGPR(xp,Iimm0)
2540#endif
2541      ;
2542    LispObj new_vector;
2543
2544    if ((state == ID_unrecognized_alloc_instruction) ||
2545        ((state == ID_set_allocptr_header_instruction) &&
2546         (allocptr_tag != fulltag_misc))) {
2547      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2548    }
2549    switch(state) {
2550    case ID_set_allocptr_header_instruction:
2551      /* We were consing a vector and we won.  Set the header of the
2552         new vector (in the allocptr register) to the header in %rax
2553         (%mm0 on ia32) and skip over this instruction, then fall into
2554         the next case. */
2555      new_vector = xpGPR(xp,Iallocptr);
2556      deref(new_vector,0) = 
2557#ifdef X8664
2558        xpGPR(xp,Iimm0)
2559#else
2560        xpMMXreg(xp,Imm0)
2561#endif
2562        ;
2563     
2564      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2565
2566      /* Fall thru */
2567    case ID_clear_tcr_save_allocptr_tag_instruction:
2568      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2569#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2570      if (((pc)(xpPC(xp)))[2] == 0x24) {
2571        xpPC(xp) += 1;
2572      }
2573#endif
2574      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2575
2576      break;
2577    case ID_alloc_trap_instruction:
2578      /* If we're looking at another thread, we're pretty much committed to
2579         taking the trap.  We don't want the allocptr register to be pointing
2580         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2581         was determined above.
2582      */
2583      if (interrupt_displacement == NULL) {
2584        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2585        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2586      } else {
2587        /* Back out, and tell the caller how to resume the allocation attempt */
2588        *interrupt_displacement = disp;
2589        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2590        tcr->save_allocptr += disp;
2591#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2592        /* This assumes that TCR_SEG_PREFIX can't appear
2593           anywhere but at the beginning of one of these
2594           magic allocation-sequence instructions. */
2595        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2596                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction));
2597        if (*((pc)(xpPC(xp))) == TCR_SEG_PREFIX) {
2598          xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2599        } else {
2600          xpPC(xp) -= (sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction) + 2);
2601        }
2602       
2603#else
2604        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2605                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2606                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2607#endif
2608      }
2609      break;
2610    case ID_branch_around_alloc_trap_instruction:
2611      /* If we'd take the branch - which is a "ja" - around the alloc trap,
2612         we might as well finish the allocation.  Otherwise, back out of the
2613         attempt. */
2614      {
2615        int flags = (int)eflags_register(xp);
2616       
2617        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2618            (!(flags & (1 << X86_CARRY_FLAG_BIT)))) {
2619          /* The branch (ja) would have been taken.  Emulate taking it. */
2620          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2621                       sizeof(alloc_trap_instruction));
2622          if (allocptr_tag == fulltag_misc) {
2623            /* Slap the header on the new uvector */
2624            new_vector = xpGPR(xp,Iallocptr);
2625#ifdef X8664
2626            deref(new_vector,0) = xpGPR(xp,Iimm0);
2627#else
2628            deref(new_vector,0) = xpMMXreg(xp,Imm0);
2629#endif
2630            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2631          }
2632          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2633#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2634          if (((pc)xpPC(xp))[2] == 0x24) {
2635            xpPC(xp) += 1;
2636          }
2637#endif
2638          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2639        } else {
2640          /* Back up */
2641          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2642                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2643#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2644          if (*((pc)(xpPC(xp))) != TCR_SEG_PREFIX) {
2645            /* skipped two instructions with extra SIB byte */
2646            xpPC(xp) -= 2;
2647          }
2648#endif
2649          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2650          if (interrupt_displacement) {
2651            *interrupt_displacement = disp;
2652            tcr->save_allocptr += disp;
2653          } else {
2654            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2655          }
2656        }
2657      }
2658      break;
2659    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2660      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2661      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2662#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
2663      if (*((pc)xpPC(xp)) != TCR_SEG_PREFIX) {
2664        xpPC(xp) -= 1;
2665      }
2666#endif
2667      /* Fall through */
2668    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2669      if (interrupt_displacement) {
2670        tcr->save_allocptr += disp;
2671        *interrupt_displacement = disp;
2672      } else {
2673        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2674      }
2675      break;
2676    default: 
2677      break;
2678    }
2679    return;
2680  }
2681  if ((program_counter >= &egc_write_barrier_start) &&
2682      (program_counter < &egc_write_barrier_end)) {
2683    LispObj *ea = 0, val, root = 0;
2684    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2685    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
2686
2687    if (program_counter >= &egc_set_hash_key_conditional) {
2688      if (program_counter <= &egc_set_hash_key_conditional_retry) {
2689        return;
2690      }
2691      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
2692          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2693           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2694        /* Back up the PC, try again */
2695        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry;
2696        return;
2697      }
2698      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2699      val = xpGPR(xp,Iarg_z);
2700#ifdef X8664
2701      root = xpGPR(xp,Iarg_x);
2702      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2703#else
2704      root = xpGPR(xp,Itemp1);
2705      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2706#endif
2707      need_memoize_root = true;
2708      need_store = false;
2709      xpGPR(xp,Iarg_z) = t_value;
2710    } else if (program_counter >= &egc_store_node_conditional) {
2711      if (program_counter <= &egc_store_node_conditional_retry) {
2712        return;
2713      }
2714      if ((program_counter < &egc_store_node_conditional_success_test) ||
2715          ((program_counter == &egc_store_node_conditional_success_test) &&
2716           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
2717        /* Back up the PC, try again */
2718        xpPC(xp) = (LispObj) &egc_store_node_conditional_retry;
2719        return;
2720      }
2721      if (program_counter >= &egc_store_node_conditional_success_end) {
2722        return;
2723      }
2724
2725      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2726      val = xpGPR(xp,Iarg_z);
2727#ifdef X8664
2728      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2729                                                       xpGPR(xp,Itemp0))));
2730#else
2731      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2732#endif
2733      xpGPR(xp,Iarg_z) = t_value;
2734      need_store = false;
2735    } else if (program_counter >= &egc_set_hash_key) {
2736#ifdef X8664
2737      root = xpGPR(xp,Iarg_x);
2738#else
2739      root = xpGPR(xp,Itemp0);
2740#endif
2741      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2742      val = xpGPR(xp,Iarg_z);
2743      need_memoize_root = true;
2744    } else if (program_counter >= &egc_gvset) {
2745#ifdef X8664
2746      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2747#else
2748      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2749#endif
2750      val = xpGPR(xp,Iarg_z);
2751    } else if (program_counter >= &egc_rplacd) {
2752      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2753      val = xpGPR(xp,Iarg_z);
2754    } else {                      /* egc_rplaca */
2755      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2756      val = xpGPR(xp,Iarg_z);
2757    }
2758    if (need_store) {
2759      *ea = val;
2760    }
2761    if (need_check_memo) {
2762      natural  bitnumber = area_dnode(ea, lisp_global(REF_BASE));
2763      if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) &&
2764          ((LispObj)ea < val)) {
2765        atomic_set_bit(refbits, bitnumber);
2766        if (need_memoize_root) {
2767          bitnumber = area_dnode(root, lisp_global(REF_BASE));
2768          atomic_set_bit(refbits, bitnumber);
2769        }
2770      }
2771    }
2772    {
2773      /* These subprimitives are called via CALL/RET; need
2774         to pop the return address off the stack and set
2775         the PC there. */
2776      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2777      xpPC(xp) = ra;
2778      xpGPR(xp,Isp)=(LispObj)sp;
2779    }
2780    return;
2781  }
2782}
2783
2784
2785void
2786normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2787{
2788  void *cur_allocptr = (void *)(tcr->save_allocptr);
2789  LispObj lisprsp;
2790  area *a;
2791
2792  if (xp) {
2793    if (is_other_tcr) {
2794      pc_luser_xp(xp, tcr, NULL);
2795    }
2796    a = tcr->vs_area;
2797    lisprsp = xpGPR(xp, Isp);
2798    if (((BytePtr)lisprsp >= a->low) &&
2799        ((BytePtr)lisprsp < a->high)) {
2800      a->active = (BytePtr)lisprsp;
2801    } else {
2802      a->active = (BytePtr) tcr->save_vsp;
2803    }
2804    a = tcr->ts_area;
2805    a->active = (BytePtr) tcr->save_tsp;
2806  } else {
2807    /* In ff-call; get area active pointers from tcr */
2808    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2809    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2810  }
2811  if (cur_allocptr) {
2812    update_bytes_allocated(tcr, cur_allocptr);
2813  }
2814  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2815  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2816    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2817  }
2818}
2819
2820
2821/* Suspend and "normalize" other tcrs, then call a gc-like function
2822   in that context.  Resume the other tcrs, then return what the
2823   function returned */
2824
2825TCR *gc_tcr = NULL;
2826
2827
2828signed_natural
2829gc_like_from_xp(ExceptionInformation *xp, 
2830                signed_natural(*fun)(TCR *, signed_natural), 
2831                signed_natural param)
2832{
2833  TCR *tcr = get_tcr(false), *other_tcr;
2834  int result;
2835  signed_natural inhibit;
2836
2837  suspend_other_threads(true);
2838  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2839  if (inhibit != 0) {
2840    if (inhibit > 0) {
2841      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2842    }
2843    resume_other_threads(true);
2844    gc_deferred++;
2845    return 0;
2846  }
2847  gc_deferred = 0;
2848
2849  gc_tcr = tcr;
2850
2851  /* This is generally necessary if the current thread invoked the GC
2852     via an alloc trap, and harmless if the GC was invoked via a GC
2853     trap.  (It's necessary in the first case because the "allocptr"
2854     register - %rbx - may be pointing into the middle of something
2855     below tcr->save_allocbase, and we wouldn't want the GC to see
2856     that bogus pointer.) */
2857  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2858
2859  normalize_tcr(xp, tcr, false);
2860
2861
2862  for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) {
2863    if (other_tcr->pending_exception_context) {
2864      other_tcr->gc_context = other_tcr->pending_exception_context;
2865    } else if (other_tcr->valence == TCR_STATE_LISP) {
2866      other_tcr->gc_context = other_tcr->suspend_context;
2867    } else {
2868      /* no pending exception, didn't suspend in lisp state:
2869         must have executed a synchronous ff-call.
2870      */
2871      other_tcr->gc_context = NULL;
2872    }
2873    normalize_tcr(other_tcr->gc_context, other_tcr, true);
2874  }
2875   
2876
2877
2878  result = fun(tcr, param);
2879
2880  other_tcr = tcr;
2881  do {
2882    other_tcr->gc_context = NULL;
2883    other_tcr = other_tcr->next;
2884  } while (other_tcr != tcr);
2885
2886  gc_tcr = NULL;
2887
2888  resume_other_threads(true);
2889
2890  return result;
2891
2892}
2893
2894signed_natural
2895purify_from_xp(ExceptionInformation *xp, signed_natural param)
2896{
2897  return gc_like_from_xp(xp, purify, param);
2898}
2899
2900signed_natural
2901impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2902{
2903  return gc_like_from_xp(xp, impurify, param);
2904}
2905
2906/* Returns #bytes freed by invoking GC */
2907
2908signed_natural
2909gc_from_tcr(TCR *tcr, signed_natural param)
2910{
2911  area *a;
2912  BytePtr oldfree, newfree;
2913  BytePtr oldend, newend;
2914
2915#if 0
2916  fprintf(dbgout, "Start GC  in 0x" LISP "\n", tcr);
2917#endif
2918  a = active_dynamic_area;
2919  oldend = a->high;
2920  oldfree = a->active;
2921  gc(tcr, param);
2922  newfree = a->active;
2923  newend = a->high;
2924#if 0
2925  fprintf(dbgout, "End GC  in 0x" LISP "\n", tcr);
2926#endif
2927  return ((oldfree-newfree)+(newend-oldend));
2928}
2929
2930signed_natural
2931gc_from_xp(ExceptionInformation *xp, signed_natural param)
2932{
2933  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
2934
2935  freeGCptrs();
2936  return status;
2937}
2938
2939#ifdef DARWIN
2940
2941#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p))
2942#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr)))
2943
2944extern void pseudo_sigreturn(void);
2945
2946
2947
2948#define LISP_EXCEPTIONS_HANDLED_MASK \
2949 (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC)
2950
2951/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */
2952#define NUM_LISP_EXCEPTIONS_HANDLED 4
2953
2954typedef struct {
2955  int foreign_exception_port_count;
2956  exception_mask_t         masks[NUM_LISP_EXCEPTIONS_HANDLED];
2957  mach_port_t              ports[NUM_LISP_EXCEPTIONS_HANDLED];
2958  exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED];
2959  thread_state_flavor_t  flavors[NUM_LISP_EXCEPTIONS_HANDLED];
2960} MACH_foreign_exception_state;
2961
2962
2963
2964
2965/*
2966  Mach's exception mechanism works a little better than its signal
2967  mechanism (and, not incidentally, it gets along with GDB a lot
2968  better.
2969
2970  Initially, we install an exception handler to handle each native
2971  thread's exceptions.  This process involves creating a distinguished
2972  thread which listens for kernel exception messages on a set of
2973  0 or more thread exception ports.  As threads are created, they're
2974  added to that port set; a thread's exception port is destroyed
2975  (and therefore removed from the port set) when the thread exits.
2976
2977  A few exceptions can be handled directly in the handler thread;
2978  others require that we resume the user thread (and that the
2979  exception thread resumes listening for exceptions.)  The user
2980  thread might eventually want to return to the original context
2981  (possibly modified somewhat.)
2982
2983  As it turns out, the simplest way to force the faulting user
2984  thread to handle its own exceptions is to do pretty much what
2985  signal() does: the exception handlng thread sets up a sigcontext
2986  on the user thread's stack and forces the user thread to resume
2987  execution as if a signal handler had been called with that
2988  context as an argument.  We can use a distinguished UUO at a
2989  distinguished address to do something like sigreturn(); that'll
2990  have the effect of resuming the user thread's execution in
2991  the (pseudo-) signal context.
2992
2993  Since:
2994    a) we have miles of code in C and in Lisp that knows how to
2995    deal with Linux sigcontexts
2996    b) Linux sigcontexts contain a little more useful information
2997    (the DAR, DSISR, etc.) than their Darwin counterparts
2998    c) we have to create a sigcontext ourselves when calling out
2999    to the user thread: we aren't really generating a signal, just
3000    leveraging existing signal-handling code.
3001
3002  we create a Linux sigcontext struct.
3003
3004  Simple ?  Hopefully from the outside it is ...
3005
3006  We want the process of passing a thread's own context to it to
3007  appear to be atomic: in particular, we don't want the GC to suspend
3008  a thread that's had an exception but has not yet had its user-level
3009  exception handler called, and we don't want the thread's exception
3010  context to be modified by a GC while the Mach handler thread is
3011  copying it around.  On Linux (and on Jaguar), we avoid this issue
3012  because (a) the kernel sets up the user-level signal handler and
3013  (b) the signal handler blocks signals (including the signal used
3014  by the GC to suspend threads) until tcr->xframe is set up.
3015
3016  The GC and the Mach server thread therefore contend for the lock
3017  "mach_exception_lock".  The Mach server thread holds the lock
3018  when copying exception information between the kernel and the
3019  user thread; the GC holds this lock during most of its execution
3020  (delaying exception processing until it can be done without
3021  GC interference.)
3022
3023*/
3024
3025#ifdef PPC64
3026#define C_REDZONE_LEN           320
3027#define C_STK_ALIGN             32
3028#else
3029#define C_REDZONE_LEN           224
3030#define C_STK_ALIGN             16
3031#endif
3032#define C_PARAMSAVE_LEN         64
3033#define C_LINKAGE_LEN           48
3034
3035#define TRUNC_DOWN(a,b,c)  (((((natural)a)-(b))/(c)) * (c))
3036
3037void
3038fatal_mach_error(char *format, ...);
3039
3040#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);}
3041
3042
3043void
3044restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext)
3045{
3046  kern_return_t kret;
3047#if WORD_SIZE == 64
3048  MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext);
3049#else
3050  mcontext_t mc = UC_MCONTEXT(pseudosigcontext);
3051#endif
3052
3053  /* Set the thread's FP state from the pseudosigcontext */
3054#if WORD_SIZE == 64
3055  kret = thread_set_state(thread,
3056                          x86_FLOAT_STATE64,
3057                          (thread_state_t)&(mc->__fs),
3058                          x86_FLOAT_STATE64_COUNT);
3059#else
3060  kret = thread_set_state(thread,
3061                          x86_FLOAT_STATE32,
3062                          (thread_state_t)&(mc->__fs),
3063                          x86_FLOAT_STATE32_COUNT);
3064#endif
3065  MACH_CHECK_ERROR("setting thread FP state", kret);
3066
3067  /* The thread'll be as good as new ... */
3068#if WORD_SIZE == 64
3069  kret = thread_set_state(thread,
3070                          x86_THREAD_STATE64,
3071                          (thread_state_t)&(mc->__ss),
3072                          x86_THREAD_STATE64_COUNT);
3073#else
3074  kret = thread_set_state(thread, 
3075                          x86_THREAD_STATE32,
3076                          (thread_state_t)&(mc->__ss),
3077                          x86_THREAD_STATE32_COUNT);
3078#endif
3079  MACH_CHECK_ERROR("setting thread state", kret);
3080} 
3081
3082/* This code runs in the exception handling thread, in response
3083   to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g.,
3084   in response to a call to pseudo_sigreturn() from the specified
3085   user thread.
3086   Find that context (the user thread's R3 points to it), then
3087   use that context to set the user thread's state.  When this
3088   function's caller returns, the Mach kernel will resume the
3089   user thread.
3090*/
3091
3092kern_return_t
3093do_pseudo_sigreturn(mach_port_t thread, TCR *tcr)
3094{
3095  ExceptionInformation *xp;
3096
3097#ifdef DEBUG_MACH_EXCEPTIONS
3098  fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr);
3099#endif
3100  xp = tcr->pending_exception_context;
3101  if (xp) {
3102    tcr->pending_exception_context = NULL;
3103    tcr->valence = TCR_STATE_LISP;
3104    restore_mach_thread_state(thread, xp);
3105    raise_pending_interrupt(tcr);
3106  } else {
3107    Bug(NULL, "no xp here!\n");
3108  }
3109#ifdef DEBUG_MACH_EXCEPTIONS
3110  fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr);
3111#endif
3112  return KERN_SUCCESS;
3113} 
3114
3115ExceptionInformation *
3116create_thread_context_frame(mach_port_t thread, 
3117                            natural *new_stack_top,
3118                            siginfo_t **info_ptr,
3119                            TCR *tcr,
3120#ifdef X8664
3121                            x86_thread_state64_t *ts
3122#else
3123                            x86_thread_state32_t *ts
3124#endif
3125                            )
3126{
3127  mach_msg_type_number_t thread_state_count;
3128  ExceptionInformation *pseudosigcontext;
3129#ifdef X8664
3130  MCONTEXT_T mc;
3131#else
3132  mcontext_t mc;
3133#endif
3134  natural stackp;
3135
3136#ifdef X8664 
3137  stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr);
3138  stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN);
3139#else
3140  stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr);
3141#endif
3142  stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN);
3143  if (info_ptr) {
3144    *info_ptr = (siginfo_t *)stackp;
3145  }
3146  stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN);
3147  pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp);
3148
3149  stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN);
3150  mc = (MCONTEXT_T) ptr_from_lispobj(stackp);
3151 
3152  memmove(&(mc->__ss),ts,sizeof(*ts));
3153
3154#ifdef X8664
3155  thread_state_count = x86_FLOAT_STATE64_COUNT;
3156  thread_get_state(thread,
3157                   x86_FLOAT_STATE64,
3158                   (thread_state_t)&(mc->__fs),
3159                   &thread_state_count);
3160
3161  thread_state_count = x86_EXCEPTION_STATE64_COUNT;
3162  thread_get_state(thread,
3163                   x86_EXCEPTION_STATE64,
3164                   (thread_state_t)&(mc->__es),
3165                   &thread_state_count);
3166#else
3167  thread_state_count = x86_FLOAT_STATE32_COUNT;
3168  thread_get_state(thread,
3169                   x86_FLOAT_STATE32,
3170                   (thread_state_t)&(mc->__fs),
3171                   &thread_state_count);
3172
3173  thread_state_count = x86_EXCEPTION_STATE32_COUNT;
3174  thread_get_state(thread,
3175                   x86_EXCEPTION_STATE32,
3176                   (thread_state_t)&(mc->__es),
3177                   &thread_state_count);
3178#endif
3179
3180
3181  UC_MCONTEXT(pseudosigcontext) = mc;
3182  if (new_stack_top) {
3183    *new_stack_top = stackp;
3184  }
3185  return pseudosigcontext;
3186}
3187
3188/*
3189  This code sets up the user thread so that it executes a "pseudo-signal
3190  handler" function when it resumes.  Create a fake ucontext struct
3191  on the thread's stack and pass it as an argument to the pseudo-signal
3192  handler.
3193
3194  Things are set up so that the handler "returns to" pseudo_sigreturn(),
3195  which will restore the thread's context.
3196
3197  If the handler invokes code that throws (or otherwise never sigreturn()'s
3198  to the context), that's fine.
3199
3200  Actually, check that: throw (and variants) may need to be careful and
3201  pop the tcr's xframe list until it's younger than any frame being
3202  entered.
3203*/
3204
3205int
3206setup_signal_frame(mach_port_t thread,
3207                   void *handler_address,
3208                   int signum,
3209                   int code,
3210                   TCR *tcr,
3211#ifdef X8664
3212                   x86_thread_state64_t *ts
3213#else
3214                   x86_thread_state32_t *ts
3215#endif
3216                   )
3217{
3218#ifdef X8664
3219  x86_thread_state64_t new_ts;
3220#else
3221  x86_thread_state32_t new_ts;
3222#endif
3223  ExceptionInformation *pseudosigcontext;
3224  int  old_valence = tcr->valence;
3225  natural stackp, *stackpp;
3226  siginfo_t *info;
3227
3228#ifdef DEBUG_MACH_EXCEPTIONS
3229  fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr);
3230#endif
3231  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
3232  bzero(info, sizeof(*info));
3233  info->si_code = code;
3234  info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr);
3235  info->si_signo = signum;
3236  pseudosigcontext->uc_onstack = 0;
3237  pseudosigcontext->uc_sigmask = (sigset_t) 0;
3238  pseudosigcontext->uc_stack.ss_sp = 0;
3239  pseudosigcontext->uc_stack.ss_size = 0;
3240  pseudosigcontext->uc_stack.ss_flags = 0;
3241  pseudosigcontext->uc_link = NULL;
3242  pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext));
3243  tcr->pending_exception_context = pseudosigcontext;
3244  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
3245 
3246
3247  /*
3248     It seems like we've created a  sigcontext on the thread's
3249     stack.  Set things up so that we call the handler (with appropriate
3250     args) when the thread's resumed.
3251  */
3252
3253#ifdef X8664
3254  new_ts.__rip = (natural) handler_address;
3255  stackpp = (natural *)stackp;
3256  *--stackpp = (natural)pseudo_sigreturn;
3257  stackp = (natural)stackpp;
3258  new_ts.__rdi = signum;
3259  new_ts.__rsi = (natural)info;
3260  new_ts.__rdx = (natural)pseudosigcontext;
3261  new_ts.__rcx = (natural)tcr;
3262  new_ts.__r8 = (natural)old_valence;
3263  new_ts.__rsp = stackp;
3264  new_ts.__rflags = ts->__rflags;
3265#else
3266#define USER_CS 0x17
3267#define USER_DS 0x1f
3268  bzero(&new_ts, sizeof(new_ts));
3269  new_ts.__cs = ts->__cs;
3270  new_ts.__ss = ts->__ss;
3271  new_ts.__ds = ts->__ds;
3272  new_ts.__es = ts->__es;
3273  new_ts.__fs = ts->__fs;
3274  new_ts.__gs = ts->__gs;
3275
3276  new_ts.__eip = (natural)handler_address;
3277  stackpp = (natural *)stackp;
3278  *--stackpp = 0;               /* alignment */
3279  *--stackpp = 0;
3280  *--stackpp = 0;
3281  *--stackpp = (natural)old_valence;
3282  *--stackpp = (natural)tcr;
3283  *--stackpp = (natural)pseudosigcontext;
3284  *--stackpp = (natural)info;
3285  *--stackpp = (natural)signum;
3286  *--stackpp = (natural)pseudo_sigreturn;
3287  stackp = (natural)stackpp;
3288  new_ts.__esp = stackp;
3289  new_ts.__eflags = ts->__eflags;
3290#endif
3291
3292#ifdef X8664
3293  thread_set_state(thread,
3294                   x86_THREAD_STATE64,
3295                   (thread_state_t)&new_ts,
3296                   x86_THREAD_STATE64_COUNT);
3297#else
3298  thread_set_state(thread, 
3299                   x86_THREAD_STATE32,
3300                   (thread_state_t)&new_ts,
3301                   x86_THREAD_STATE32_COUNT);
3302#endif
3303#ifdef DEBUG_MACH_EXCEPTIONS
3304  fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
3305#endif
3306  return 0;
3307}
3308
3309
3310
3311
3312
3313
3314/*
3315  This function runs in the exception handling thread.  It's
3316  called (by this precise name) from the library function "exc_server()"
3317  when the thread's exception ports are set up.  (exc_server() is called
3318  via mach_msg_server(), which is a function that waits for and dispatches
3319  on exception messages from the Mach kernel.)
3320
3321  This checks to see if the exception was caused by a pseudo_sigreturn()
3322  UUO; if so, it arranges for the thread to have its state restored
3323  from the specified context.
3324
3325  Otherwise, it tries to map the exception to a signal number and
3326  arranges that the thread run a "pseudo signal handler" to handle
3327  the exception.
3328
3329  Some exceptions could and should be handled here directly.
3330*/
3331
3332/* We need the thread's state earlier on x86_64 than we did on PPC;
3333   the PC won't fit in code_vector[1].  We shouldn't try to get it
3334   lazily (via catch_exception_raise_state()); until we own the
3335   exception lock, we shouldn't have it in userspace (since a GCing
3336   thread wouldn't know that we had our hands on it.)
3337*/
3338
3339#ifdef X8664
3340#define ts_pc(t) t.__rip
3341#else
3342#define ts_pc(t) t.__eip
3343#endif
3344
3345
3346#define DARWIN_EXCEPTION_HANDLER signal_handler
3347
3348
3349kern_return_t
3350catch_exception_raise(mach_port_t exception_port,
3351                      mach_port_t thread,
3352                      mach_port_t task, 
3353                      exception_type_t exception,
3354                      exception_data_t code_vector,
3355                      mach_msg_type_number_t code_count)
3356{
3357  int signum = 0, code = *code_vector;
3358  TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port);
3359  kern_return_t kret, call_kret;
3360#ifdef X8664
3361  x86_thread_state64_t ts;
3362#else
3363  x86_thread_state32_t ts;
3364#endif
3365  mach_msg_type_number_t thread_state_count;
3366
3367
3368
3369
3370#ifdef DEBUG_MACH_EXCEPTIONS
3371  fprintf(dbgout, "obtaining Mach exception lock in exception thread\n");
3372#endif
3373
3374
3375  if (1) {
3376#ifdef X8664
3377    do {
3378      thread_state_count = x86_THREAD_STATE64_COUNT;
3379      call_kret = thread_get_state(thread,
3380                                   x86_THREAD_STATE64,
3381                                   (thread_state_t)&ts,
3382                                   &thread_state_count);
3383    } while (call_kret == KERN_ABORTED);
3384  MACH_CHECK_ERROR("getting thread state",call_kret);
3385#else
3386    thread_state_count = x86_THREAD_STATE32_COUNT;
3387    call_kret = thread_get_state(thread,
3388                                 x86_THREAD_STATE32,
3389                                 (thread_state_t)&ts,
3390                                 &thread_state_count);
3391    MACH_CHECK_ERROR("getting thread state",call_kret);
3392#endif
3393    if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_EXCEPTION)) {
3394      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_EXCEPTION);
3395    } 
3396    if ((code == EXC_I386_GPFLT) &&
3397        ((natural)(ts_pc(ts)) == (natural)pseudo_sigreturn)) {
3398      kret = do_pseudo_sigreturn(thread, tcr);
3399#if 0
3400      fprintf(dbgout, "Exception return in 0x%x\n",tcr);
3401#endif
3402    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
3403      CLR_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
3404      kret = 17;
3405    } else {
3406      switch (exception) {
3407      case EXC_BAD_ACCESS:
3408        if (code == EXC_I386_GPFLT) {
3409          signum = SIGSEGV;
3410        } else {
3411          signum = SIGBUS;
3412        }
3413        break;
3414       
3415      case EXC_BAD_INSTRUCTION:
3416        if (code == EXC_I386_GPFLT) {
3417          signum = SIGSEGV;
3418        } else {
3419          signum = SIGILL;
3420        }
3421        break;
3422         
3423      case EXC_SOFTWARE:
3424        signum = SIGILL;
3425        break;
3426       
3427      case EXC_ARITHMETIC:
3428        signum = SIGFPE;
3429        if (code == EXC_I386_DIV)
3430          code = FPE_INTDIV;
3431        break;
3432       
3433      default:
3434        break;
3435      }
3436#if WORD_SIZE==64
3437      if ((signum==SIGFPE) && 
3438          (code != FPE_INTDIV) && 
3439          (tcr->valence != TCR_STATE_LISP)) {
3440        mach_msg_type_number_t thread_state_count = x86_FLOAT_STATE64_COUNT;
3441        x86_float_state64_t fs;
3442
3443        thread_get_state(thread,
3444                         x86_FLOAT_STATE64,
3445                         (thread_state_t)&fs,
3446                         &thread_state_count);
3447       
3448        if (! (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN_FPE))) {
3449          tcr->flags |= (1<<TCR_FLAG_BIT_FOREIGN_FPE);
3450          tcr->lisp_mxcsr = (fs.__fpu_mxcsr & ~MXCSR_STATUS_MASK);
3451        }
3452        fs.__fpu_mxcsr &= ~MXCSR_STATUS_MASK;
3453        fs.__fpu_mxcsr |= MXCSR_CONTROL_MASK;
3454        thread_set_state(thread,
3455                         x86_FLOAT_STATE64,
3456                         (thread_state_t)&fs,
3457                         x86_FLOAT_STATE64_COUNT);
3458        return 0;
3459      }
3460#endif
3461      if (signum) {
3462        kret = setup_signal_frame(thread,
3463                                  (void *)DARWIN_EXCEPTION_HANDLER,
3464                                  signum,
3465                                  code,
3466                                  tcr, 
3467                                  &ts);
3468#if 0
3469        fprintf(dbgout, "Setup pseudosignal handling in 0x%x\n",tcr);
3470#endif
3471       
3472      } else {
3473        kret = 17;
3474      }
3475    }
3476  }
3477  return kret;
3478}
3479
3480
3481
3482
3483static mach_port_t mach_exception_thread = (mach_port_t)0;
3484
3485
3486/*
3487  The initial function for an exception-handling thread.
3488*/
3489
3490void *
3491exception_handler_proc(void *arg)
3492{
3493  extern boolean_t exc_server();
3494  mach_port_t p = TCR_TO_EXCEPTION_PORT(arg);
3495
3496  mach_exception_thread = pthread_mach_thread_np(pthread_self());
3497  mach_msg_server(exc_server, 256, p, 0);
3498  /* Should never return. */
3499  abort();
3500}
3501
3502
3503
3504void
3505mach_exception_thread_shutdown()
3506{
3507  kern_return_t kret;
3508
3509  fprintf(dbgout, "terminating Mach exception thread, 'cause exit can't\n");
3510  kret = thread_terminate(mach_exception_thread);
3511  if (kret != KERN_SUCCESS) {
3512    fprintf(dbgout, "Couldn't terminate exception thread, kret = %d\n",kret);
3513  }
3514}
3515
3516
3517mach_port_t
3518mach_exception_port_set()
3519{
3520  static mach_port_t __exception_port_set = MACH_PORT_NULL;
3521  kern_return_t kret; 
3522  if (__exception_port_set == MACH_PORT_NULL) {
3523
3524    kret = mach_port_allocate(mach_task_self(),
3525                              MACH_PORT_RIGHT_PORT_SET,
3526                              &__exception_port_set);
3527    MACH_CHECK_ERROR("allocating thread exception_ports",kret);
3528    create_system_thread(0,
3529                         NULL,
3530                         exception_handler_proc, 
3531                         (void *)((natural)__exception_port_set));
3532  }
3533  return __exception_port_set;
3534}
3535
3536/*
3537  Setup a new thread to handle those exceptions specified by
3538  the mask "which".  This involves creating a special Mach
3539  message port, telling the Mach kernel to send exception
3540  messages for the calling thread to that port, and setting
3541  up a handler thread which listens for and responds to
3542  those messages.
3543
3544*/
3545
3546/*
3547  Establish the lisp thread's TCR as its exception port, and determine
3548  whether any other ports have been established by foreign code for
3549  exceptions that lisp cares about.
3550
3551  If this happens at all, it should happen on return from foreign
3552  code and on entry to lisp code via a callback.
3553
3554  This is a lot of trouble (and overhead) to support Java, or other
3555  embeddable systems that clobber their caller's thread exception ports.
3556 
3557*/
3558kern_return_t
3559tcr_establish_exception_port(TCR *tcr, mach_port_t thread)
3560{
3561  kern_return_t kret;
3562  MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info;
3563  int i;
3564  unsigned n = NUM_LISP_EXCEPTIONS_HANDLED;
3565  mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port;
3566  exception_mask_t mask = 0;
3567
3568  kret = thread_swap_exception_ports(thread,
3569                                     LISP_EXCEPTIONS_HANDLED_MASK,
3570                                     lisp_port,
3571                                     EXCEPTION_DEFAULT,
3572                                     THREAD_STATE_NONE,
3573                                     fxs->masks,
3574                                     &n,
3575                                     fxs->ports,
3576                                     fxs->behaviors,
3577                                     fxs->flavors);
3578  if (kret == KERN_SUCCESS) {
3579    fxs->foreign_exception_port_count = n;
3580    for (i = 0; i < n; i ++) {
3581      foreign_port = fxs->ports[i];
3582
3583      if ((foreign_port != lisp_port) &&
3584          (foreign_port != MACH_PORT_NULL)) {
3585        mask |= fxs->masks[i];
3586      }
3587    }
3588    tcr->foreign_exception_status = (int) mask;
3589  }
3590  return kret;
3591}
3592
3593kern_return_t
3594tcr_establish_lisp_exception_port(TCR *tcr)
3595{
3596  return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id));
3597}
3598
3599/*
3600  Do this when calling out to or returning from foreign code, if
3601  any conflicting foreign exception ports were established when we
3602  last entered lisp code.
3603*/
3604kern_return_t
3605restore_foreign_exception_ports(TCR *tcr)
3606{
3607  exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status;
3608 
3609  if (m) {
3610    MACH_foreign_exception_state *fxs  = 
3611      (MACH_foreign_exception_state *) tcr->native_thread_info;
3612    int i, n = fxs->foreign_exception_port_count;
3613    exception_mask_t tm;
3614
3615    for (i = 0; i < n; i++) {
3616      if ((tm = fxs->masks[i]) & m) {
3617        thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id),
3618                                   tm,
3619                                   fxs->ports[i],
3620                                   fxs->behaviors[i],
3621                                   fxs->flavors[i]);
3622      }
3623    }
3624  }
3625}
3626                                   
3627
3628/*
3629  This assumes that a Mach port (to be used as the thread's exception port) whose
3630  "name" matches the TCR's 32-bit address has already been allocated.
3631*/
3632
3633kern_return_t
3634setup_mach_exception_handling(TCR *tcr)
3635{
3636  mach_port_t
3637    thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr),
3638    task_self = mach_task_self();
3639  kern_return_t kret;
3640
3641  kret = mach_port_insert_right(task_self,
3642                                thread_exception_port,
3643                                thread_exception_port,
3644                                MACH_MSG_TYPE_MAKE_SEND);
3645  MACH_CHECK_ERROR("adding send right to exception_port",kret);
3646
3647  kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id));
3648  if (kret == KERN_SUCCESS) {
3649    mach_port_t exception_port_set = mach_exception_port_set();
3650
3651    kret = mach_port_move_member(task_self,
3652                                 thread_exception_port,
3653                                 exception_port_set);
3654  }
3655  return kret;
3656}
3657
3658void
3659darwin_exception_init(TCR *tcr)
3660{
3661  void tcr_monitor_exception_handling(TCR*, Boolean);
3662  kern_return_t kret;
3663  MACH_foreign_exception_state *fxs = 
3664    calloc(1, sizeof(MACH_foreign_exception_state));
3665 
3666  tcr->native_thread_info = (void *) fxs;
3667
3668  if ((kret = setup_mach_exception_handling(tcr))
3669      != KERN_SUCCESS) {
3670    fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret);
3671    terminate_lisp();
3672  }
3673}
3674
3675/*
3676  The tcr is the "name" of the corresponding thread's exception port.
3677  Destroying the port should remove it from all port sets of which it's
3678  a member (notably, the exception port set.)
3679*/
3680void
3681darwin_exception_cleanup(TCR *tcr)
3682{
3683  void *fxs = tcr->native_thread_info;
3684  extern Boolean use_mach_exception_handling;
3685
3686  if (fxs) {
3687    tcr->native_thread_info = NULL;
3688    free(fxs);
3689  }
3690  if (use_mach_exception_handling) {
3691    mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3692    mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr));
3693  }
3694}
3695
3696
3697Boolean
3698suspend_mach_thread(mach_port_t mach_thread)
3699{
3700  kern_return_t status;
3701  Boolean aborted = false;
3702 
3703  do {
3704    aborted = false;
3705    status = thread_suspend(mach_thread);
3706    if (status == KERN_SUCCESS) {
3707      status = thread_abort_safely(mach_thread);
3708      if (status == KERN_SUCCESS) {
3709        aborted = true;
3710      } else {
3711        fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread);
3712        thread_resume(mach_thread);
3713      }
3714    } else {
3715      return false;
3716    }
3717  } while (! aborted);
3718  return true;
3719}
3720
3721/*
3722  Only do this if pthread_kill indicated that the pthread isn't
3723  listening to signals anymore, as can happen as soon as pthread_exit()
3724  is called on Darwin.  The thread could still call out to lisp as it
3725  is exiting, so we need another way to suspend it in this case.
3726*/
3727Boolean
3728mach_suspend_tcr(TCR *tcr)
3729{
3730  mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id));
3731  ExceptionInformation *pseudosigcontext;
3732  Boolean result = false;
3733 
3734  result = suspend_mach_thread(mach_thread);
3735  if (result) {
3736    mach_msg_type_number_t thread_state_count;
3737#ifdef X8664
3738    x86_thread_state64_t ts;
3739    thread_state_count = x86_THREAD_STATE64_COUNT;
3740    thread_get_state(mach_thread,
3741                     x86_THREAD_STATE64,
3742                     (thread_state_t)&ts,
3743                     &thread_state_count);
3744#else
3745    x86_thread_state32_t ts;
3746    thread_state_count = x86_THREAD_STATE_COUNT;
3747    thread_get_state(mach_thread,
3748                     x86_THREAD_STATE,
3749                     (thread_state_t)&ts,
3750                     &thread_state_count);
3751#endif
3752
3753    pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts);
3754    pseudosigcontext->uc_onstack = 0;
3755    pseudosigcontext->uc_sigmask = (sigset_t) 0;
3756    tcr->suspend_context = pseudosigcontext;
3757  }
3758  return result;
3759}
3760
3761void
3762mach_resume_tcr(TCR *tcr)
3763{
3764  ExceptionInformation *xp;
3765  mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id));
3766 
3767  xp = tcr->suspend_context;
3768#ifdef DEBUG_MACH_EXCEPTIONS
3769  fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
3770          tcr, tcr->pending_exception_context);
3771#endif
3772  tcr->suspend_context = NULL;
3773  restore_mach_thread_state(mach_thread, xp);
3774#ifdef DEBUG_MACH_EXCEPTIONS
3775  fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
3776          tcr, tcr->pending_exception_context);
3777#endif
3778  thread_resume(mach_thread);
3779}
3780
3781void
3782fatal_mach_error(char *format, ...)
3783{
3784  va_list args;
3785  char s[512];
3786 
3787
3788  va_start(args, format);
3789  vsnprintf(s, sizeof(s),format, args);
3790  va_end(args);
3791
3792  Fatal("Mach error", s);
3793}
3794
3795
3796
3797
3798#endif
3799
3800/* watchpoint stuff */
3801
3802area *
3803new_watched_area(natural size)
3804{
3805  char *p;
3806
3807  p = MapMemory(NULL, size, MEMPROTECT_RWX);
3808  if ((signed_natural)p == -1) {
3809    allocation_failure(true, size);
3810  }
3811  return new_area(p, p + size, AREA_WATCHED);
3812}
3813
3814void
3815delete_watched_area(area *a, TCR *tcr)
3816{
3817  natural nbytes = a->high - a->low;
3818  char *base = a->low;
3819
3820  condemn_area_holding_area_lock(a);
3821
3822  if (nbytes) {
3823    int err;
3824
3825    err = UnMapMemory(base, nbytes);
3826    if (err != 0)
3827      Fatal("munmap in delete_watched_area", "");
3828  }
3829}
3830
3831natural
3832uvector_total_size_in_bytes(LispObj *u)
3833{
3834  LispObj header = header_of(u);
3835  natural header_tag = fulltag_of(header);
3836  natural subtag = header_subtag(header);
3837  natural element_count = header_element_count(header);
3838  natural nbytes = 0;
3839
3840#ifdef X8632
3841  if ((nodeheader_tag_p(header_tag)) ||
3842      (subtag <= max_32_bit_ivector_subtag)) {
3843    nbytes = element_count << 2;
3844  } else if (subtag <= max_8_bit_ivector_subtag) {
3845    nbytes = element_count;
3846  } else if (subtag <= max_16_bit_ivector_subtag) {
3847    nbytes = element_count << 1;
3848  } else if (subtag == subtag_double_float_vector) {
3849    nbytes = element_count << 3;
3850  } else {
3851    nbytes = (element_count + 7) >> 3;
3852  }
3853  /* add 4 byte header and round up to multiple of 8 bytes */
3854  return ~7 & (4 + nbytes + 7);
3855#endif
3856#ifdef X8664
3857  if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) {
3858    nbytes = element_count << 3;
3859  } else if (header_tag == ivector_class_32_bit) {
3860    nbytes = element_count << 2;
3861  } else {
3862    /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */
3863    if (subtag == subtag_bit_vector) {
3864      nbytes = (element_count + 7) >> 3;
3865    } else if (subtag >= min_8_bit_ivector_subtag) {
3866      nbytes = element_count;
3867    } else {
3868      nbytes = element_count << 1;
3869    }
3870  }
3871  /* add 8 byte header and round up to multiple of 16 bytes */
3872  return ~15 & (8 + nbytes + 15);
3873#endif
3874}
3875
3876extern void wp_update_references(TCR *, LispObj, LispObj);
3877
3878/*
3879 * Other threads are suspended and pc-lusered.
3880 *
3881 * param contains a tagged pointer to a uvector or a cons cell
3882 */
3883signed_natural
3884watch_object(TCR *tcr, signed_natural param)
3885{
3886  LispObj object = (LispObj)param;
3887  unsigned tag = fulltag_of(object);
3888  LispObj *noderef = (LispObj *)untag(object);
3889  area *object_area = area_containing((BytePtr)noderef);
3890  natural size;
3891
3892  if (tag == fulltag_cons)
3893    size = 2 * node_size;
3894  else
3895    size = uvector_total_size_in_bytes(noderef);
3896
3897  if (object_area && object_area->code == AREA_DYNAMIC) {
3898    area *a = new_watched_area(size);
3899    LispObj old = object;
3900    LispObj new = (LispObj)((natural)a->low + tag);
3901
3902    add_area_holding_area_lock(a);
3903
3904    /* move object to watched area */
3905    memcpy(a->low, noderef, size);
3906    ProtectMemory(a->low, size);
3907    memset(noderef, 0, size);
3908    wp_update_references(tcr, old, new);
3909    check_all_areas(tcr);
3910    return 1;
3911  }
3912  return 0;
3913}
3914
3915/*
3916 * We expect the watched object in arg_y, and the new uninitialized
3917 * object (which is just zeroed) in arg_z.
3918 */
3919signed_natural
3920unwatch_object(TCR *tcr, signed_natural param)
3921{
3922  ExceptionInformation *xp = tcr->xframe->curr;
3923  LispObj old = xpGPR(xp, Iarg_y);
3924  unsigned tag = fulltag_of(old);
3925  LispObj new = xpGPR(xp, Iarg_z);
3926  LispObj *oldnode = (LispObj *)untag(old);
3927  LispObj *newnode = (LispObj *)untag(new);
3928  area *a = area_containing((BytePtr)old);
3929  extern void update_managed_refs(area *, BytePtr, natural);
3930
3931  if (a && a->code == AREA_WATCHED) {
3932    natural size;
3933
3934    if (tag == fulltag_cons)
3935      size = 2 * node_size;
3936    else
3937      size = uvector_total_size_in_bytes(oldnode);
3938
3939    memcpy(newnode, oldnode, size);
3940    delete_watched_area(a, tcr);
3941    wp_update_references(tcr, old, new);
3942    /* because wp_update_references doesn't update refbits */
3943    tenure_to_area(tenured_area);
3944    /* Unwatching can (re-)introduce managed_static->dynamic references */
3945    zero_bits(managed_static_area->refbits,managed_static_area->ndnodes);
3946    update_managed_refs(managed_static_area, low_markable_address, area_dnode(active_dynamic_area->active, low_markable_address));
3947    check_all_areas(tcr);
3948    xpGPR(xp, Iarg_z) = new;
3949  }
3950  return 0;
3951}
3952
3953Boolean
3954handle_watch_trap(ExceptionInformation *xp, TCR *tcr)
3955{
3956  LispObj selector = xpGPR(xp,Iimm0);
3957  LispObj object = xpGPR(xp, Iarg_z);
3958  signed_natural result;
3959 
3960  switch (selector) {
3961    case WATCH_TRAP_FUNCTION_WATCH:
3962      result = gc_like_from_xp(xp, watch_object, object);
3963      if (result == 0)
3964        xpGPR(xp,Iarg_z) = lisp_nil;
3965      break;
3966    case WATCH_TRAP_FUNCTION_UNWATCH:
3967      gc_like_from_xp(xp, unwatch_object, 0);
3968      break;
3969    default:
3970      break;
3971  }
3972  return true;
3973}
3974
Note: See TracBrowser for help on using the repository browser.