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

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

Merge r14962 from trunk.

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