source: branches/gb-egc/lisp-kernel/x86-exceptions.c @ 15831

Last change on this file since 15831 was 15831, checked in by gb, 8 years ago

Zero dnodes when allocating segments, not in GC.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 83.2 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 "x86-utils.h"
21#include "threads.h"
22#include <ctype.h>
23#include <stdio.h>
24#include <stddef.h>
25#include <string.h>
26#include <stdarg.h>
27#include <errno.h>
28#include <stdio.h>
29#ifdef LINUX
30#include <strings.h>
31#include <sys/mman.h>
32#include <fpu_control.h>
33#include <linux/prctl.h>
34#endif
35#ifdef DARWIN
36#include <sysexits.h>
37#endif
38#ifndef WINDOWS
39#include <sys/syslog.h>
40#endif
41#ifdef WINDOWS
42#include <windows.h>
43#ifdef WIN_64
44#include <winternl.h>
45#include <ntstatus.h>
46#endif
47#ifndef EXCEPTION_WRITE_FAULT
48#define EXCEPTION_WRITE_FAULT 1
49#endif
50#endif
51
52/*
53  We do all kinds of funky things to avoid handling a signal on the lisp
54  stack.  One of those funky things involves using the  __builtin_return_address()
55  intrinsic so that the real handler returns to the right place when it exits,
56  even if it returns on a different stack.  Code at "the right place" is presumed
57  to just do a sigrereturn, however the OS does that.
58
59  Sadly, some JVMs (at least) do what they call "signal chaining": they install
60  their own handlers for signals that we expect to handle, and call our handler
61  when they realize that they don't know how to handle what we raise.  They
62  don't observe sigaltstack, and they don't necessarily do call our handler
63  tail-recursively (so our stack-switching code would cause our handler to
64  return to the JVM's, running on the wrong stack.
65
66  Try to work around this by setting up an "early" signal handler (before any
67  of this JVM nonsense can take effect) and noting the address it'd return to.
68*/
69
70pc
71real_sigreturn = (pc)0;
72
73#define SIGRETURN_ADDRESS() (real_sigreturn ? real_sigreturn : __builtin_return_address(0))
74
75#ifndef WINDOWS
76#ifndef DARWIN
77void
78early_intn_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
79{
80  real_sigreturn = (pc) __builtin_return_address(0);
81  xpPC(xp) += 2;
82}
83
84#endif
85#endif
86
87void
88do_intn()
89{
90  __asm volatile("int $0xcd");
91}
92
93
94void
95x86_early_exception_init()
96{
97#ifndef WINDOWS
98#ifndef DARWIN
99  struct sigaction action, oaction;
100
101  action.sa_sigaction = (void *) early_intn_handler;
102  sigfillset(&action.sa_mask);
103  action.sa_flags = SA_SIGINFO;
104  sigaction(SIGNUM_FOR_INTN_TRAP,&action,&oaction);
105 
106  do_intn();
107  sigaction(SIGNUM_FOR_INTN_TRAP,&oaction, NULL);
108#endif
109#endif
110}
111
112int
113page_size = 4096;
114
115int
116log2_page_size = 12;
117
118Boolean
119did_gc_notification_since_last_full_gc = false;
120
121
122void
123update_bytes_allocated(TCR* tcr, void *cur_allocptr)
124{
125  char *last = tcr->last_allocptr;
126  char *current = cur_allocptr;
127  u64_t *bytes_allocated = (u64_t *)&TCR_AUX(tcr)->bytes_allocated;
128
129  if (last && (tcr->save_allocbase != ((void *)VOID_ALLOCPTR))) {
130    *bytes_allocated += last - current;
131  }
132  tcr->last_allocptr = 0;
133}
134
135
136
137//  This doesn't GC; it returns true if it made enough room, false
138//  otherwise.
139//  If "extend" is true, it can try to extend the dynamic area to
140//  satisfy the request.
141
142
143
144void
145platform_new_heap_segment(ExceptionInformation *xp, TCR *tcr, BytePtr low, BytePtr high)
146{
147  tcr->last_allocptr = (void *)high;
148  tcr->save_allocptr = (void *)high;
149  xpGPR(xp,Iallocptr) = (LispObj) high;
150  tcr->save_allocbase = (void *) low;
151}
152
153Boolean
154allocate_object(ExceptionInformation *xp,
155                natural bytes_needed, 
156                signed_natural disp_from_allocptr,
157                TCR *tcr,
158                Boolean *crossed_threshold)
159{
160  area *a = active_dynamic_area;
161
162  /* Maybe do an EGC */
163  if (a->older && lisp_global(OLDEST_EPHEMERAL)) {
164    if (((a->active)-(a->low)) >= a->threshold) {
165      gc_from_xp(xp, 0L);
166    }
167  }
168
169  /* Life is pretty simple if we can simply grab a segment
170     without extending the heap.
171  */
172  if (new_heap_segment(xp, bytes_needed, false, tcr, crossed_threshold)) {
173    xpGPR(xp, Iallocptr) -= disp_from_allocptr;
174    tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr));
175    return true;
176  }
177 
178  /* It doesn't make sense to try a full GC if the object
179     we're trying to allocate is larger than everything
180     allocated so far.
181  */
182  if ((lisp_global(HEAP_END)-lisp_global(HEAP_START)) > bytes_needed) {
183    untenure_from_area(tenured_area); /* force a full GC */
184    gc_from_xp(xp, 0L);
185    did_gc_notification_since_last_full_gc = false;
186  }
187 
188  /* Try again, growing the heap if necessary */
189  if (new_heap_segment(xp, bytes_needed, true, tcr, NULL)) {
190    xpGPR(xp, Iallocptr) -= disp_from_allocptr;
191    tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr));
192    return true;
193  }
194 
195  return false;
196}
197
198natural gc_deferred = 0, full_gc_deferred = 0;
199
200signed_natural
201flash_freeze(TCR *tcr, signed_natural param)
202{
203  return 0;
204}
205
206
207Boolean
208handle_gc_trap(ExceptionInformation *xp, TCR *tcr)
209{
210  LispObj selector = xpGPR(xp,Iimm0);
211#ifdef X8664
212  LispObj arg = xpGPR(xp,Iimm1);
213#else
214  LispObj arg = xpMMXreg(xp,Imm0);
215#endif
216  area *a = active_dynamic_area;
217  Boolean egc_was_enabled = (a->older != NULL);
218 
219  natural gc_previously_deferred = gc_deferred;
220
221  switch (selector) {
222  case GC_TRAP_FUNCTION_EGC_CONTROL:
223    egc_control(arg != 0, a->active);
224    xpGPR(xp,Iarg_z) = lisp_nil + (egc_was_enabled ? t_offset : 0);
225    break;
226
227  case GC_TRAP_FUNCTION_CONFIGURE_EGC:
228#ifdef X8664
229    a->threshold = unbox_fixnum(xpGPR(xp, Iarg_x));
230#else
231    a->threshold = unbox_fixnum(xpGPR(xp, Itemp0));
232#endif
233    g1_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_y));
234    g2_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_z));
235    xpGPR(xp,Iarg_z) = lisp_nil+t_offset;
236    break;
237
238  case GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD:
239    if (((signed_natural) arg) > 0) {
240      lisp_heap_gc_threshold = 
241        align_to_power_of_2((arg-1) +
242                            (heap_segment_size - 1),
243                            log2_heap_segment_size);
244    }
245    /* fall through */
246  case GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD:
247    xpGPR(xp, Iimm0) = lisp_heap_gc_threshold;
248    break;
249
250  case GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD:
251    /*  Try to put the current threshold in effect.  This may
252        need to disable/reenable the EGC. */
253    untenure_from_area(tenured_area);
254    resize_dynamic_heap(a->active,lisp_heap_gc_threshold);
255    if (egc_was_enabled) {
256      if ((a->high - a->active) >= a->threshold) {
257        tenure_to_area(tenured_area);
258      }
259    }
260    xpGPR(xp, Iimm0) = lisp_heap_gc_threshold;
261    break;
262
263  case GC_TRAP_FUNCTION_SET_GC_NOTIFICATION_THRESHOLD:
264    if ((signed_natural)arg >= 0) {
265      lisp_heap_notify_threshold = arg;
266      did_gc_notification_since_last_full_gc = false;
267    }
268    /* fall through */
269
270  case GC_TRAP_FUNCTION_GET_GC_NOTIFICATION_THRESHOLD:
271    xpGPR(xp, Iimm0) = lisp_heap_notify_threshold;
272    break;
273
274  case GC_TRAP_FUNCTION_ENSURE_STATIC_CONSES:
275    ensure_static_conses(xp, tcr, 32768);
276    break;
277
278  case GC_TRAP_FUNCTION_FLASH_FREEZE: /* Like freeze below, but no GC */
279    untenure_from_area(tenured_area);
280    gc_like_from_xp(xp,flash_freeze,0);
281    a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size);
282    tenured_area->static_dnodes = area_dnode(a->active, a->low);
283    if (egc_was_enabled) {
284      tenure_to_area(tenured_area);
285    }
286    xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift;
287    break;
288
289  default:
290    update_bytes_allocated(tcr, (void *) tcr->save_allocptr);
291
292    if (selector == GC_TRAP_FUNCTION_IMMEDIATE_GC) {
293      if (!full_gc_deferred) {
294        gc_from_xp(xp, 0L);
295        did_gc_notification_since_last_full_gc = false;
296        break;
297      }
298      /* Tried to do a full GC when gc was disabled.  That failed,
299         so try full GC now */
300      selector = GC_TRAP_FUNCTION_GC;
301    }
302   
303    if (egc_was_enabled) {
304      egc_control(false, (BytePtr) a->active);
305    }
306    gc_from_xp(xp, 0L);
307    did_gc_notification_since_last_full_gc = false;
308    if (gc_deferred > gc_previously_deferred) {
309      full_gc_deferred = 1;
310    } else {
311      full_gc_deferred = 0;
312    }
313    if (selector > GC_TRAP_FUNCTION_GC) {
314      if (selector & GC_TRAP_FUNCTION_IMPURIFY) {
315        impurify_from_xp(xp, 0L);
316        /*        nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */
317        lisp_global(OLDSPACE_DNODE_COUNT) = 0;
318        gc_from_xp(xp, 0L);
319      }
320      if (selector & GC_TRAP_FUNCTION_PURIFY) {
321        purify_from_xp(xp, 1);
322        lisp_global(OLDSPACE_DNODE_COUNT) = 0;
323        gc_from_xp(xp, 0L);
324      }
325      if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) {
326        OSErr err;
327        extern OSErr save_application(int, Boolean);
328        area *vsarea = tcr->vs_area;
329
330#ifdef WINDOWS 
331        arg = _open_osfhandle(arg,0);
332#endif
333        nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1);
334        err = save_application((int)arg, egc_was_enabled);
335        if (err == noErr) {
336          _exit(0);
337        }
338        fatal_oserr(": save_application", err);
339      }
340      switch (selector) {
341      case GC_TRAP_FUNCTION_FREEZE:
342        a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size);
343        tenured_area->static_dnodes = area_dnode(a->active, a->low);
344        xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift;
345        break;
346      default:
347        break;
348      }
349    }
350    if (egc_was_enabled) {
351      egc_control(true, NULL);
352    }
353    break;
354  }
355  return true;
356}
357
358 
359
360
361
362void
363push_on_lisp_stack(ExceptionInformation *xp, LispObj value)
364{
365  LispObj *vsp = (LispObj *)xpGPR(xp,Isp);
366  *--vsp = value;
367  xpGPR(xp,Isp) = (LispObj)vsp;
368}
369
370
371/* Hard to know if or whether this is necessary in general.  For now,
372   do it when we get a "wrong number of arguments" trap.
373*/
374void
375finish_function_entry(ExceptionInformation *xp)
376{
377  natural nargs = xpGPR(xp,Inargs)>>fixnumshift;
378  signed_natural disp = nargs - nargregs;
379  LispObj *vsp =  (LispObj *) xpGPR(xp,Isp), ra = *vsp++;
380   
381  xpGPR(xp,Isp) = (LispObj) vsp;
382
383  if (disp > 0) {               /* implies that nargs > nargregs */
384    vsp[disp] = xpGPR(xp,Ifp);
385    vsp[disp+1] = ra;
386    xpGPR(xp,Ifp) = (LispObj)(vsp+disp);
387#ifdef X8664
388    push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
389#endif
390    push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
391    push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
392  } else {
393    push_on_lisp_stack(xp,ra);
394    push_on_lisp_stack(xp,xpGPR(xp,Ifp));
395    xpGPR(xp,Ifp) = xpGPR(xp,Isp);
396#ifdef X8664
397    if (nargs == 3) {
398      push_on_lisp_stack(xp,xpGPR(xp,Iarg_x));
399    }
400#endif
401    if (nargs >= 2) {
402      push_on_lisp_stack(xp,xpGPR(xp,Iarg_y));
403    }
404    if (nargs >= 1) {
405      push_on_lisp_stack(xp,xpGPR(xp,Iarg_z));
406    }
407  }
408}
409
410Boolean
411object_contains_pc(LispObj container, LispObj addr)
412{
413  if (fulltag_of(container) >= fulltag_misc) {
414    natural elements = header_element_count(header_of(container));
415    if ((addr >= container) &&
416        (addr < ((LispObj)&(deref(container,1+elements))))) {
417      return true;
418    }
419  }
420  return false;
421}
422
423LispObj
424create_exception_callback_frame(ExceptionInformation *xp, TCR *tcr)
425{
426  LispObj containing_uvector = 0, 
427    relative_pc = lisp_nil,
428    nominal_function = lisp_nil, 
429    f, tra, tra_f = 0, abs_pc;
430  LispObj pc_low, pc_high;
431
432  f = xpGPR(xp,Ifn);
433  tra = *(LispObj*)(xpGPR(xp,Isp));
434  if (tra_p(tra)) {
435    char *p = (char *)tra;
436    extern char *spentry_start, *spentry_end;
437
438    if (ptr_in_area(p, tcr->ts_area) ||
439        (p > spentry_start && p < spentry_end) ||
440        in_any_consing_area(tra))
441      tra_f = tra_function(tra);
442    else
443      Bug(xp, "martian tra %p\n", tra);
444  }
445  abs_pc = (LispObj)xpPC(xp);
446#if WORD_SIZE == 64
447  pc_high = ((abs_pc >> 32) & 0xffffffff) << fixnumshift;
448  pc_low = (abs_pc & 0xffffffff) << fixnumshift;
449#else
450  pc_high = ((abs_pc >> 16) & 0xffff) << fixnumshift;
451  pc_low = (abs_pc & 0xffff) << fixnumshift;
452#endif
453
454
455  if (functionp(f))
456    nominal_function = f;
457  else if (tra_f)
458    nominal_function = tra_f;
459 
460  f = xpGPR(xp,Ifn);
461  if (object_contains_pc(f, abs_pc)) {
462    containing_uvector = untag(f)+fulltag_misc;
463  } else {
464    f = xpGPR(xp,Ixfn);
465    if (object_contains_pc(f, abs_pc)) {
466      containing_uvector = untag(f)+fulltag_misc;
467    } else {
468      if (tra_f) {
469        f = tra_f;
470        if (object_contains_pc(f, abs_pc)) {
471          containing_uvector = untag(f)+fulltag_misc;
472          relative_pc = (abs_pc - f) << fixnumshift;
473        }
474      }
475    }
476  }
477  if (containing_uvector) {
478    relative_pc = (abs_pc - (LispObj)&(deref(containing_uvector,1))) << fixnumshift;
479  } else {
480    containing_uvector = lisp_nil;
481  }
482  push_on_lisp_stack(xp, pc_high);
483  push_on_lisp_stack(xp, pc_low);
484  push_on_lisp_stack(xp,(LispObj)(tcr->xframe->prev));
485  push_on_lisp_stack(xp,(LispObj)(tcr->foreign_sp));
486  push_on_lisp_stack(xp,tra);
487  push_on_lisp_stack(xp,(LispObj)xp);
488  push_on_lisp_stack(xp,containing_uvector); 
489  push_on_lisp_stack(xp,relative_pc);
490  push_on_lisp_stack(xp,nominal_function);
491  push_on_lisp_stack(xp,0);
492  push_on_lisp_stack(xp,xpGPR(xp,Ifp));
493  xpGPR(xp,Ifp) = xpGPR(xp,Isp);
494  return xpGPR(xp,Isp);
495}
496
497#ifndef XMEMFULL
498#define XMEMFULL (76)
499#endif
500
501void
502lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed )
503{
504  LispObj xcf = create_exception_callback_frame(xp, tcr),
505    cmain = nrs_CMAIN.vcell;
506  int skip;
507   
508  tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR;
509  xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
510
511  skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0);
512  xpPC(xp) += skip;
513}
514
515#ifndef SIGTRAP
516#define SIGTRAP 5
517#endif
518
519void
520callback_for_gc_notification(ExceptionInformation *xp, TCR *tcr)
521{
522  LispObj cmain = nrs_CMAIN.vcell;
523  if ((fulltag_of(cmain) == fulltag_misc) &&
524      (header_subtag(header_of(cmain)) == subtag_macptr)) {
525    LispObj *save_vsp = (LispObj *)xpGPR(xp,Isp),
526      word_beyond_vsp = save_vsp[-1],
527      save_fp = xpGPR(xp,Ifp),
528      xcf = create_exception_callback_frame(xp, tcr);
529
530    callback_to_lisp(tcr, cmain, xp, xcf, SIGTRAP, 0, 0, 0);
531    did_gc_notification_since_last_full_gc = true;
532    xpGPR(xp,Ifp) = save_fp;
533    xpGPR(xp,Isp) = (LispObj)save_vsp;
534    save_vsp[-1] = word_beyond_vsp;
535  }
536}
537
538
539/*
540  Allocate a large list, where "large" means "large enough to
541  possibly trigger the EGC several times if this was done
542  by individually allocating each CONS."  The number of
543  ocnses in question is in arg_z; on successful return,
544  the list will be in arg_z
545*/
546
547Boolean
548allocate_list(ExceptionInformation *xp, TCR *tcr)
549{
550  natural
551    nconses = (unbox_fixnum(xpGPR(xp,Iarg_z))),
552    bytes_needed = (nconses << dnode_shift);
553  LispObj
554    prev = lisp_nil,
555    current,
556    initial = xpGPR(xp,Iarg_y);
557  Boolean notify_pending_gc = false;
558
559  if (nconses == 0) {
560    /* Silly case */
561    xpGPR(xp,Iarg_z) = lisp_nil;
562    xpGPR(xp,Iallocptr) = lisp_nil;
563    return true;
564  }
565  update_bytes_allocated(tcr, (void *)tcr->save_allocptr);
566  if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr, &notify_pending_gc)) {
567    tcr->save_allocptr -= fulltag_cons;
568    for (current = xpGPR(xp,Iallocptr);
569         nconses;
570         prev = current, current+= dnode_size, nconses--) {
571      deref(current,0) = prev;
572      deref(current,1) = initial;
573    }
574    xpGPR(xp,Iarg_z) = prev;
575    if (notify_pending_gc && !did_gc_notification_since_last_full_gc) {
576      callback_for_gc_notification(xp,tcr);
577    }
578  } else {
579    lisp_allocation_failure(xp,tcr,bytes_needed);
580  }
581  return true;
582}
583
584Boolean
585handle_alloc_trap(ExceptionInformation *xp, TCR *tcr, Boolean *notify)
586{
587  natural cur_allocptr, bytes_needed;
588  unsigned allocptr_tag;
589  signed_natural disp;
590 
591  cur_allocptr = xpGPR(xp,Iallocptr);
592  allocptr_tag = fulltag_of(cur_allocptr);
593  if (allocptr_tag == fulltag_misc) {
594#ifdef X8664
595    disp = xpGPR(xp,Iimm1);
596#else
597    disp = xpGPR(xp,Iimm0);
598#endif
599  } else {
600    disp = dnode_size-fulltag_cons;
601  }
602  bytes_needed = disp+allocptr_tag;
603
604  update_bytes_allocated(tcr,((BytePtr)(cur_allocptr+disp)));
605  if (allocate_object(xp, bytes_needed, disp, tcr, notify)) {
606    if (notify && *notify) {
607      xpPC(xp)+=2;
608      /* Finish the allocation: add a header if necessary,
609         clear the tag bits in tcr.save_allocptr. */
610      pc_luser_xp(xp,tcr,NULL);
611      callback_for_gc_notification(xp,tcr);
612    }
613    return true;
614  }
615 
616  lisp_allocation_failure(xp,tcr,bytes_needed);
617
618  return true;
619}
620
621 
622int
623callback_to_lisp (TCR * tcr, LispObj callback_macptr, ExceptionInformation *xp,
624                  natural arg1, natural arg2, natural arg3, natural arg4, natural arg5)
625{
626  natural  callback_ptr;
627  int delta;
628  unsigned old_mxcsr = get_mxcsr();
629#ifdef X8632
630  natural saved_node_regs_mask = tcr->node_regs_mask;
631  natural saved_unboxed0 = tcr->unboxed0;
632  natural saved_unboxed1 = tcr->unboxed1;
633  LispObj *vsp = (LispObj *)xpGPR(xp, Isp);
634#endif
635  set_mxcsr(0x1f80);
636
637  /* Put the active stack pointers where .SPcallback expects them */
638#ifdef X8632
639  tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK;
640
641  *--vsp = tcr->save0;
642  *--vsp = tcr->save1;
643  *--vsp = tcr->save2;
644  *--vsp = tcr->save3;
645  *--vsp = tcr->next_method_context;
646  xpGPR(xp, Isp) = (LispObj)vsp;
647#endif
648  tcr->save_vsp = (LispObj *)xpGPR(xp, Isp);
649  tcr->save_fp = (LispObj *)xpGPR(xp, Ifp);
650
651  /* Call back.  The caller of this function may have modified stack/frame
652     pointers (and at least should have called prepare_for_callback()).
653  */
654  callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
655  UNLOCK(lisp_global(EXCEPTION_LOCK), tcr);
656  delta = ((int (*)())callback_ptr) (xp, arg1, arg2, arg3, arg4, arg5);
657  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
658
659#ifdef X8632
660  tcr->next_method_context = *vsp++;
661  tcr->save3 = *vsp++;
662  tcr->save2 = *vsp++;
663  tcr->save1 = *vsp++;
664  tcr->save0 = *vsp++;
665  xpGPR(xp, Isp) = (LispObj)vsp;
666
667  tcr->node_regs_mask = saved_node_regs_mask;
668  tcr->unboxed0 = saved_unboxed0;
669  tcr->unboxed1 = saved_unboxed1;
670#endif
671  set_mxcsr(old_mxcsr);
672  return delta;
673}
674
675void
676callback_for_interrupt(TCR *tcr, ExceptionInformation *xp)
677{
678  LispObj *save_vsp = (LispObj *)xpGPR(xp,Isp),
679    word_beyond_vsp = save_vsp[-1],
680    save_fp = xpGPR(xp,Ifp),
681    xcf = create_exception_callback_frame(xp, tcr);
682  int save_errno = errno;
683
684  callback_to_lisp(tcr, nrs_CMAIN.vcell,xp, xcf, 0, 0, 0, 0);
685  xpGPR(xp,Ifp) = save_fp;
686  xpGPR(xp,Isp) = (LispObj)save_vsp;
687  save_vsp[-1] = word_beyond_vsp;
688  errno = save_errno;
689}
690
691Boolean
692handle_error(TCR *tcr, ExceptionInformation *xp)
693{
694  pc program_counter = (pc)xpPC(xp);
695  unsigned char op0 = program_counter[0], op1 = program_counter[1];
696  LispObj rpc, errdisp = nrs_ERRDISP.vcell,
697    save_vsp = xpGPR(xp,Isp), xcf0,
698    save_fp = xpGPR(xp,Ifp);
699  int skip;
700
701  if ((fulltag_of(errdisp) == fulltag_misc) &&
702      (header_subtag(header_of(errdisp)) == subtag_macptr)) {
703
704    if ((op0 == 0xcd) && (op1 >= 0xc0) && (op1 <= 0xc2)) {
705      finish_function_entry(xp);
706    }
707    xcf0 = create_exception_callback_frame(xp, tcr);
708    skip = callback_to_lisp(tcr, errdisp, xp, xcf0, 0, 0, 0, 0);
709    if (skip == -1) {
710      xcf *xcf1 = (xcf *)xcf0;
711      LispObj container = xcf1->containing_uvector;
712     
713      rpc = xcf1->relative_pc >> fixnumshift;
714      if (container == lisp_nil) {
715        xpPC(xp) = rpc;
716      } else {
717        xpPC(xp) = (LispObj)(&(deref(container,
718#ifdef X8664
719                                     1
720#else
721                                     0
722#endif
723)))+rpc;
724      }
725       
726      skip = 0;
727    }
728    xpGPR(xp,Ifp) = save_fp;
729    xpGPR(xp,Isp) = save_vsp;
730    if ((op0 == 0xcd) && (op1 == 0xc7)) {
731      /* Continue after an undefined function call. The function
732         that had been undefined has already been called (in the
733         break loop), and a list of the values that it returned
734         in in the xp's %arg_z.  A function that returns those
735         values in in the xp's %fn; we just have to adjust the
736         stack (keeping the return address in the right place
737         and discarding any stack args/reserved stack frame),
738         then set nargs and the PC so that that function's
739         called when we resume.
740      */
741      LispObj *vsp =(LispObj *)save_vsp, ra = *vsp;
742      int nargs = xpGPR(xp, Inargs)>>fixnumshift;
743
744#ifdef X8664
745      if (nargs > 3) {
746        xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3)));
747        push_on_lisp_stack(xp,ra);
748      }
749#else
750      if (nargs > 2) {
751        xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 2)));
752        push_on_lisp_stack(xp,ra);
753      }
754#endif
755      xpPC(xp) = xpGPR(xp,Ifn);
756      xpGPR(xp,Inargs) = 1<<fixnumshift;
757    } else {
758      xpPC(xp) += skip;
759    }
760    return true;
761  } else {
762    return false;
763  }
764}
765
766
767protection_handler
768* protection_handlers[] = {
769  do_spurious_wp_fault,
770  do_soft_stack_overflow,
771  do_soft_stack_overflow,
772  do_soft_stack_overflow,
773  do_hard_stack_overflow,   
774  do_hard_stack_overflow,
775  do_hard_stack_overflow,
776};
777
778
779/* Maybe this'll work someday.  We may have to do something to
780   make the thread look like it's not handling an exception */
781void
782reset_lisp_process(ExceptionInformation *xp)
783{
784}
785
786Boolean
787do_hard_stack_overflow(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr)
788{
789  /*  reset_lisp_process(xp); */
790  Bug(xp, "Unrecoverable stack overflow.");
791  return false;
792}
793
794
795Boolean
796do_spurious_wp_fault(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr)
797{
798
799  return false;
800}
801
802Boolean
803do_soft_stack_overflow(ExceptionInformation *xp, protected_area_ptr prot_area, BytePtr addr)
804{
805  /* Trying to write into a guard page on the vstack or tstack.
806     Allocate a new stack segment, emulate stwu and stwux for the TSP, and
807     signal an error_stack_overflow condition.
808      */
809  lisp_protection_kind which = prot_area->why;
810  Boolean on_TSP = (which == kTSPsoftguard);
811  LispObj save_fp = xpGPR(xp,Ifp);
812  LispObj save_vsp = xpGPR(xp,Isp), 
813    xcf,
814    cmain = nrs_CMAIN.vcell;
815  area *a;
816  protected_area_ptr soft;
817  TCR *tcr = get_tcr(false);
818  int skip;
819
820  if ((fulltag_of(cmain) == fulltag_misc) &&
821      (header_subtag(header_of(cmain)) == subtag_macptr)) {
822    if (on_TSP) {
823      a = tcr->ts_area;
824    } else {
825      a = tcr->vs_area;
826    }
827    soft = a->softprot;
828    unprotect_area(soft);
829    xcf = create_exception_callback_frame(xp, tcr);
830    skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, on_TSP, 0, 0);
831    xpGPR(xp,Ifp) = save_fp;
832    xpGPR(xp,Isp) = save_vsp;
833    xpPC(xp) += skip;
834    return true;
835  }
836  return false;
837}
838
839Boolean
840is_write_fault(ExceptionInformation *xp, siginfo_t *info)
841{
842#ifdef DARWIN
843  return (UC_MCONTEXT(xp)->__es.__err & 0x2) != 0;
844#endif
845#if defined(LINUX) || defined(SOLARIS)
846  return (xpGPR(xp,REG_ERR) & 0x2) != 0;
847#endif
848#ifdef FREEBSD
849  return (xp->uc_mcontext.mc_err & 0x2) != 0;
850#endif
851#ifdef WINDOWS
852  return (info->ExceptionFlags == EXCEPTION_WRITE_FAULT);
853#endif
854}
855
856Boolean
857handle_fault(TCR *tcr, ExceptionInformation *xp, siginfo_t *info, int old_valence)
858{
859#ifdef FREEBSD
860#ifdef X8664
861  BytePtr addr = (BytePtr) xp->uc_mcontext.mc_addr;
862#else
863  BytePtr addr = (BytePtr) info->si_addr;
864#endif
865#else
866#ifdef WINDOWS
867  BytePtr addr = (BytePtr) info->ExceptionInformation[1];
868#else
869  BytePtr addr = (BytePtr) info->si_addr;
870#endif
871#endif
872  Boolean valid = IS_PAGE_FAULT(info,xp);
873
874  if (tcr->safe_ref_address != NULL) {
875    xpGPR(xp,Iimm0) = 0;
876    xpPC(xp) = xpGPR(xp,Ira0);
877    tcr->safe_ref_address = NULL;
878    return true;
879  }
880
881  if (valid) {
882    {
883      protected_area *a = find_protected_area(addr);
884      protection_handler *handler;
885     
886      if (a) {
887        handler = protection_handlers[a->why];
888        return handler(xp, a, addr);
889      }
890    }
891
892    if ((addr >= readonly_area->low) &&
893        (addr < readonly_area->active)) {
894      UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)),
895                      page_size);
896      return true;
897    }
898
899    {
900      area *a = area_containing(addr);
901
902      if (a && a->code == AREA_WATCHED && addr < a->high) {
903        /* caught a write to a watched object */
904        LispObj *p = (LispObj *)a->low;
905        LispObj node = *p;
906        unsigned tag_n = fulltag_of(node);
907        LispObj cmain = nrs_CMAIN.vcell;
908        LispObj obj;
909
910        if (immheader_tag_p(tag_n) || nodeheader_tag_p(tag_n))
911          obj = (LispObj)p + fulltag_misc;
912        else
913          obj = (LispObj)p + fulltag_cons;
914
915        if ((fulltag_of(cmain) == fulltag_misc) &&
916            (header_subtag(header_of(cmain)) == subtag_macptr)) {
917          LispObj save_vsp = xpGPR(xp, Isp);
918          LispObj save_fp = xpGPR(xp, Ifp);
919          LispObj xcf;
920          natural offset = (LispObj)addr - obj;
921          int skip;
922
923          push_on_lisp_stack(xp, obj);
924          xcf = create_exception_callback_frame(xp, tcr);
925
926          /* The magic 2 means this was a write to a watchd object */
927          skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2,
928                                  (natural)addr, offset);
929          xpPC(xp) += skip;
930          xpGPR(xp, Ifp) = save_fp;
931          xpGPR(xp, Isp) = save_vsp;
932          return true;
933        }
934      }
935    }
936  }
937
938  if (old_valence == TCR_STATE_LISP) {
939    LispObj cmain = nrs_CMAIN.vcell,
940      xcf;
941    if ((fulltag_of(cmain) == fulltag_misc) &&
942      (header_subtag(header_of(cmain)) == subtag_macptr)) {
943      xcf = create_exception_callback_frame(xp, tcr);
944      callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, valid ? is_write_fault(xp,info) : (natural)-1, valid ? (natural)addr : 0, 0);
945    }
946  }
947  return false;
948}
949
950Boolean
951handle_foreign_fpe(TCR *tcr, ExceptionInformation *xp, siginfo_t *info)
952{
953#ifdef X8632
954  return false;
955#else
956  int code;
957
958#ifdef WINDOWS
959  if (info->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
960    return false;
961#else
962  if (info->si_code == FPE_INTDIV)
963    return false;
964#endif
965
966  /*
967   * Cooperate with .SPffcall to avoid saving and restoring the MXCSR
968   * around every foreign call.
969   */
970    if (! (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN_FPE))) {
971      tcr->flags |= (1<<TCR_FLAG_BIT_FOREIGN_FPE);
972      tcr->lisp_mxcsr = xpMXCSR(xp) & ~MXCSR_STATUS_MASK;
973    }
974    xpMXCSR(xp) &= ~MXCSR_STATUS_MASK;
975    xpMXCSR(xp) |= MXCSR_CONTROL_MASK;
976    return true;
977#endif
978}
979
980Boolean
981handle_floating_point_exception(TCR *tcr, ExceptionInformation *xp, siginfo_t *info)
982{
983  int code,skip;
984  LispObj  xcf, cmain = nrs_CMAIN.vcell,
985    save_vsp = xpGPR(xp,Isp),
986    save_fp = xpGPR(xp,Ifp);
987#ifdef DARWIN /* bug in <= 10.5 */
988  void decode_vector_fp_exception(siginfo_t *, uint32_t);
989
990  decode_vector_fp_exception(info, (uint32_t)(UC_MCONTEXT(xp)->__fs.__fpu_mxcsr));
991#endif
992
993#ifdef WINDOWS
994  code = info->ExceptionCode;
995#else
996  code = info->si_code;
997#endif 
998
999  if ((fulltag_of(cmain) == fulltag_misc) &&
1000      (header_subtag(header_of(cmain)) == subtag_macptr)) {
1001    xcf = create_exception_callback_frame(xp, tcr);
1002    skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0);
1003    xpPC(xp) += skip;
1004    xpGPR(xp,Ifp) = save_fp;
1005    xpGPR(xp,Isp) = save_vsp;
1006    return true;
1007  } else {
1008    return false;
1009  }
1010}
1011
1012
1013Boolean
1014extend_tcr_tlb(TCR *tcr, ExceptionInformation *xp)
1015{
1016  LispObj index, old_limit = tcr->tlb_limit, new_limit, new_bytes;
1017  LispObj *old_tlb = tcr->tlb_pointer, *new_tlb, *work, *tos;
1018
1019  tos = (LispObj*)(xpGPR(xp,Isp));
1020  index = *tos++;
1021  (xpGPR(xp,Isp))=(LispObj)tos;
1022 
1023  new_limit = align_to_power_of_2(index+1,12);
1024  new_bytes = new_limit-old_limit;
1025  new_tlb = realloc(old_tlb, new_limit);
1026
1027  if (new_tlb == NULL) {
1028    return false;
1029  }
1030  work = (LispObj *) ((BytePtr)new_tlb+old_limit);
1031
1032  while (new_bytes) {
1033    *work++ = no_thread_local_binding_marker;
1034    new_bytes -= sizeof(LispObj);
1035  }
1036  tcr->tlb_pointer = new_tlb;
1037  tcr->tlb_limit = new_limit;
1038  return true;
1039}
1040
1041
1042#if defined(FREEBSD) || defined(DARWIN)
1043static
1044char mxcsr_bit_to_fpe_code[] = {
1045  FPE_FLTINV,                   /* ie */
1046  0,                            /* de */
1047  FPE_FLTDIV,                   /* ze */
1048  FPE_FLTOVF,                   /* oe */
1049  FPE_FLTUND,                   /* ue */
1050  FPE_FLTRES                    /* pe */
1051};
1052
1053void
1054decode_vector_fp_exception(siginfo_t *info, uint32_t mxcsr)
1055{
1056  /* If the exception appears to be an XMM FP exception, try to
1057     determine what it was by looking at bits in the mxcsr.
1058  */
1059  int xbit, maskbit;
1060 
1061  for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
1062    if ((mxcsr & (1 << xbit)) &&
1063        !(mxcsr & (1 << maskbit))) {
1064      info->si_code = mxcsr_bit_to_fpe_code[xbit];
1065      return;
1066    }
1067  }
1068  /* Nothing enabled and set in the mxcsr, assume integer /0 */
1069  info->si_code = FPE_INTDIV;
1070}
1071
1072#ifdef FREEBSD
1073void
1074freebsd_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp)
1075{
1076  if (info->si_code == 0) {
1077#ifdef X8664
1078    struct savefpu *fpu = (struct savefpu *) &(xp->uc_mcontext.mc_fpstate);
1079#else
1080    struct ccl_savexmm *fpu = (struct ccl_savexmm *) &(xp->uc_mcontext.mc_fpstate);
1081#endif
1082    uint32_t mxcsr = fpu->sv_env.en_mxcsr;
1083
1084    decode_vector_fp_exception(info, mxcsr);
1085  }
1086}
1087#endif
1088
1089#ifdef DARWIN
1090void
1091darwin_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp)
1092{
1093  if (info->si_code == EXC_I386_SSEEXTERR) {
1094    uint32_t mxcsr = UC_MCONTEXT(xp)->__fs.__fpu_mxcsr;
1095
1096    decode_vector_fp_exception(info, mxcsr);
1097  }
1098}
1099
1100#endif
1101
1102#endif
1103
1104void
1105get_lisp_string(LispObj lisp_string, char *c_string, natural max)
1106{
1107  lisp_char_code *src = (lisp_char_code *)  (ptr_from_lispobj(lisp_string + misc_data_offset));
1108  natural i, n = header_element_count(header_of(lisp_string));
1109
1110  if (n > max) {
1111    n = max;
1112  }
1113
1114  for (i = 0; i < n; i++) {
1115    c_string[i] = 0xff & (src[i]);
1116  }
1117  c_string[n] = 0;
1118}
1119
1120Boolean handle_watch_trap(ExceptionInformation *xp, TCR *tcr);
1121
1122Boolean
1123handle_exception(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1124{
1125  pc program_counter = (pc)xpPC(context);
1126
1127  if (old_valence != TCR_STATE_LISP) {
1128    if (old_valence == TCR_STATE_FOREIGN && signum == SIGFPE) {
1129      return handle_foreign_fpe(tcr, context, info);
1130    } else {
1131      return false;
1132    }
1133  }
1134
1135  switch (signum) {
1136  case SIGNUM_FOR_INTN_TRAP:
1137    if (IS_MAYBE_INT_TRAP(info,context)) {
1138      /* Something mapped to SIGSEGV/SIGBUS that has nothing to do with
1139         a memory fault.  On x86, an "int n" instruction that's
1140         not otherwise implemented causes a "protecton fault".  Of
1141         course that has nothing to do with accessing protected
1142         memory; of course, most Unices act as if it did.*/
1143      if ((program_counter != NULL) &&
1144          (*program_counter == INTN_OPCODE)) {
1145        program_counter++;
1146        switch (*program_counter) {
1147        case UUO_ALLOC_TRAP:
1148          {
1149            Boolean did_notify = false,
1150              *notify_ptr = &did_notify;
1151            if (did_gc_notification_since_last_full_gc) {
1152              notify_ptr = NULL;
1153            }
1154            if (handle_alloc_trap(context, tcr, notify_ptr)) {
1155              if (! did_notify) {
1156                xpPC(context) += 2;     /* we might have GCed. */
1157              }
1158              return true;
1159            }
1160          }
1161          break;
1162        case UUO_GC_TRAP:
1163          if (handle_gc_trap(context, tcr)) {
1164            xpPC(context) += 2;
1165            return true;
1166          }
1167          break;
1168        case UUO_WATCH_TRAP:
1169          /* add or remove watched object */
1170          if (handle_watch_trap(context, tcr)) {
1171            xpPC(context) += 2;
1172            return true;
1173          }
1174          break;
1175        case UUO_DEBUG_TRAP:
1176          xpPC(context) = (natural) (program_counter+1);
1177          lisp_Debugger(context, info, debug_entry_dbg, false, "Lisp Breakpoint");
1178          return true;
1179           
1180        case UUO_DEBUG_TRAP_WITH_STRING:
1181          xpPC(context) = (natural) (program_counter+1);
1182          {
1183            char msg[512];
1184
1185            get_lisp_string(xpGPR(context,Iarg_z),msg, sizeof(msg)-1);
1186            lisp_Debugger(context, info, debug_entry_dbg, false, msg);
1187          }
1188          return true;
1189         
1190        default:
1191          return handle_error(tcr, context);
1192        }
1193      } else {
1194        return false;
1195      }
1196
1197    } else {
1198      return handle_fault(tcr, context, info, old_valence);
1199    }
1200    break;
1201
1202  case SIGNAL_FOR_PROCESS_INTERRUPT:
1203    tcr->interrupt_pending = 0;
1204    callback_for_interrupt(tcr, context);
1205    return true;
1206    break;
1207
1208
1209  case SIGILL:
1210    if ((program_counter[0] == XUUO_OPCODE_0) &&
1211        (program_counter[1] == XUUO_OPCODE_1)) {
1212      TCR *target = (TCR *)xpGPR(context, Iarg_z);
1213
1214      switch (program_counter[2]) {
1215      case XUUO_TLB_TOO_SMALL:
1216        if (extend_tcr_tlb(tcr,context)) {
1217          xpPC(context)+=3;
1218          return true;
1219        }
1220        break;
1221       
1222      case XUUO_INTERRUPT_NOW:
1223        callback_for_interrupt(tcr,context);
1224        xpPC(context)+=3;
1225        return true;
1226
1227      case XUUO_SUSPEND_NOW:
1228        xpPC(context)+=3;
1229        return true;
1230
1231      case XUUO_INTERRUPT:
1232        raise_thread_interrupt(target);
1233        xpPC(context)+=3;
1234        return true;
1235
1236      case XUUO_SUSPEND:
1237        xpGPR(context,Iimm0) = (LispObj) lisp_suspend_tcr(target);
1238        xpPC(context)+=3;
1239        return true;
1240
1241      case XUUO_SUSPEND_ALL:
1242        lisp_suspend_other_threads();
1243        xpPC(context)+=3;
1244        return true;
1245
1246
1247      case XUUO_RESUME:
1248        xpGPR(context,Iimm0) = (LispObj) lisp_resume_tcr(target);
1249        xpPC(context)+=3;
1250        return true;
1251       
1252      case XUUO_RESUME_ALL:
1253        lisp_resume_other_threads();
1254        xpPC(context)+=3;
1255        return true;
1256       
1257      case XUUO_KILL:
1258        xpGPR(context,Iimm0) = (LispObj)kill_tcr(target);
1259        xpPC(context)+=3;
1260        return true;
1261
1262      case XUUO_ALLOCATE_LIST:
1263        allocate_list(context,tcr);
1264        xpPC(context)+=3;
1265        return true;
1266
1267      default:
1268        return false;
1269      }
1270    } else {
1271      return false;
1272    }
1273    break;
1274   
1275  case SIGFPE:
1276#ifdef FREEBSD
1277    /* As of 6.1, FreeBSD/AMD64 doesn't seem real comfortable
1278       with this newfangled XMM business (and therefore info->si_code
1279       is often 0 on an XMM FP exception.
1280       Try to figure out what really happened by decoding mxcsr
1281       bits.
1282    */
1283    freebsd_decode_vector_fp_exception(info,context);
1284#endif
1285#ifdef DARWIN
1286    /* Same general problem with Darwin as of 8.7.2 */
1287    darwin_decode_vector_fp_exception(info,context);
1288#endif
1289
1290    return handle_floating_point_exception(tcr, context, info);
1291
1292#if SIGBUS != SIGNUM_FOR_INTN_TRAP
1293  case SIGBUS:
1294    return handle_fault(tcr, context, info, old_valence);
1295#endif
1296   
1297#if SIGSEGV != SIGNUM_FOR_INTN_TRAP
1298  case SIGSEGV:
1299    return handle_fault(tcr, context, info, old_valence);
1300#endif   
1301   
1302  default:
1303    return false;
1304  }
1305  return false;
1306}
1307
1308
1309/*
1310   Current thread has all signals masked.  Before unmasking them,
1311   make it appear that the current thread has been suspended.
1312   (This is to handle the case where another thread is trying
1313   to GC before this thread is able to seize the exception lock.)
1314*/
1315int
1316prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context)
1317{
1318  int old_valence = tcr->valence;
1319
1320  tcr->pending_exception_context = context;
1321  tcr->valence = TCR_STATE_EXCEPTION_WAIT;
1322
1323#ifdef WINDOWS
1324  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1325    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1326    SEM_RAISE(TCR_AUX(tcr)->suspend);
1327    SEM_WAIT_FOREVER(TCR_AUX(tcr)->resume);
1328  }
1329#else
1330  ALLOW_EXCEPTIONS(context);
1331#endif
1332  return old_valence;
1333} 
1334
1335void
1336wait_for_exception_lock_in_handler(TCR *tcr, 
1337                                   ExceptionInformation *context,
1338                                   xframe_list *xf)
1339{
1340
1341  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
1342#if 0
1343  fprintf(dbgout, "0x" LISP " has exception lock\n", tcr);
1344#endif
1345  xf->curr = context;
1346#ifdef X8632
1347  xf->node_regs_mask = tcr->node_regs_mask;
1348#endif
1349  xf->prev = tcr->xframe;
1350  tcr->xframe =  xf;
1351  tcr->pending_exception_context = NULL;
1352  tcr->valence = TCR_STATE_FOREIGN; 
1353}
1354
1355void
1356unlock_exception_lock_in_handler(TCR *tcr)
1357{
1358  tcr->pending_exception_context = tcr->xframe->curr;
1359#ifdef X8632
1360  tcr->node_regs_mask = tcr->xframe->node_regs_mask;
1361#endif
1362  tcr->xframe = tcr->xframe->prev;
1363  tcr->valence = TCR_STATE_EXCEPTION_RETURN;
1364  UNLOCK(lisp_global(EXCEPTION_LOCK),tcr);
1365#if 0
1366  fprintf(dbgout, "0x" LISP " released exception lock\n", tcr);
1367#endif
1368}
1369
1370/*
1371   If an interrupt is pending on exception exit, try to ensure
1372   that the thread sees it as soon as it's able to run.
1373*/
1374#ifdef WINDOWS
1375void
1376raise_pending_interrupt(TCR *tcr)
1377{
1378}
1379void
1380exit_signal_handler(TCR *tcr, int old_valence)
1381{
1382}
1383void
1384signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
1385{
1386}
1387#else
1388void
1389raise_pending_interrupt(TCR *tcr)
1390{
1391  if ((TCR_INTERRUPT_LEVEL(tcr) >= 0) &&
1392      (tcr->interrupt_pending)) {
1393    pthread_kill((pthread_t)(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT);
1394  }
1395}
1396
1397void
1398exit_signal_handler(TCR *tcr, int old_valence)
1399{
1400  sigset_t mask;
1401  sigfillset(&mask);
1402#ifdef FREEBSD
1403  sigdelset(&mask,SIGTRAP);
1404#endif
1405 
1406  pthread_sigmask(SIG_SETMASK,&mask, NULL);
1407  tcr->valence = old_valence;
1408  tcr->pending_exception_context = NULL;
1409}
1410
1411void
1412signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1413{
1414  xframe_list xframe_link;
1415  TCR *tcr = get_tcr(false);
1416
1417  ResetAltStack();
1418
1419  int old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1420  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
1421    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
1422    pthread_kill(pthread_self(), thread_suspend_signal);
1423  }
1424  wait_for_exception_lock_in_handler(tcr,context, &xframe_link);
1425
1426
1427  if (! handle_exception(signum, info, context, tcr, old_valence)) {
1428    char msg[512];
1429    Boolean foreign = (old_valence != TCR_STATE_LISP);
1430
1431    snprintf(msg, sizeof(msg), "Unhandled exception %d at 0x" LISP ", context->regs at #x" LISP "", signum, xpPC(context), (natural)xpGPRvector(context));
1432   
1433    if (lisp_Debugger(context, info, signum,  foreign, msg)) {
1434      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
1435    }
1436  }
1437  unlock_exception_lock_in_handler(tcr);
1438  exit_signal_handler(tcr, old_valence);
1439  /* raise_pending_interrupt(tcr); */
1440  SIGRETURN(context);
1441}
1442#endif
1443
1444
1445
1446
1447#ifdef LINUX
1448/* type of pointer to saved fp state */
1449#ifdef X8664
1450typedef fpregset_t FPREGS;
1451#else
1452typedef struct _fpstate *FPREGS;
1453#endif
1454LispObj *
1455copy_fpregs(ExceptionInformation *xp, LispObj *current, FPREGS *destptr)
1456{
1457  FPREGS src = (FPREGS)(xp->uc_mcontext.fpregs), dest;
1458 
1459  if (src) {
1460    dest = ((FPREGS)current)-1;
1461    *dest = *src;
1462    *destptr = dest;
1463    current = (LispObj *) dest;
1464  }
1465  return current;
1466}
1467#endif
1468
1469
1470#ifdef FREEBSD
1471typedef void *FPREGS;
1472
1473
1474LispObj *
1475copy_avx(ExceptionInformation *xp, LispObj *current, FPREGS *destptr)
1476{
1477  natural sp;
1478
1479  *destptr = (FPREGS)AVX_CONTEXT_PTR(xp);
1480
1481  if (AVX_CONTEXT_PRESENT(xp)) {
1482    sp = (natural)current;
1483    sp -= AVX_CONTEXT_SIZE(xp);
1484    sp = truncate_to_power_of_2(sp,6);
1485    memcpy((void *)sp,(void *)AVX_CONTEXT_PTR(xp),AVX_CONTEXT_SIZE(xp));
1486    current = (LispObj *)sp;
1487    *destptr = (FPREGS)current;
1488  }
1489  return current;
1490}
1491#endif
1492
1493#ifdef DARWIN
1494LispObj *
1495copy_darwin_mcontext(MCONTEXT_T context, 
1496                     LispObj *current, 
1497                     MCONTEXT_T *out)
1498{
1499  MCONTEXT_T dest = ((MCONTEXT_T)current)-1;
1500  dest = (MCONTEXT_T) (((LispObj)dest) & ~15);
1501
1502  *dest = *context;
1503  *out = dest;
1504  return (LispObj *)dest;
1505}
1506#endif
1507
1508LispObj *
1509copy_siginfo(siginfo_t *info, LispObj *current)
1510{
1511  siginfo_t *dest = ((siginfo_t *)current) - 1;
1512#if !defined(LINUX) || !defined(X8632)
1513  dest = (siginfo_t *) (((LispObj)dest)&~15);
1514#endif
1515  *dest = *info;
1516  return (LispObj *)dest;
1517}
1518
1519#ifdef LINUX
1520typedef FPREGS copy_ucontext_last_arg_t;
1521#else
1522typedef void * copy_ucontext_last_arg_t;
1523#endif
1524
1525#ifndef WINDOWS
1526LispObj *
1527copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1528{
1529  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1530#if !defined(LINUX) || !defined(X8632)
1531  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1532#endif
1533
1534  *dest = *context;
1535  /* Fix it up a little; where's the signal mask allocated, if indeed
1536     it is "allocated" ? */
1537#ifdef LINUX
1538  dest->uc_mcontext.fpregs = (fpregset_t)fp;
1539#endif
1540#ifdef FREEBSD
1541  if (AVX_CONTEXT_PRESENT(context)) {
1542    AVX_CONTEXT_PTR(context) = (natural)fp;
1543  }
1544#endif
1545  dest->uc_stack.ss_sp = 0;
1546  dest->uc_stack.ss_size = 0;
1547  dest->uc_stack.ss_flags = 0;
1548  dest->uc_link = NULL;
1549  return (LispObj *)dest;
1550}
1551#endif
1552
1553
1554LispObj *
1555tcr_frame_ptr(TCR *tcr)
1556{
1557  ExceptionInformation *xp;
1558  LispObj *fp;
1559
1560  if (tcr->pending_exception_context)
1561    xp = tcr->pending_exception_context;
1562  else if (tcr->valence == TCR_STATE_LISP) {
1563    xp = TCR_AUX(tcr)->suspend_context;
1564  } else {
1565    xp = NULL;
1566  }
1567  if (xp) {
1568    fp = (LispObj *)xpGPR(xp, Ifp);
1569  } else {
1570    fp = tcr->save_fp;
1571  }
1572  return fp;
1573}
1574
1575
1576LispObj *
1577find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1578{
1579
1580  if (((BytePtr)rsp < foreign_area->low) ||
1581      ((BytePtr)rsp > foreign_area->high)) {
1582    rsp = (LispObj)(tcr->foreign_sp);
1583  }
1584  return (LispObj *) (((rsp-128) & ~15));
1585}
1586
1587#ifdef X8632
1588#ifdef LINUX
1589/* This is here for debugging.  On entry to a signal handler that
1590   receives info and context arguments, the stack should look exactly
1591   like this.  The "pretcode field" of the structure is the address
1592   of code that does an rt_sigreturn syscall, and rt_sigreturn expects
1593   %esp at the time of that syscall to be pointing just past the
1594   pretcode field.
1595   handle_signal_on_foreign_stack() and helpers have to be very
1596   careful to duplicate this "structure" exactly.
1597   Note that on x8664 Linux, rt_sigreturn expects a ucontext to
1598   be on top of the stack (with a siginfo_t underneath it.)
1599   It sort of half-works to do sigreturn via setcontext() on
1600   x8632 Linux, but (a) it may not be available on some distributions
1601   and (b) even a relatively modern version of it uses "fldenv" to
1602   restore FP context, and "fldenv" isn't nearly good enough.
1603*/
1604
1605struct rt_sigframe {
1606        char *pretcode;
1607        int sig;
1608        siginfo_t  *pinfo;
1609        void  *puc;
1610        siginfo_t info;
1611        struct ucontext uc;
1612        struct _fpstate fpstate;
1613        char retcode[8];
1614};
1615struct rt_sigframe *rtsf = 0;
1616
1617#endif
1618#endif
1619
1620
1621#ifndef WINDOWS
1622/* x8632 Linux requires that the stack-allocated siginfo is nearer
1623   the top of stack than the stack-allocated ucontext.  If other
1624   platforms care, they expect the ucontext to be nearer the top
1625   of stack.
1626*/
1627
1628#if defined(LINUX) && defined(X8632)
1629#define UCONTEXT_ON_TOP_OF_STACK 0
1630#else
1631#define UCONTEXT_ON_TOP_OF_STACK 1
1632#endif
1633void
1634handle_signal_on_foreign_stack(TCR *tcr,
1635                               void *handler, 
1636                               int signum, 
1637                               siginfo_t *info, 
1638                               ExceptionInformation *context,
1639                               LispObj return_address
1640                               )
1641{
1642#ifdef LINUX
1643  FPREGS fpregs = NULL;
1644#else
1645  void *fpregs = NULL;
1646#endif
1647#ifdef DARWIN
1648  MCONTEXT_T mcontextp = NULL;
1649#endif
1650  siginfo_t *info_copy = NULL;
1651  ExceptionInformation *xp = NULL;
1652  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1653
1654#ifdef LINUX
1655  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1656#endif
1657#ifdef FREEBSD
1658  foreign_rsp = copy_avx(context, foreign_rsp, &fpregs);
1659#endif
1660#ifdef DARWIN
1661  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1662#endif
1663#if UCONTEXT_ON_TOP_OF_STACK
1664  /* copy info first */
1665  foreign_rsp = copy_siginfo(info, foreign_rsp);
1666  info_copy = (siginfo_t *)foreign_rsp;
1667  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1668  xp = (ExceptionInformation *)foreign_rsp;
1669#else
1670  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1671  xp = (ExceptionInformation *)foreign_rsp;
1672  foreign_rsp = copy_siginfo(info, foreign_rsp);
1673  info_copy = (siginfo_t *)foreign_rsp;
1674#endif
1675#ifdef DARWIN
1676  UC_MCONTEXT(xp) = mcontextp;
1677#endif
1678  *--foreign_rsp = return_address;
1679  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1680}
1681#endif
1682
1683
1684#ifndef WINDOWS
1685#ifndef USE_SIGALTSTACK
1686void
1687arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1688{
1689  TCR *tcr = get_interrupt_tcr(false);
1690#if 1
1691  if (tcr->valence != TCR_STATE_LISP) {
1692    lisp_Debugger(context, info, signum, true, "exception in foreign context");
1693  }
1694#endif
1695  {
1696    area *vs = tcr->vs_area;
1697    BytePtr current_sp = (BytePtr) current_stack_pointer();
1698
1699
1700    if ((current_sp >= vs->low) &&
1701        (current_sp < vs->high)) {
1702      handle_signal_on_foreign_stack(tcr,
1703                                     signal_handler,
1704                                     signum,
1705                                     info,
1706                                     context,
1707                                     (LispObj)__builtin_return_address(0)
1708
1709                                     );
1710    } else {
1711      signal_handler(signum, info, context);
1712    }
1713  }
1714}
1715
1716#else
1717void
1718altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1719{
1720  TCR* tcr = get_tcr(true);
1721  Boolean do_stack_switch = false;
1722  stack_t ss;
1723
1724  if ((tcr->valence != TCR_STATE_LISP) &&
1725      (tcr->safe_ref_address) &&
1726      ((signum == SIGBUS) || (signum == SIGSEGV))) {
1727    extern opcode ffcall_return;
1728    xpPC(context) = (natural)&ffcall_return;
1729    xpGPR(context,Iimm0) = 0;
1730    xpGPR(context,Isp) = (natural)(tcr->foreign_sp);
1731    return;
1732  }
1733
1734
1735
1736
1737
1738#if WORD_SIZE==64
1739  if ((signum == SIGFPE) && (tcr->valence != TCR_STATE_LISP)) {
1740    if (handle_foreign_fpe(tcr,context,info)) {
1741      return;
1742    }
1743  }
1744#endif
1745     
1746  /* Because of signal chaining - and the possibility that libraries
1747     that use it ignore sigaltstack-related issues - we have to check
1748     to see if we're actually on the altstack.
1749
1750     When OpenJDK VMs overwrite preinstalled signal handlers (that're
1751     there for a reason ...), they're also casual about SA_RESTART.
1752     We care about SA_RESTART (mostly) in the PROCESS-INTERRUPT case,
1753     and whether a JVM steals the signal used for PROCESS-INTERRUPT
1754     is platform-dependent.  On those platforms where the same signal
1755     is used, we should strongly consider trying to use another one.
1756  */
1757  sigaltstack(NULL, &ss);
1758  if (ss.ss_flags == SS_ONSTACK) {
1759    do_stack_switch = true;
1760  } else {
1761    area *vs = tcr->vs_area;
1762    BytePtr current_sp = (BytePtr) current_stack_pointer();
1763
1764    if ((current_sp >= vs->low) &&
1765        (current_sp < vs->high)) {
1766      do_stack_switch = true;
1767    }
1768  }
1769  if (do_stack_switch) {
1770    handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)SIGRETURN_ADDRESS());
1771  } else {
1772    signal_handler(signum,info,context);
1773  }
1774}
1775#endif
1776#endif
1777
1778Boolean
1779stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr)
1780{
1781  area *a = tcr->vs_area;
1782 
1783  return (((BytePtr)stack_pointer <= a->high) &&
1784          ((BytePtr)stack_pointer > a->low));
1785}
1786
1787
1788#ifdef WINDOWS
1789extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int);
1790#endif
1791
1792void
1793interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1794{
1795  TCR *tcr = get_interrupt_tcr(false);
1796  int old_valence = tcr->valence;
1797
1798  if (tcr) {
1799    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1800        (tcr->valence != TCR_STATE_LISP) ||
1801        (tcr->unwinding != 0) ||
1802        ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) ||
1803        ! stack_pointer_on_vstack_p(xpGPR(context,Ifp), tcr)) {
1804      tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1)));
1805    } else {
1806      LispObj cmain = nrs_CMAIN.vcell;
1807     
1808      ResetAltStack();
1809      if ((fulltag_of(cmain) == fulltag_misc) &&
1810          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1811        /*
1812           This thread can (allegedly) take an interrupt now.
1813        */
1814
1815        xframe_list xframe_link;
1816        signed_natural alloc_displacement = 0;
1817        LispObj
1818          *next_tsp = tcr->next_tsp,
1819          *save_tsp = tcr->save_tsp,
1820          *p,
1821          q;
1822        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1823
1824        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1825           
1826        if (next_tsp != save_tsp) {
1827          tcr->next_tsp = save_tsp;
1828        } else {
1829          next_tsp = NULL;
1830        }
1831        /* have to do this before allowing interrupts */
1832        pc_luser_xp(context, tcr, &alloc_displacement);
1833        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1834        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1835        handle_exception(signum, info, context, tcr, old_valence);
1836        if (alloc_displacement) {
1837          tcr->save_allocptr -= alloc_displacement;
1838        }
1839        if (next_tsp) {
1840          tcr->next_tsp = next_tsp;
1841          p = next_tsp;
1842          while (p != save_tsp) {
1843            *p++ = 0;
1844          }
1845          q = (LispObj)save_tsp;
1846          *next_tsp = q;
1847        }
1848        tcr->flags |= old_foreign_exception;
1849        unlock_exception_lock_in_handler(tcr);
1850#ifndef WINDOWS
1851        exit_signal_handler(tcr, old_valence);
1852#endif
1853      }
1854    }
1855  }
1856#ifdef WINDOWS
1857  restore_windows_context(context,tcr,old_valence);
1858#else
1859  SIGRETURN(context);
1860#endif
1861}
1862
1863
1864#ifndef WINDOWS
1865#ifndef USE_SIGALTSTACK
1866void
1867arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1868{
1869  TCR *tcr = get_interrupt_tcr(false);
1870  area *vs = tcr->vs_area;
1871  BytePtr current_sp = (BytePtr) current_stack_pointer();
1872
1873  if ((current_sp >= vs->low) &&
1874      (current_sp < vs->high)) {
1875    handle_signal_on_foreign_stack(tcr,
1876                                   interrupt_handler,
1877                                   signum,
1878                                   info,
1879                                   context,
1880                                   (LispObj)__builtin_return_address(0)
1881                                   );
1882  } else {
1883    /* If we're not on the value stack, we pretty much have to be on
1884       the C stack.  Just run the handler. */
1885    interrupt_handler(signum, info, context);
1886  }
1887}
1888
1889#else /* altstack works */
1890
1891/*
1892   There aren't likely any JVM-related signal-chaining issues here, since
1893   on platforms where that could be an issue we use either an RT signal
1894   or an unused synchronous hardware signal to raise interrupts.
1895*/
1896void
1897altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1898{
1899  TCR *tcr = get_interrupt_tcr(false);
1900  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1901                                 );
1902}
1903
1904#endif
1905#endif
1906
1907#ifndef WINDOWS
1908void
1909install_signal_handler(int signo, void *handler, unsigned flags)
1910{
1911  struct sigaction sa;
1912  int err;
1913 
1914  sa.sa_sigaction = (void *)handler;
1915  sigfillset(&sa.sa_mask);
1916#ifdef FREEBSD
1917  /* Strange FreeBSD behavior wrt synchronous signals */
1918  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1919#endif
1920  sa.sa_flags = SA_SIGINFO;
1921
1922#ifdef USE_SIGALTSTACK
1923  if (flags & ON_ALTSTACK)
1924    sa.sa_flags |= SA_ONSTACK;
1925#endif
1926  if (flags & RESTART_SYSCALLS)
1927    sa.sa_flags |= SA_RESTART;
1928  if (flags & RESERVE_FOR_LISP) {
1929    extern sigset_t user_signals_reserved;
1930    sigaddset(&user_signals_reserved, signo);
1931  }
1932
1933  err = sigaction(signo, &sa, NULL);
1934  if (err) {
1935    perror("sigaction");
1936    exit(1);
1937  }
1938}
1939#endif
1940
1941#ifdef WINDOWS
1942BOOL
1943CALLBACK ControlEventHandler(DWORD event)
1944{
1945  switch(event) {
1946  case CTRL_C_EVENT:
1947    lisp_global(INTFLAG) = (1 << fixnumshift);
1948    return TRUE;
1949    break;
1950  case CTRL_BREAK_EVENT:
1951    lisp_global(INTFLAG) = (2 << fixnumshift);
1952    return TRUE;
1953    break;
1954  default:
1955    return FALSE;
1956  }
1957}
1958
1959static
1960DWORD mxcsr_bit_to_fpe_code[] = {
1961  EXCEPTION_FLT_INVALID_OPERATION, /* ie */
1962  0,                            /* de */
1963  EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */
1964  EXCEPTION_FLT_OVERFLOW,       /* oe */
1965  EXCEPTION_FLT_UNDERFLOW,      /* ue */
1966  EXCEPTION_FLT_INEXACT_RESULT  /* pe */
1967};
1968
1969#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
1970#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4
1971#endif
1972
1973#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
1974#define  STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5
1975#endif
1976
1977int
1978map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context)
1979{
1980  switch (code) {
1981#ifdef WIN_32
1982  case STATUS_FLOAT_MULTIPLE_FAULTS:
1983  case STATUS_FLOAT_MULTIPLE_TRAPS:
1984    {
1985      int xbit, maskbit;
1986      DWORD mxcsr = *(xpMXCSRptr(context));
1987
1988      for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
1989        if ((mxcsr & (1 << xbit)) &&
1990            !(mxcsr & (1 << maskbit))) {
1991          info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit];
1992          break;
1993        }
1994      }
1995    }
1996    return SIGFPE;
1997#endif
1998     
1999  case EXCEPTION_ACCESS_VIOLATION:
2000    return SIGSEGV;
2001  case EXCEPTION_FLT_DENORMAL_OPERAND:
2002  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
2003  case EXCEPTION_FLT_INEXACT_RESULT:
2004  case EXCEPTION_FLT_INVALID_OPERATION:
2005  case EXCEPTION_FLT_OVERFLOW:
2006  case EXCEPTION_FLT_STACK_CHECK:
2007  case EXCEPTION_FLT_UNDERFLOW:
2008  case EXCEPTION_INT_DIVIDE_BY_ZERO:
2009  case EXCEPTION_INT_OVERFLOW:
2010    return SIGFPE;
2011  case EXCEPTION_PRIV_INSTRUCTION:
2012  case EXCEPTION_ILLEGAL_INSTRUCTION:
2013    return SIGILL;
2014  case EXCEPTION_IN_PAGE_ERROR:
2015  case STATUS_GUARD_PAGE_VIOLATION:
2016    return SIGBUS;
2017  default:
2018    return -1;
2019  }
2020}
2021
2022
2023LONG
2024windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr)
2025{
2026  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
2027  int old_valence, signal_number;
2028  ExceptionInformation *context = exception_pointers->ContextRecord;
2029  siginfo_t *info = exception_pointers->ExceptionRecord;
2030  xframe_list xframes;
2031
2032  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
2033  wait_for_exception_lock_in_handler(tcr, context, &xframes);
2034
2035  signal_number = map_windows_exception_code_to_posix_signal(code, info, context);
2036 
2037  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
2038    char msg[512];
2039    Boolean foreign = (old_valence != TCR_STATE_LISP);
2040
2041    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));
2042   
2043    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
2044      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
2045    }
2046  }
2047  unlock_exception_lock_in_handler(tcr);
2048  return restore_windows_context(context, tcr, old_valence);
2049}
2050
2051void
2052setup_exception_handler_call(CONTEXT *context,
2053                             LispObj new_sp,
2054                             void *handler,
2055                             EXCEPTION_POINTERS *new_ep,
2056                             TCR *tcr)
2057{
2058  extern void windows_halt(void);
2059  LispObj *p = (LispObj *)new_sp;
2060#ifdef WIN_64
2061  p-=4;                         /* win64 abi argsave nonsense */
2062  *(--p) = (LispObj)windows_halt;
2063  context->Rsp = (DWORD64)p;
2064  context->Rip = (DWORD64)handler;
2065  context->Rcx = (DWORD64)new_ep;
2066  context->Rdx = (DWORD64)tcr;
2067#else
2068  p-=4;                          /* args on stack, stack aligned */
2069  p[0] = (LispObj)new_ep;
2070  p[1] = (LispObj)tcr;
2071  *(--p) = (LispObj)windows_halt;
2072  context->Esp = (DWORD)p;
2073  context->Eip = (DWORD)handler;
2074#endif
2075  context->EFlags &= ~0x400;  /* clear direction flag */
2076}
2077
2078void
2079prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr,
2080                                                     CONTEXT *context,
2081                                                     void *handler,
2082                                                     EXCEPTION_POINTERS *original_ep)
2083{
2084  LispObj foreign_rsp = 
2085    (LispObj) (tcr->foreign_sp - 128) & ~15;
2086  CONTEXT *new_context;
2087  siginfo_t *new_info;
2088  EXCEPTION_POINTERS *new_ep;
2089
2090  new_context = ((CONTEXT *)(foreign_rsp&~15))-1;
2091  *new_context = *context;
2092  foreign_rsp = (LispObj)new_context;
2093  new_info = ((siginfo_t *)(foreign_rsp&~15))-1;
2094  *new_info = *original_ep->ExceptionRecord;
2095  foreign_rsp = (LispObj)new_info;
2096  new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1;
2097  foreign_rsp = (LispObj)new_ep & ~15;
2098  new_ep->ContextRecord = new_context;
2099  new_ep->ExceptionRecord = new_info;
2100  setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr);
2101}
2102
2103LONG CALLBACK
2104windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers)
2105{
2106  extern void ensure_safe_for_string_operations(void);
2107  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
2108
2109
2110 
2111  if ((code & 0x80000000L) == 0) {
2112    return EXCEPTION_CONTINUE_SEARCH;
2113  } else {
2114    TCR *tcr = get_interrupt_tcr(false);
2115    area *cs = TCR_AUX(tcr)->cs_area;
2116    BytePtr current_sp = (BytePtr) current_stack_pointer();
2117    CONTEXT *context = exception_pointers->ContextRecord;
2118   
2119    ensure_safe_for_string_operations();
2120
2121    if ((current_sp >= cs->low) &&
2122        (current_sp < cs->high)) {
2123      debug_show_registers(context, exception_pointers->ExceptionRecord, 0);
2124      FBug(context, "Exception on foreign stack\n");
2125      return EXCEPTION_CONTINUE_EXECUTION;
2126    }
2127
2128    prepare_to_handle_windows_exception_on_foreign_stack(tcr,
2129                                                         context,
2130                                                         windows_exception_handler,
2131                                                         exception_pointers);
2132    return EXCEPTION_CONTINUE_EXECUTION;
2133  }
2134}
2135
2136
2137void
2138install_pmcl_exception_handlers()
2139{
2140  AddVectoredExceptionHandler(1,windows_arbstack_exception_handler);
2141}
2142#else
2143void
2144install_pmcl_exception_handlers()
2145{
2146  void *handler, *interrupt_handler;
2147
2148#ifdef USE_SIGALTSTACK
2149  handler = (void *)altstack_signal_handler;
2150  interrupt_handler = (void *)altstack_interrupt_handler;
2151#else
2152  handler = (void *)arbstack_signal_handler;
2153  interrupt_handler = (void *)arbstack_interrupt_handler;
2154#endif
2155
2156  install_signal_handler(SIGILL, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2157  install_signal_handler(SIGBUS, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2158  install_signal_handler(SIGSEGV, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2159  install_signal_handler(SIGFPE, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2160 
2161  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, interrupt_handler,
2162                         RESERVE_FOR_LISP|ON_ALTSTACK);
2163  signal(SIGPIPE, SIG_IGN);
2164}
2165#endif
2166
2167
2168
2169/* This should only be called when the tcr_area_lock is held */
2170void
2171empty_tcr_stacks(TCR *tcr)
2172{
2173  if (tcr) {
2174    area *a;
2175
2176    tcr->valence = TCR_STATE_FOREIGN;
2177    a = tcr->vs_area;
2178    if (a) {
2179      a->active = a->high;
2180    }
2181    a = tcr->ts_area;
2182    if (a) {
2183      a->active = a->high;
2184    }
2185    a = TCR_AUX(tcr)->cs_area;
2186    if (a) {
2187      a->active = a->high;
2188    }
2189  }
2190}
2191
2192#ifdef WINDOWS
2193void
2194thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2195{
2196}
2197#else
2198void
2199thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2200{
2201  TCR *tcr = get_tcr(false);
2202  sigset_t mask;
2203
2204  sigemptyset(&mask);
2205
2206  empty_tcr_stacks(tcr);
2207
2208  pthread_sigmask(SIG_SETMASK,&mask,NULL);
2209  pthread_exit(NULL);
2210}
2211#endif
2212
2213#ifndef WINDOWS
2214#ifndef USE_SIGALTSTACK
2215void
2216arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2217{
2218  TCR *tcr = get_interrupt_tcr(false);
2219  area *vs = tcr->vs_area;
2220  BytePtr current_sp = (BytePtr) current_stack_pointer();
2221
2222  if ((current_sp >= vs->low) &&
2223      (current_sp < vs->high)) {
2224    handle_signal_on_foreign_stack(tcr,
2225                                   thread_kill_handler,
2226                                   signum,
2227                                   info,
2228                                   context,
2229                                   (LispObj)__builtin_return_address(0)
2230                                   );
2231  } else {
2232    /* If we're not on the value stack, we pretty much have to be on
2233       the C stack.  Just run the handler. */
2234    thread_kill_handler(signum, info, context);
2235  }
2236}
2237
2238
2239#else
2240void
2241altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2242{
2243  TCR* tcr = get_tcr(true);
2244  handle_signal_on_foreign_stack(tcr,
2245                                 thread_kill_handler,
2246                                 signum,
2247                                 info,
2248                                 context,
2249                                 (LispObj)__builtin_return_address(0)
2250                                 );
2251}
2252#endif
2253#endif
2254
2255#ifdef USE_SIGALTSTACK
2256#define THREAD_KILL_HANDLER altstack_thread_kill_handler
2257#else
2258#define THREAD_KILL_HANDLER arbstack_thread_kill_handler
2259#endif
2260
2261#ifdef WINDOWS
2262void
2263thread_signal_setup()
2264{
2265}
2266#else
2267void
2268thread_signal_setup()
2269{
2270  thread_suspend_signal = SIG_SUSPEND_THREAD;
2271  thread_kill_signal = SIG_KILL_THREAD;
2272
2273  install_signal_handler(thread_suspend_signal, (void *)suspend_resume_handler,
2274                         RESERVE_FOR_LISP|RESTART_SYSCALLS);
2275  install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER,
2276                         RESERVE_FOR_LISP|ON_ALTSTACK);
2277}
2278#endif
2279
2280void
2281enable_fp_exceptions()
2282{
2283}
2284
2285void
2286exception_init()
2287{
2288  x86_early_exception_init();
2289  install_pmcl_exception_handlers();
2290}
2291
2292void
2293adjust_exception_pc(ExceptionInformation *xp, int delta)
2294{
2295  xpPC(xp) += delta;
2296}
2297
2298/*
2299  Lower (move toward 0) the "end" of the soft protected area associated
2300  with a by a page, if we can.
2301*/
2302
2303void
2304adjust_soft_protection_limit(area *a)
2305{
2306  char *proposed_new_soft_limit = a->softlimit - 4096;
2307  protected_area_ptr p = a->softprot;
2308 
2309  if (proposed_new_soft_limit >= (p->start+16384)) {
2310    p->end = proposed_new_soft_limit;
2311    p->protsize = p->end-p->start;
2312    a->softlimit = proposed_new_soft_limit;
2313  }
2314  protect_area(p);
2315}
2316
2317void
2318restore_soft_stack_limit(unsigned restore_tsp)
2319{
2320  TCR *tcr = get_tcr(false);
2321  area *a;
2322 
2323  if (restore_tsp) {
2324    a = tcr->ts_area;
2325  } else {
2326    a = tcr->vs_area;
2327  }
2328  adjust_soft_protection_limit(a);
2329}
2330
2331
2332#ifdef USE_SIGALTSTACK
2333void
2334setup_sigaltstack(area *a)
2335{
2336  stack_t stack;
2337
2338  stack.ss_size = SIGSTKSZ*8;
2339  stack.ss_flags = 0;
2340  stack.ss_sp = mmap(NULL,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_ANON|MAP_PRIVATE,-1,0);
2341#ifdef LINUX
2342  /* The ucontext pushed on the altstack may not contain the (largish)
2343     __fpregs_mem field; copy_ucontext() wants to copy what it thinks
2344     is a pointer to a full ucontext.  That'll touch a page beyond the
2345     bottom of the altstack, and when this happens on the initial
2346     thread's stack on a recent (2.6.32+?) kernel, we'll SIGBUS instead
2347     of mapping that page.
2348     It's easier to just reserve that page here than it would be to
2349     change copy_ucontext().
2350  */
2351  stack.ss_size -= sizeof(struct ucontext);
2352#endif
2353  if (sigaltstack(&stack, NULL) != 0) {
2354    perror("sigaltstack");
2355    exit(-1);
2356  }
2357}
2358#endif
2359
2360extern opcode egc_write_barrier_start, egc_write_barrier_end,
2361  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2362  egc_set_hash_key_conditional_retry,
2363  egc_store_node_conditional_success_end, egc_store_node_conditional_retry,
2364  egc_store_node_conditional_success_test,egc_store_node_conditional,
2365  egc_set_hash_key, egc_gvset, egc_rplacd, egc_rplaca;
2366
2367/* We use (extremely) rigidly defined instruction sequences for consing,
2368   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2369   while consing.
2370
2371   Note that we can usually identify which of these instructions is about
2372   to be executed by a stopped thread without comparing all of the bytes
2373   to those at the stopped program counter, but we generally need to
2374   know the sizes of each of these instructions.
2375*/
2376
2377#ifdef X8664
2378opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2379#ifdef TCR_IN_GPR
2380  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2381#else
2382  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2383#endif
2384;
2385opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2386#ifdef TCR_IN_GPR
2387  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2388#else
2389  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2390#endif
2391
2392;
2393opcode branch_around_alloc_trap_instruction[] =
2394  {0x77,0x02};
2395opcode alloc_trap_instruction[] =
2396  {0xcd,0xc5};
2397opcode clear_tcr_save_allocptr_tag_instruction[] =
2398#ifdef TCR_IN_GPR
2399  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2400#else
2401  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2402#endif
2403;
2404opcode set_allocptr_header_instruction[] =
2405  {0x48,0x89,0x43,0xf3};
2406
2407
2408alloc_instruction_id
2409recognize_alloc_instruction(pc program_counter)
2410{
2411  switch(program_counter[0]) {
2412  case 0xcd: return ID_alloc_trap_instruction;
2413  /* 0x7f is jg, which we used to use here instead of ja */
2414  case 0x7f:
2415  case 0x77: return ID_branch_around_alloc_trap_instruction;
2416  case 0x48: return ID_set_allocptr_header_instruction;
2417#ifdef TCR_IN_GPR
2418  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2419  case 0x49:
2420    switch(program_counter[1]) {
2421    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2422    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2423    }
2424#else
2425  case 0x65: 
2426    switch(program_counter[1]) {
2427    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2428    case 0x48:
2429      switch(program_counter[2]) {
2430      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2431      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2432      }
2433    }
2434#endif
2435  default: break;
2436  }
2437  return ID_unrecognized_alloc_instruction;
2438}
2439#endif
2440#ifdef X8632
2441#define TCR_SEG_PREFIX 0x64
2442
2443#ifdef WIN_32
2444#define SAVE_ALLOCPTR 0x9c,0x0e,0x0,0x0
2445#define SAVE_ALLOCBASE 0x98,0x0e,0x0,0x0
2446#else
2447#define SAVE_ALLOCPTR 0x84,0x0,0x0,0x0
2448#define SAVE_ALLOCBASE 0x88,0x0,0x0,0x0
2449#endif
2450
2451opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2452  {TCR_SEG_PREFIX,0x8b,0x0d,SAVE_ALLOCPTR};
2453opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2454  {TCR_SEG_PREFIX,0x3b,0x0d,SAVE_ALLOCBASE};
2455opcode branch_around_alloc_trap_instruction[] =
2456  {0x77,0x02};
2457opcode alloc_trap_instruction[] =
2458  {0xcd,0xc5};
2459opcode clear_tcr_save_allocptr_tag_instruction[] =
2460  {TCR_SEG_PREFIX,0x80,0x25,SAVE_ALLOCPTR,0xf8};
2461opcode set_allocptr_header_instruction[] =
2462  {0x0f,0x7e,0x41,0xfa};
2463
2464alloc_instruction_id
2465recognize_alloc_instruction(pc program_counter)
2466{
2467  switch(program_counter[0]) {
2468  case 0xcd: return ID_alloc_trap_instruction;
2469  case 0x77: return ID_branch_around_alloc_trap_instruction;
2470  case 0x0f: return ID_set_allocptr_header_instruction;
2471  case 0x64: 
2472    switch(program_counter[1]) {
2473    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2474    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2475    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2476    }
2477  }
2478  return ID_unrecognized_alloc_instruction;
2479}
2480#endif     
2481
2482void
2483pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2484{
2485  pc program_counter = (pc)xpPC(xp);
2486  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2487
2488  if (allocptr_tag != 0) {
2489    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2490    signed_natural
2491      disp = (allocptr_tag == fulltag_cons) ?
2492      sizeof(cons) - fulltag_cons :
2493#ifdef X8664
2494      xpGPR(xp,Iimm1)
2495#else
2496      xpGPR(xp,Iimm0)
2497#endif
2498      ;
2499    LispObj new_vector;
2500
2501    if ((state == ID_unrecognized_alloc_instruction) ||
2502        ((state == ID_set_allocptr_header_instruction) &&
2503         (allocptr_tag != fulltag_misc))) {
2504      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2505    }
2506    switch(state) {
2507    case ID_set_allocptr_header_instruction:
2508      /* We were consing a vector and we won.  Set the header of the
2509         new vector (in the allocptr register) to the header in %rax
2510         (%mm0 on ia32) and skip over this instruction, then fall into
2511         the next case. */
2512      new_vector = xpGPR(xp,Iallocptr);
2513      deref(new_vector,0) = 
2514#ifdef X8664
2515        xpGPR(xp,Iimm0)
2516#else
2517        xpMMXreg(xp,Imm0)
2518#endif
2519        ;
2520     
2521      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2522
2523      /* Fall thru */
2524    case ID_clear_tcr_save_allocptr_tag_instruction:
2525      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2526      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2527
2528      break;
2529    case ID_alloc_trap_instruction:
2530      /* If we're looking at another thread, we're pretty much committed to
2531         taking the trap.  We don't want the allocptr register to be pointing
2532         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2533         was determined above.
2534      */
2535      if (interrupt_displacement == NULL) {
2536        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2537        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2538      } else {
2539        /* Back out, and tell the caller how to resume the allocation attempt */
2540        *interrupt_displacement = disp;
2541        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2542        tcr->save_allocptr += disp;
2543        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2544                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2545                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2546      }
2547      break;
2548    case ID_branch_around_alloc_trap_instruction:
2549      /* If we'd take the branch - which is a "ja" - around the alloc trap,
2550         we might as well finish the allocation.  Otherwise, back out of the
2551         attempt. */
2552      {
2553        int flags = (int)eflags_register(xp);
2554       
2555        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2556            (!(flags & (1 << X86_CARRY_FLAG_BIT)))) {
2557          /* The branch (ja) would have been taken.  Emulate taking it. */
2558          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2559                       sizeof(alloc_trap_instruction));
2560          if (allocptr_tag == fulltag_misc) {
2561            /* Slap the header on the new uvector */
2562            new_vector = xpGPR(xp,Iallocptr);
2563#ifdef X8664
2564            deref(new_vector,0) = xpGPR(xp,Iimm0);
2565#else
2566            deref(new_vector,0) = xpMMXreg(xp,Imm0);
2567#endif
2568            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2569          }
2570          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2571          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2572        } else {
2573          /* Back up */
2574          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2575                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2576          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2577          if (interrupt_displacement) {
2578            *interrupt_displacement = disp;
2579            tcr->save_allocptr += disp;
2580          } else {
2581            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2582          }
2583        }
2584      }
2585      break;
2586    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2587      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2588      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2589      /* Fall through */
2590    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2591      if (interrupt_displacement) {
2592        tcr->save_allocptr += disp;
2593        *interrupt_displacement = disp;
2594      } else {
2595        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2596      }
2597      break;
2598    default: 
2599      break;
2600    }
2601    return;
2602  }
2603  if ((program_counter >= &egc_write_barrier_start) &&
2604      (program_counter < &egc_write_barrier_end)) {
2605    LispObj *ea = 0, val, root = 0;
2606    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2607    Boolean  need_check_memo = true, need_memoize_root = false;
2608
2609    if (program_counter >= &egc_set_hash_key_conditional) {
2610      if (program_counter <= &egc_set_hash_key_conditional_retry) {
2611        return;
2612      }
2613      if (program_counter < &egc_set_hash_key_conditional_success_test) {
2614        /* Back up the PC, try again.  This is necessary since a pending
2615           GC may cause the value in %eax/%rax to move and backing up
2616           will reload %eax/%rax from a node register before trying the
2617           cmpxchg.
2618        */
2619        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry;
2620        return;
2621      }
2622      if ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2623          !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT))) {
2624        /* Conditional store failed.  Return NIL. */
2625        LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2626        xpGPR(xp,Iarg_z) = lisp_nil;
2627        xpPC(xp) = ra;
2628        xpGPR(xp,Isp)=(LispObj)sp;
2629        return;
2630      }
2631      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2632      val = xpGPR(xp,Iarg_z);
2633#ifdef X8664
2634      root = xpGPR(xp,Iarg_x);
2635      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2636#else
2637      root = xpGPR(xp,Itemp1);
2638      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2639#endif
2640      need_memoize_root = true;
2641      xpGPR(xp,Iarg_z) = t_value;
2642    } else if (program_counter >= &egc_store_node_conditional) {
2643      if (program_counter <= &egc_store_node_conditional_retry) {
2644        return;
2645      }
2646      if (program_counter < &egc_store_node_conditional_success_test) {
2647        /* Back up the PC, try again.  Again, this is necessary because
2648           we're possibly keeping a node in %eax/%rax and haven't completed
2649           the cmpxchg yet. */
2650        xpPC(xp) = (LispObj) &egc_store_node_conditional_retry;
2651        return;
2652      }
2653      if ((program_counter == &egc_store_node_conditional_success_test) &&
2654           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT))) {
2655        /* cmpxchg failed.  Return NIL. */
2656        LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2657        xpGPR(xp,Iarg_z) = lisp_nil;
2658        xpPC(xp) = ra;
2659        xpGPR(xp,Isp)=(LispObj)sp;
2660        return;
2661      }
2662
2663      if (program_counter >= &egc_store_node_conditional_success_end) {
2664        return;
2665      }
2666
2667      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2668      val = xpGPR(xp,Iarg_z);
2669#ifdef X8664
2670      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2671                                                       xpGPR(xp,Itemp0))));
2672#else
2673      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2674#endif
2675      xpGPR(xp,Iarg_z) = t_value;
2676    } else if (program_counter >= &egc_set_hash_key) {
2677      if (program_counter == &egc_set_hash_key) {
2678        return;
2679      }
2680#ifdef X8664
2681      root = xpGPR(xp,Iarg_x);
2682#else
2683      root = xpGPR(xp,Itemp0);
2684#endif
2685      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2686      val = xpGPR(xp,Iarg_z);
2687      need_memoize_root = true;
2688    } else if (program_counter >= &egc_gvset) {
2689      /* This assumes that the store is the first instruction at _SPgvset.
2690         As of late February 2013 - just before the 1.9 release, that's
2691         a relatively recent change.
2692         If the store has already completed, don't do it again.
2693         See ticket:1058 for an example showing why this matters.
2694      */
2695      if (program_counter == &egc_gvset) {
2696        return;
2697      }
2698#ifdef X8664
2699      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2700#else
2701      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2702#endif
2703      val = xpGPR(xp,Iarg_z);
2704    } else if (program_counter >= &egc_rplacd) {
2705      if (program_counter == &egc_rplacd) {
2706        return;
2707      }
2708      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2709      val = xpGPR(xp,Iarg_z);
2710    } else {                      /* egc_rplaca */
2711      if (program_counter == &egc_rplaca) {
2712        return;
2713      }
2714      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2715      val = xpGPR(xp,Iarg_z);
2716    }
2717    if (need_check_memo) {
2718      if ((LispObj)ea < val) {
2719        natural  bitnumber = area_dnode(ea, lisp_global(REF_BASE)),
2720          rootbitnumber = area_dnode(root, lisp_global(REF_BASE));
2721        if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT))) {
2722          atomic_set_bit(refbits, bitnumber);
2723          atomic_set_bit(global_refidx,bitnumber>>8);
2724          if (need_memoize_root) {
2725            atomic_set_bit(refbits, rootbitnumber);
2726            atomic_set_bit(global_refidx,rootbitnumber>>8);
2727          }
2728        }
2729        if (bitnumber < lisp_global(MANAGED_STATIC_DNODES)) {
2730          atomic_set_bit(managed_static_refbits,bitnumber);
2731          atomic_set_bit(managed_static_refidx,bitnumber>>8);
2732          if (need_memoize_root) {
2733            atomic_set_bit(managed_static_refbits, rootbitnumber);
2734            atomic_set_bit(managed_static_refidx,rootbitnumber>>8);
2735          }
2736        }
2737      }
2738    }
2739    {
2740      /* These subprimitives are called via CALL/RET; need
2741         to pop the return address off the stack and set
2742         the PC there. */
2743      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2744      xpPC(xp) = ra;
2745      xpGPR(xp,Isp)=(LispObj)sp;
2746    }
2747    return;
2748  }
2749}
2750
2751
2752void
2753normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2754{
2755  void *cur_allocptr = (void *)(tcr->save_allocptr);
2756  LispObj lisprsp;
2757  area *a;
2758
2759  if (xp) {
2760    if (is_other_tcr) {
2761      pc_luser_xp(xp, tcr, NULL);
2762    }
2763    a = tcr->vs_area;
2764    lisprsp = xpGPR(xp, Isp);
2765    if (((BytePtr)lisprsp >= a->low) &&
2766        ((BytePtr)lisprsp < a->high)) {
2767      a->active = (BytePtr)lisprsp;
2768    } else {
2769      a->active = (BytePtr) tcr->save_vsp;
2770    }
2771    a = tcr->ts_area;
2772    a->active = (BytePtr) tcr->save_tsp;
2773  } else {
2774    /* In ff-call; get area active pointers from tcr */
2775    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2776    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2777  }
2778  if (cur_allocptr) {
2779    update_bytes_allocated(tcr, cur_allocptr);
2780  }
2781  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2782  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2783    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2784  }
2785}
2786
2787
2788/* Suspend and "normalize" other tcrs, then call a gc-like function
2789   in that context.  Resume the other tcrs, then return what the
2790   function returned */
2791
2792TCR *gc_tcr = NULL;
2793
2794
2795signed_natural
2796gc_like_from_xp(ExceptionInformation *xp, 
2797                signed_natural(*fun)(TCR *, signed_natural), 
2798                signed_natural param)
2799{
2800  TCR *tcr = get_tcr(false), *other_tcr;
2801  int result;
2802  signed_natural inhibit;
2803
2804  suspend_other_threads(true);
2805  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2806  if (inhibit != 0) {
2807    if (inhibit > 0) {
2808      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2809    }
2810    resume_other_threads(true);
2811    gc_deferred++;
2812    return 0;
2813  }
2814  gc_deferred = 0;
2815
2816  gc_tcr = tcr;
2817
2818  /* This is generally necessary if the current thread invoked the GC
2819     via an alloc trap, and harmless if the GC was invoked via a GC
2820     trap.  (It's necessary in the first case because the "allocptr"
2821     register - %rbx - may be pointing into the middle of something
2822     below tcr->save_allocbase, and we wouldn't want the GC to see
2823     that bogus pointer.) */
2824  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2825
2826  normalize_tcr(xp, tcr, false);
2827
2828
2829  for (other_tcr = TCR_AUX(tcr)->next; other_tcr != tcr;
2830       other_tcr = TCR_AUX(other_tcr)->next) {
2831    if (other_tcr->pending_exception_context) {
2832      TCR_AUX(other_tcr)->gc_context = other_tcr->pending_exception_context;
2833    } else if (other_tcr->valence == TCR_STATE_LISP) {
2834      TCR_AUX(other_tcr)->gc_context = TCR_AUX(other_tcr)->suspend_context;
2835    } else {
2836      /* no pending exception, didn't suspend in lisp state:
2837         must have executed a synchronous ff-call.
2838      */
2839      TCR_AUX(other_tcr)->gc_context = NULL;
2840    }
2841    normalize_tcr(TCR_AUX(other_tcr)->gc_context, other_tcr, true);
2842  }
2843   
2844
2845
2846  result = fun(tcr, param);
2847
2848  other_tcr = tcr;
2849  do {
2850    TCR_AUX(other_tcr)->gc_context = NULL;
2851    other_tcr = TCR_AUX(other_tcr)->next;
2852  } while (other_tcr != tcr);
2853
2854  gc_tcr = NULL;
2855
2856  resume_other_threads(true);
2857
2858  return result;
2859
2860}
2861
2862signed_natural
2863purify_from_xp(ExceptionInformation *xp, signed_natural param)
2864{
2865  return gc_like_from_xp(xp, purify, param);
2866}
2867
2868signed_natural
2869impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2870{
2871  return gc_like_from_xp(xp, impurify, param);
2872}
2873
2874/* Returns #bytes freed by invoking GC */
2875
2876signed_natural
2877gc_from_tcr(TCR *tcr, signed_natural param)
2878{
2879  area *a;
2880  BytePtr oldfree, newfree;
2881  BytePtr oldend, newend;
2882
2883#if 0
2884  fprintf(dbgout, "Start GC  in 0x" LISP "\n", tcr);
2885#endif
2886  a = active_dynamic_area;
2887  oldend = a->high;
2888  oldfree = a->active;
2889  gc(tcr, param);
2890  newfree = a->active;
2891  newend = a->high;
2892#if 0
2893  fprintf(dbgout, "End GC  in 0x" LISP "\n", tcr);
2894#endif
2895  return ((oldfree-newfree)+(newend-oldend));
2896}
2897
2898signed_natural
2899gc_from_xp(ExceptionInformation *xp, signed_natural param)
2900{
2901  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
2902
2903  freeGCptrs();
2904  return status;
2905}
2906
2907
2908/* watchpoint stuff */
2909
2910area *
2911new_watched_area(natural size)
2912{
2913  char *p;
2914
2915  p = MapMemory(NULL, size, MEMPROTECT_RWX);
2916  if ((signed_natural)p == -1) {
2917    allocation_failure(true, size);
2918  }
2919  return new_area(p, p + size, AREA_WATCHED);
2920}
2921
2922void
2923delete_watched_area(area *a, TCR *tcr)
2924{
2925  natural nbytes = a->high - a->low;
2926  char *base = a->low;
2927
2928  condemn_area_holding_area_lock(a);
2929
2930  if (nbytes) {
2931    int err;
2932
2933    err = UnMapMemory(base, nbytes);
2934    if (err != 0)
2935      Fatal("munmap in delete_watched_area", "");
2936  }
2937}
2938
2939natural
2940uvector_total_size_in_bytes(LispObj *u)
2941{
2942  LispObj header = header_of(u);
2943  natural header_tag = fulltag_of(header);
2944  natural subtag = header_subtag(header);
2945  natural element_count = header_element_count(header);
2946  natural nbytes = 0;
2947
2948#ifdef X8632
2949  if ((nodeheader_tag_p(header_tag)) ||
2950      (subtag <= max_32_bit_ivector_subtag)) {
2951    nbytes = element_count << 2;
2952  } else if (subtag <= max_8_bit_ivector_subtag) {
2953    nbytes = element_count;
2954  } else if (subtag <= max_16_bit_ivector_subtag) {
2955    nbytes = element_count << 1;
2956  } else if (subtag == subtag_double_float_vector) {
2957    nbytes = element_count << 3;
2958  } else {
2959    nbytes = (element_count + 7) >> 3;
2960  }
2961  /* add 4 byte header and round up to multiple of 8 bytes */
2962  return ~7 & (4 + nbytes + 7);
2963#endif
2964#ifdef X8664
2965  if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) {
2966    nbytes = element_count << 3;
2967  } else if (header_tag == ivector_class_32_bit) {
2968    nbytes = element_count << 2;
2969  } else {
2970    /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */
2971    if (subtag == subtag_bit_vector) {
2972      nbytes = (element_count + 7) >> 3;
2973    } else if (subtag >= min_8_bit_ivector_subtag) {
2974      nbytes = element_count;
2975    } else {
2976      nbytes = element_count << 1;
2977    }
2978  }
2979  /* add 8 byte header and round up to multiple of 16 bytes */
2980  return ~15 & (8 + nbytes + 15);
2981#endif
2982}
2983
2984extern void wp_update_references(TCR *, LispObj, LispObj);
2985
2986/*
2987 * Other threads are suspended and pc-lusered.
2988 *
2989 * param contains a tagged pointer to a uvector or a cons cell
2990 */
2991signed_natural
2992watch_object(TCR *tcr, signed_natural param)
2993{
2994  LispObj object = (LispObj)param;
2995  unsigned tag = fulltag_of(object);
2996  LispObj *noderef = (LispObj *)untag(object);
2997  area *object_area = area_containing((BytePtr)noderef);
2998  natural size;
2999
3000  if (tag == fulltag_cons)
3001    size = 2 * node_size;
3002  else
3003    size = uvector_total_size_in_bytes(noderef);
3004
3005  if (object_area && object_area->code == AREA_DYNAMIC) {
3006    area *a = new_watched_area(size);
3007    LispObj old = object;
3008    LispObj new = (LispObj)((natural)a->low + tag);
3009
3010    add_area_holding_area_lock(a);
3011
3012    /* move object to watched area */
3013    memcpy(a->low, noderef, size);
3014    ProtectMemory(a->low, size);
3015    memset(noderef, 0, size);
3016    wp_update_references(tcr, old, new);
3017    check_all_areas(tcr);
3018    return 1;
3019  }
3020  return 0;
3021}
3022
3023/*
3024 * We expect the watched object in arg_y, and the new uninitialized
3025 * object (which is just zeroed) in arg_z.
3026 */
3027signed_natural
3028unwatch_object(TCR *tcr, signed_natural param)
3029{
3030  ExceptionInformation *xp = tcr->xframe->curr;
3031  LispObj old = xpGPR(xp, Iarg_y);
3032  unsigned tag = fulltag_of(old);
3033  LispObj new = xpGPR(xp, Iarg_z);
3034  LispObj *oldnode = (LispObj *)untag(old);
3035  LispObj *newnode = (LispObj *)untag(new);
3036  area *a = area_containing((BytePtr)old);
3037  extern void update_managed_refs(area *, BytePtr, natural);
3038
3039  if (a && a->code == AREA_WATCHED) {
3040    natural size;
3041
3042    if (tag == fulltag_cons)
3043      size = 2 * node_size;
3044    else
3045      size = uvector_total_size_in_bytes(oldnode);
3046
3047    memcpy(newnode, oldnode, size);
3048    delete_watched_area(a, tcr);
3049    wp_update_references(tcr, old, new);
3050    /* because wp_update_references doesn't update refbits */
3051    tenure_to_area(tenured_area);
3052    /* Unwatching can (re-)introduce managed_static->dynamic references */
3053    zero_bits(managed_static_area->refbits,managed_static_area->ndnodes);
3054    update_managed_refs(managed_static_area, low_markable_address, area_dnode(active_dynamic_area->active, low_markable_address));
3055    check_all_areas(tcr);
3056    xpGPR(xp, Iarg_z) = new;
3057  }
3058  return 0;
3059}
3060
3061Boolean
3062handle_watch_trap(ExceptionInformation *xp, TCR *tcr)
3063{
3064  LispObj selector = xpGPR(xp,Iimm0);
3065  LispObj object = xpGPR(xp, Iarg_z);
3066  signed_natural result;
3067 
3068  switch (selector) {
3069    case WATCH_TRAP_FUNCTION_WATCH:
3070      result = gc_like_from_xp(xp, watch_object, object);
3071      if (result == 0)
3072        xpGPR(xp,Iarg_z) = lisp_nil;
3073      break;
3074    case WATCH_TRAP_FUNCTION_UNWATCH:
3075      gc_like_from_xp(xp, unwatch_object, 0);
3076      break;
3077    default:
3078      break;
3079  }
3080  return true;
3081}
3082
Note: See TracBrowser for help on using the repository browser.