source: release/1.9/source/lisp-kernel/x86-exceptions.c @ 15706

Last change on this file since 15706 was 15706, checked in by gb, 6 years ago

Propagate recent trunk changes.

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