source: trunk/source/lisp-kernel/x86-exceptions.c @ 15572

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

If we get a SIGSEGV or SIGBUS while executing foreign code when
tcr->safe_ref_address is non-nil, try to recover by making it look
like the current ffcall has returned a null pointer.

Try to use this mechanism to recognize tagged ObjC instances. (Part
of that process involves sending -[NSObject class] to something that
may or may not be an ObjC instance, and if the instance isn't valid
that message will likely generate a memory fault.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 83.2 KB
Line 
1/*
2   Copyright (C) 2005-2009 Clozure Associates
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "lisp-exceptions.h"
19#include "lisp_globals.h"
20#include "x86-utils.h"
21#include "threads.h"
22#include <ctype.h>
23#include <stdio.h>
24#include <stddef.h>
25#include <string.h>
26#include <stdarg.h>
27#include <errno.h>
28#include <stdio.h>
29#ifdef LINUX
30#include <strings.h>
31#include <sys/mman.h>
32#include <fpu_control.h>
33#include <linux/prctl.h>
34#endif
35#ifdef DARWIN
36#include <sysexits.h>
37#endif
38#ifndef WINDOWS
39#include <sys/syslog.h>
40#endif
41#ifdef WINDOWS
42#include <windows.h>
43#ifdef WIN_64
44#include <winternl.h>
45#include <ntstatus.h>
46#endif
47#ifndef EXCEPTION_WRITE_FAULT
48#define EXCEPTION_WRITE_FAULT 1
49#endif
50#endif
51
52/*
53  We do all kinds of funky things to avoid handling a signal on the lisp
54  stack.  One of those funky things involves using the  __builtin_return_address()
55  intrinsic so that the real handler returns to the right place when it exits,
56  even if it returns on a different stack.  Code at "the right place" is presumed
57  to just do a sigrereturn, however the OS does that.
58
59  Sadly, some JVMs (at least) do what they call "signal chaining": they install
60  their own handlers for signals that we expect to handle, and call our handler
61  when they realize that they don't know how to handle what we raise.  They
62  don't observe sigaltstack, and they don't necessarily do call our handler
63  tail-recursively (so our stack-switching code would cause our handler to
64  return to the JVM's, running on the wrong stack.
65
66  Try to work around this by setting up an "early" signal handler (before any
67  of this JVM nonsense can take effect) and noting the address it'd return to.
68*/
69
70pc
71real_sigreturn = (pc)0;
72
73#define SIGRETURN_ADDRESS() (real_sigreturn ? real_sigreturn : __builtin_return_address(0))
74
75#ifndef WINDOWS
76#ifndef DARWIN
77void
78early_intn_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
79{
80  real_sigreturn = (pc) __builtin_return_address(0);
81  xpPC(xp) += 2;
82}
83
84#endif
85#endif
86
87void
88do_intn()
89{
90  __asm volatile("int $0xcd");
91}
92
93
94void
95x86_early_exception_init()
96{
97#ifndef WINDOWS
98#ifndef DARWIN
99  struct sigaction action, oaction;
100
101  action.sa_sigaction = (void *) early_intn_handler;
102  sigfillset(&action.sa_mask);
103  action.sa_flags = SA_SIGINFO;
104  sigaction(SIGNUM_FOR_INTN_TRAP,&action,&oaction);
105 
106  do_intn();
107  sigaction(SIGNUM_FOR_INTN_TRAP,&oaction, NULL);
108#endif
109#endif
110}
111
112int
113page_size = 4096;
114
115int
116log2_page_size = 12;
117
118Boolean
119did_gc_notification_since_last_full_gc = false;
120
121
122void
123update_bytes_allocated(TCR* tcr, void *cur_allocptr)
124{
125  char *last = tcr->last_allocptr;
126  char *current = cur_allocptr;
127  u64_t *bytes_allocated = (u64_t *)&TCR_AUX(tcr)->bytes_allocated;
128
129  if (last && (tcr->save_allocbase != ((void *)VOID_ALLOCPTR))) {
130    *bytes_allocated += last - current;
131  }
132  tcr->last_allocptr = 0;
133}
134
135
136
137//  This doesn't GC; it returns true if it made enough room, false
138//  otherwise.
139//  If "extend" is true, it can try to extend the dynamic area to
140//  satisfy the request.
141
142
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#ifdef DARWIN
1509LispObj *
1510copy_darwin_mcontext(MCONTEXT_T context, 
1511                     LispObj *current, 
1512                     MCONTEXT_T *out)
1513{
1514  MCONTEXT_T dest = ((MCONTEXT_T)current)-1;
1515  dest = (MCONTEXT_T) (((LispObj)dest) & ~15);
1516
1517  *dest = *context;
1518  *out = dest;
1519  return (LispObj *)dest;
1520}
1521#endif
1522
1523LispObj *
1524copy_siginfo(siginfo_t *info, LispObj *current)
1525{
1526  siginfo_t *dest = ((siginfo_t *)current) - 1;
1527#if !defined(LINUX) || !defined(X8632)
1528  dest = (siginfo_t *) (((LispObj)dest)&~15);
1529#endif
1530  *dest = *info;
1531  return (LispObj *)dest;
1532}
1533
1534#ifdef LINUX
1535typedef FPREGS copy_ucontext_last_arg_t;
1536#else
1537typedef void * copy_ucontext_last_arg_t;
1538#endif
1539
1540#ifndef WINDOWS
1541LispObj *
1542copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp)
1543{
1544  ExceptionInformation *dest = ((ExceptionInformation *)current)-1;
1545#if !defined(LINUX) || !defined(X8632)
1546  dest = (ExceptionInformation *) (((LispObj)dest) & ~15);
1547#endif
1548
1549  *dest = *context;
1550  /* Fix it up a little; where's the signal mask allocated, if indeed
1551     it is "allocated" ? */
1552#ifdef LINUX
1553  dest->uc_mcontext.fpregs = (fpregset_t)fp;
1554#endif
1555  dest->uc_stack.ss_sp = 0;
1556  dest->uc_stack.ss_size = 0;
1557  dest->uc_stack.ss_flags = 0;
1558  dest->uc_link = NULL;
1559  return (LispObj *)dest;
1560}
1561#endif
1562
1563
1564LispObj *
1565tcr_frame_ptr(TCR *tcr)
1566{
1567  ExceptionInformation *xp;
1568  LispObj *fp;
1569
1570  if (tcr->pending_exception_context)
1571    xp = tcr->pending_exception_context;
1572  else if (tcr->valence == TCR_STATE_LISP) {
1573    xp = TCR_AUX(tcr)->suspend_context;
1574  } else {
1575    xp = NULL;
1576  }
1577  if (xp) {
1578    fp = (LispObj *)xpGPR(xp, Ifp);
1579  } else {
1580    fp = tcr->save_fp;
1581  }
1582  return fp;
1583}
1584
1585
1586LispObj *
1587find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr)
1588{
1589
1590  if (((BytePtr)rsp < foreign_area->low) ||
1591      ((BytePtr)rsp > foreign_area->high)) {
1592    rsp = (LispObj)(tcr->foreign_sp);
1593  }
1594  return (LispObj *) (((rsp-128) & ~15));
1595}
1596
1597#ifdef X8632
1598#ifdef LINUX
1599/* This is here for debugging.  On entry to a signal handler that
1600   receives info and context arguments, the stack should look exactly
1601   like this.  The "pretcode field" of the structure is the address
1602   of code that does an rt_sigreturn syscall, and rt_sigreturn expects
1603   %esp at the time of that syscall to be pointing just past the
1604   pretcode field.
1605   handle_signal_on_foreign_stack() and helpers have to be very
1606   careful to duplicate this "structure" exactly.
1607   Note that on x8664 Linux, rt_sigreturn expects a ucontext to
1608   be on top of the stack (with a siginfo_t underneath it.)
1609   It sort of half-works to do sigreturn via setcontext() on
1610   x8632 Linux, but (a) it may not be available on some distributions
1611   and (b) even a relatively modern version of it uses "fldenv" to
1612   restore FP context, and "fldenv" isn't nearly good enough.
1613*/
1614
1615struct rt_sigframe {
1616        char *pretcode;
1617        int sig;
1618        siginfo_t  *pinfo;
1619        void  *puc;
1620        siginfo_t info;
1621        struct ucontext uc;
1622        struct _fpstate fpstate;
1623        char retcode[8];
1624};
1625struct rt_sigframe *rtsf = 0;
1626
1627#endif
1628#endif
1629
1630
1631#ifndef WINDOWS
1632/* x8632 Linux requires that the stack-allocated siginfo is nearer
1633   the top of stack than the stack-allocated ucontext.  If other
1634   platforms care, they expect the ucontext to be nearer the top
1635   of stack.
1636*/
1637
1638#if defined(LINUX) && defined(X8632)
1639#define UCONTEXT_ON_TOP_OF_STACK 0
1640#else
1641#define UCONTEXT_ON_TOP_OF_STACK 1
1642#endif
1643void
1644handle_signal_on_foreign_stack(TCR *tcr,
1645                               void *handler, 
1646                               int signum, 
1647                               siginfo_t *info, 
1648                               ExceptionInformation *context,
1649                               LispObj return_address
1650                               )
1651{
1652#ifdef LINUX
1653  FPREGS fpregs = NULL;
1654#else
1655  void *fpregs = NULL;
1656#endif
1657#ifdef DARWIN
1658  MCONTEXT_T mcontextp = NULL;
1659#endif
1660  siginfo_t *info_copy = NULL;
1661  ExceptionInformation *xp = NULL;
1662  LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr);
1663
1664#ifdef LINUX
1665  foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs);
1666#endif
1667#ifdef DARWIN
1668  foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp);
1669#endif
1670#if UCONTEXT_ON_TOP_OF_STACK
1671  /* copy info first */
1672  foreign_rsp = copy_siginfo(info, foreign_rsp);
1673  info_copy = (siginfo_t *)foreign_rsp;
1674  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1675  xp = (ExceptionInformation *)foreign_rsp;
1676#else
1677  foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs);
1678  xp = (ExceptionInformation *)foreign_rsp;
1679  foreign_rsp = copy_siginfo(info, foreign_rsp);
1680  info_copy = (siginfo_t *)foreign_rsp;
1681#endif
1682#ifdef DARWIN
1683  UC_MCONTEXT(xp) = mcontextp;
1684#endif
1685  *--foreign_rsp = return_address;
1686  switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp);
1687}
1688#endif
1689
1690
1691#ifndef WINDOWS
1692#ifndef USE_SIGALTSTACK
1693void
1694arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
1695{
1696  TCR *tcr = get_interrupt_tcr(false);
1697#if 1
1698  if (tcr->valence != TCR_STATE_LISP) {
1699    lisp_Debugger(context, info, signum, true, "exception in foreign context");
1700  }
1701#endif
1702  {
1703    area *vs = tcr->vs_area;
1704    BytePtr current_sp = (BytePtr) current_stack_pointer();
1705
1706
1707    if ((current_sp >= vs->low) &&
1708        (current_sp < vs->high)) {
1709      handle_signal_on_foreign_stack(tcr,
1710                                     signal_handler,
1711                                     signum,
1712                                     info,
1713                                     context,
1714                                     (LispObj)__builtin_return_address(0)
1715
1716                                     );
1717    } else {
1718      signal_handler(signum, info, context);
1719    }
1720  }
1721}
1722
1723#else
1724void
1725altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context)
1726{
1727  TCR* tcr = get_tcr(true);
1728  Boolean do_stack_switch = false;
1729  stack_t ss;
1730
1731  if ((tcr->valence != TCR_STATE_LISP) &&
1732      (tcr->safe_ref_address) &&
1733      ((signum == SIGBUS) || (signum == SIGSEGV))) {
1734    extern opcode ffcall_return;
1735    xpPC(context) = (natural)&ffcall_return;
1736    xpGPR(context,Iimm0) = 0;
1737    xpGPR(context,Isp) = (natural)(tcr->foreign_sp);
1738    return;
1739  }
1740
1741
1742
1743
1744
1745#if WORD_SIZE==64
1746  if ((signum == SIGFPE) && (tcr->valence != TCR_STATE_LISP)) {
1747    if (handle_foreign_fpe(tcr,context,info)) {
1748      return;
1749    }
1750  }
1751#endif
1752     
1753  /* Because of signal chaining - and the possibility that libraries
1754     that use it ignore sigaltstack-related issues - we have to check
1755     to see if we're actually on the altstack.
1756
1757     When OpenJDK VMs overwrite preinstalled signal handlers (that're
1758     there for a reason ...), they're also casual about SA_RESTART.
1759     We care about SA_RESTART (mostly) in the PROCESS-INTERRUPT case,
1760     and whether a JVM steals the signal used for PROCESS-INTERRUPT
1761     is platform-dependent.  On those platforms where the same signal
1762     is used, we should strongly consider trying to use another one.
1763  */
1764  sigaltstack(NULL, &ss);
1765  if (ss.ss_flags == SS_ONSTACK) {
1766    do_stack_switch = true;
1767  } else {
1768    area *vs = tcr->vs_area;
1769    BytePtr current_sp = (BytePtr) current_stack_pointer();
1770
1771    if ((current_sp >= vs->low) &&
1772        (current_sp < vs->high)) {
1773      do_stack_switch = true;
1774    }
1775  }
1776  if (do_stack_switch) {
1777    handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)SIGRETURN_ADDRESS());
1778  } else {
1779    signal_handler(signum,info,context);
1780  }
1781}
1782#endif
1783#endif
1784
1785Boolean
1786stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr)
1787{
1788  area *a = tcr->vs_area;
1789 
1790  return (((BytePtr)stack_pointer <= a->high) &&
1791          ((BytePtr)stack_pointer > a->low));
1792}
1793
1794
1795#ifdef WINDOWS
1796extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int);
1797#endif
1798
1799void
1800interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1801{
1802  TCR *tcr = get_interrupt_tcr(false);
1803  int old_valence = tcr->valence;
1804
1805  if (tcr) {
1806    if ((TCR_INTERRUPT_LEVEL(tcr) < 0) ||
1807        (tcr->valence != TCR_STATE_LISP) ||
1808        (tcr->unwinding != 0) ||
1809        ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) ||
1810        ! stack_pointer_on_vstack_p(xpGPR(context,Ifp), tcr)) {
1811      tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1)));
1812    } else {
1813      LispObj cmain = nrs_CMAIN.vcell;
1814     
1815      ResetAltStack();
1816      if ((fulltag_of(cmain) == fulltag_misc) &&
1817          (header_subtag(header_of(cmain)) == subtag_macptr)) {
1818        /*
1819           This thread can (allegedly) take an interrupt now.
1820        */
1821
1822        xframe_list xframe_link;
1823        signed_natural alloc_displacement = 0;
1824        LispObj
1825          *next_tsp = tcr->next_tsp,
1826          *save_tsp = tcr->save_tsp,
1827          *p,
1828          q;
1829        natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1830
1831        tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION);
1832           
1833        if (next_tsp != save_tsp) {
1834          tcr->next_tsp = save_tsp;
1835        } else {
1836          next_tsp = NULL;
1837        }
1838        /* have to do this before allowing interrupts */
1839        pc_luser_xp(context, tcr, &alloc_displacement);
1840        old_valence = prepare_to_wait_for_exception_lock(tcr, context);
1841        wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
1842        handle_exception(signum, info, context, tcr, old_valence);
1843        if (alloc_displacement) {
1844          tcr->save_allocptr -= alloc_displacement;
1845        }
1846        if (next_tsp) {
1847          tcr->next_tsp = next_tsp;
1848          p = next_tsp;
1849          while (p != save_tsp) {
1850            *p++ = 0;
1851          }
1852          q = (LispObj)save_tsp;
1853          *next_tsp = q;
1854        }
1855        tcr->flags |= old_foreign_exception;
1856        unlock_exception_lock_in_handler(tcr);
1857#ifndef WINDOWS
1858        exit_signal_handler(tcr, old_valence);
1859#endif
1860      }
1861    }
1862  }
1863#ifdef WINDOWS
1864  restore_windows_context(context,tcr,old_valence);
1865#else
1866  SIGRETURN(context);
1867#endif
1868}
1869
1870
1871#ifndef WINDOWS
1872#ifndef USE_SIGALTSTACK
1873void
1874arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1875{
1876  TCR *tcr = get_interrupt_tcr(false);
1877  area *vs = tcr->vs_area;
1878  BytePtr current_sp = (BytePtr) current_stack_pointer();
1879
1880  if ((current_sp >= vs->low) &&
1881      (current_sp < vs->high)) {
1882    handle_signal_on_foreign_stack(tcr,
1883                                   interrupt_handler,
1884                                   signum,
1885                                   info,
1886                                   context,
1887                                   (LispObj)__builtin_return_address(0)
1888                                   );
1889  } else {
1890    /* If we're not on the value stack, we pretty much have to be on
1891       the C stack.  Just run the handler. */
1892    interrupt_handler(signum, info, context);
1893  }
1894}
1895
1896#else /* altstack works */
1897
1898/*
1899   There aren't likely any JVM-related signal-chaining issues here, since
1900   on platforms where that could be an issue we use either an RT signal
1901   or an unused synchronous hardware signal to raise interrupts.
1902*/
1903void
1904altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context)
1905{
1906  TCR *tcr = get_interrupt_tcr(false);
1907  handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0)
1908                                 );
1909}
1910
1911#endif
1912#endif
1913
1914#ifndef WINDOWS
1915void
1916install_signal_handler(int signo, void *handler, unsigned flags)
1917{
1918  struct sigaction sa;
1919  int err;
1920 
1921  sa.sa_sigaction = (void *)handler;
1922  sigfillset(&sa.sa_mask);
1923#ifdef FREEBSD
1924  /* Strange FreeBSD behavior wrt synchronous signals */
1925  sigdelset(&sa.sa_mask,SIGTRAP);  /* let GDB work */
1926#endif
1927  sa.sa_flags = SA_SIGINFO;
1928
1929#ifdef USE_SIGALTSTACK
1930  if (flags & ON_ALTSTACK)
1931    sa.sa_flags |= SA_ONSTACK;
1932#endif
1933  if (flags & RESTART_SYSCALLS)
1934    sa.sa_flags |= SA_RESTART;
1935  if (flags & RESERVE_FOR_LISP) {
1936    extern sigset_t user_signals_reserved;
1937    sigaddset(&user_signals_reserved, signo);
1938  }
1939
1940  err = sigaction(signo, &sa, NULL);
1941  if (err) {
1942    perror("sigaction");
1943    exit(1);
1944  }
1945}
1946#endif
1947
1948#ifdef WINDOWS
1949BOOL
1950CALLBACK ControlEventHandler(DWORD event)
1951{
1952  switch(event) {
1953  case CTRL_C_EVENT:
1954    lisp_global(INTFLAG) = (1 << fixnumshift);
1955    return TRUE;
1956    break;
1957  case CTRL_BREAK_EVENT:
1958    lisp_global(INTFLAG) = (2 << fixnumshift);
1959    return TRUE;
1960    break;
1961  default:
1962    return FALSE;
1963  }
1964}
1965
1966static
1967DWORD mxcsr_bit_to_fpe_code[] = {
1968  EXCEPTION_FLT_INVALID_OPERATION, /* ie */
1969  0,                            /* de */
1970  EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */
1971  EXCEPTION_FLT_OVERFLOW,       /* oe */
1972  EXCEPTION_FLT_UNDERFLOW,      /* ue */
1973  EXCEPTION_FLT_INEXACT_RESULT  /* pe */
1974};
1975
1976#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
1977#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4
1978#endif
1979
1980#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
1981#define  STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5
1982#endif
1983
1984int
1985map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context)
1986{
1987  switch (code) {
1988#ifdef WIN_32
1989  case STATUS_FLOAT_MULTIPLE_FAULTS:
1990  case STATUS_FLOAT_MULTIPLE_TRAPS:
1991    {
1992      int xbit, maskbit;
1993      DWORD mxcsr = *(xpMXCSRptr(context));
1994
1995      for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
1996        if ((mxcsr & (1 << xbit)) &&
1997            !(mxcsr & (1 << maskbit))) {
1998          info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit];
1999          break;
2000        }
2001      }
2002    }
2003    return SIGFPE;
2004#endif
2005     
2006  case EXCEPTION_ACCESS_VIOLATION:
2007    return SIGSEGV;
2008  case EXCEPTION_FLT_DENORMAL_OPERAND:
2009  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
2010  case EXCEPTION_FLT_INEXACT_RESULT:
2011  case EXCEPTION_FLT_INVALID_OPERATION:
2012  case EXCEPTION_FLT_OVERFLOW:
2013  case EXCEPTION_FLT_STACK_CHECK:
2014  case EXCEPTION_FLT_UNDERFLOW:
2015  case EXCEPTION_INT_DIVIDE_BY_ZERO:
2016  case EXCEPTION_INT_OVERFLOW:
2017    return SIGFPE;
2018  case EXCEPTION_PRIV_INSTRUCTION:
2019  case EXCEPTION_ILLEGAL_INSTRUCTION:
2020    return SIGILL;
2021  case EXCEPTION_IN_PAGE_ERROR:
2022  case STATUS_GUARD_PAGE_VIOLATION:
2023    return SIGBUS;
2024  default:
2025    return -1;
2026  }
2027}
2028
2029
2030LONG
2031windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr)
2032{
2033  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
2034  int old_valence, signal_number;
2035  ExceptionInformation *context = exception_pointers->ContextRecord;
2036  siginfo_t *info = exception_pointers->ExceptionRecord;
2037  xframe_list xframes;
2038
2039  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
2040  wait_for_exception_lock_in_handler(tcr, context, &xframes);
2041
2042  signal_number = map_windows_exception_code_to_posix_signal(code, info, context);
2043 
2044  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
2045    char msg[512];
2046    Boolean foreign = (old_valence != TCR_STATE_LISP);
2047
2048    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));
2049   
2050    if (lisp_Debugger(context, info, signal_number,  foreign, msg)) {
2051      SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION);
2052    }
2053  }
2054  unlock_exception_lock_in_handler(tcr);
2055  return restore_windows_context(context, tcr, old_valence);
2056}
2057
2058void
2059setup_exception_handler_call(CONTEXT *context,
2060                             LispObj new_sp,
2061                             void *handler,
2062                             EXCEPTION_POINTERS *new_ep,
2063                             TCR *tcr)
2064{
2065  extern void windows_halt(void);
2066  LispObj *p = (LispObj *)new_sp;
2067#ifdef WIN_64
2068  p-=4;                         /* win64 abi argsave nonsense */
2069  *(--p) = (LispObj)windows_halt;
2070  context->Rsp = (DWORD64)p;
2071  context->Rip = (DWORD64)handler;
2072  context->Rcx = (DWORD64)new_ep;
2073  context->Rdx = (DWORD64)tcr;
2074#else
2075  p-=4;                          /* args on stack, stack aligned */
2076  p[0] = (LispObj)new_ep;
2077  p[1] = (LispObj)tcr;
2078  *(--p) = (LispObj)windows_halt;
2079  context->Esp = (DWORD)p;
2080  context->Eip = (DWORD)handler;
2081#endif
2082  context->EFlags &= ~0x400;  /* clear direction flag */
2083}
2084
2085void
2086prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr,
2087                                                     CONTEXT *context,
2088                                                     void *handler,
2089                                                     EXCEPTION_POINTERS *original_ep)
2090{
2091  LispObj foreign_rsp = 
2092    (LispObj) (tcr->foreign_sp - 128) & ~15;
2093  CONTEXT *new_context;
2094  siginfo_t *new_info;
2095  EXCEPTION_POINTERS *new_ep;
2096
2097  new_context = ((CONTEXT *)(foreign_rsp&~15))-1;
2098  *new_context = *context;
2099  foreign_rsp = (LispObj)new_context;
2100  new_info = ((siginfo_t *)(foreign_rsp&~15))-1;
2101  *new_info = *original_ep->ExceptionRecord;
2102  foreign_rsp = (LispObj)new_info;
2103  new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1;
2104  foreign_rsp = (LispObj)new_ep & ~15;
2105  new_ep->ContextRecord = new_context;
2106  new_ep->ExceptionRecord = new_info;
2107  setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr);
2108}
2109
2110LONG CALLBACK
2111windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers)
2112{
2113  extern void ensure_safe_for_string_operations(void);
2114  DWORD code = exception_pointers->ExceptionRecord->ExceptionCode;
2115
2116
2117 
2118  if ((code & 0x80000000L) == 0) {
2119    return EXCEPTION_CONTINUE_SEARCH;
2120  } else {
2121    TCR *tcr = get_interrupt_tcr(false);
2122    area *cs = TCR_AUX(tcr)->cs_area;
2123    BytePtr current_sp = (BytePtr) current_stack_pointer();
2124    CONTEXT *context = exception_pointers->ContextRecord;
2125   
2126    ensure_safe_for_string_operations();
2127
2128    if ((current_sp >= cs->low) &&
2129        (current_sp < cs->high)) {
2130      debug_show_registers(context, exception_pointers->ExceptionRecord, 0);
2131      FBug(context, "Exception on foreign stack\n");
2132      return EXCEPTION_CONTINUE_EXECUTION;
2133    }
2134
2135    prepare_to_handle_windows_exception_on_foreign_stack(tcr,
2136                                                         context,
2137                                                         windows_exception_handler,
2138                                                         exception_pointers);
2139    return EXCEPTION_CONTINUE_EXECUTION;
2140  }
2141}
2142
2143
2144void
2145install_pmcl_exception_handlers()
2146{
2147  AddVectoredExceptionHandler(1,windows_arbstack_exception_handler);
2148}
2149#else
2150void
2151install_pmcl_exception_handlers()
2152{
2153  void *handler, *interrupt_handler;
2154
2155#ifdef USE_SIGALTSTACK
2156  handler = (void *)altstack_signal_handler;
2157  interrupt_handler = (void *)altstack_interrupt_handler;
2158#else
2159  handler = (void *)arbstack_signal_handler;
2160  interrupt_handler = (void *)arbstack_interrupt_handler;
2161#endif
2162
2163  install_signal_handler(SIGILL, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2164  install_signal_handler(SIGBUS, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2165  install_signal_handler(SIGSEGV, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2166  install_signal_handler(SIGFPE, handler, RESERVE_FOR_LISP|ON_ALTSTACK);
2167 
2168  install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, interrupt_handler,
2169                         RESERVE_FOR_LISP|ON_ALTSTACK);
2170  signal(SIGPIPE, SIG_IGN);
2171}
2172#endif
2173
2174
2175
2176/* This should only be called when the tcr_area_lock is held */
2177void
2178empty_tcr_stacks(TCR *tcr)
2179{
2180  if (tcr) {
2181    area *a;
2182
2183    tcr->valence = TCR_STATE_FOREIGN;
2184    a = tcr->vs_area;
2185    if (a) {
2186      a->active = a->high;
2187    }
2188    a = tcr->ts_area;
2189    if (a) {
2190      a->active = a->high;
2191    }
2192    a = TCR_AUX(tcr)->cs_area;
2193    if (a) {
2194      a->active = a->high;
2195    }
2196  }
2197}
2198
2199#ifdef WINDOWS
2200void
2201thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2202{
2203}
2204#else
2205void
2206thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
2207{
2208  TCR *tcr = get_tcr(false);
2209  sigset_t mask;
2210
2211  sigemptyset(&mask);
2212
2213  empty_tcr_stacks(tcr);
2214
2215  pthread_sigmask(SIG_SETMASK,&mask,NULL);
2216  pthread_exit(NULL);
2217}
2218#endif
2219
2220#ifndef WINDOWS
2221#ifndef USE_SIGALTSTACK
2222void
2223arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2224{
2225  TCR *tcr = get_interrupt_tcr(false);
2226  area *vs = tcr->vs_area;
2227  BytePtr current_sp = (BytePtr) current_stack_pointer();
2228
2229  if ((current_sp >= vs->low) &&
2230      (current_sp < vs->high)) {
2231    handle_signal_on_foreign_stack(tcr,
2232                                   thread_kill_handler,
2233                                   signum,
2234                                   info,
2235                                   context,
2236                                   (LispObj)__builtin_return_address(0)
2237                                   );
2238  } else {
2239    /* If we're not on the value stack, we pretty much have to be on
2240       the C stack.  Just run the handler. */
2241    thread_kill_handler(signum, info, context);
2242  }
2243}
2244
2245
2246#else
2247void
2248altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context)
2249{
2250  TCR* tcr = get_tcr(true);
2251  handle_signal_on_foreign_stack(tcr,
2252                                 thread_kill_handler,
2253                                 signum,
2254                                 info,
2255                                 context,
2256                                 (LispObj)__builtin_return_address(0)
2257                                 );
2258}
2259#endif
2260#endif
2261
2262#ifdef USE_SIGALTSTACK
2263#define THREAD_KILL_HANDLER altstack_thread_kill_handler
2264#else
2265#define THREAD_KILL_HANDLER arbstack_thread_kill_handler
2266#endif
2267
2268#ifdef WINDOWS
2269void
2270thread_signal_setup()
2271{
2272}
2273#else
2274void
2275thread_signal_setup()
2276{
2277  thread_suspend_signal = SIG_SUSPEND_THREAD;
2278  thread_kill_signal = SIG_KILL_THREAD;
2279
2280  install_signal_handler(thread_suspend_signal, (void *)suspend_resume_handler,
2281                         RESERVE_FOR_LISP|RESTART_SYSCALLS);
2282  install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER,
2283                         RESERVE_FOR_LISP|ON_ALTSTACK);
2284}
2285#endif
2286
2287void
2288enable_fp_exceptions()
2289{
2290}
2291
2292void
2293exception_init()
2294{
2295  x86_early_exception_init();
2296  install_pmcl_exception_handlers();
2297}
2298
2299void
2300adjust_exception_pc(ExceptionInformation *xp, int delta)
2301{
2302  xpPC(xp) += delta;
2303}
2304
2305/*
2306  Lower (move toward 0) the "end" of the soft protected area associated
2307  with a by a page, if we can.
2308*/
2309
2310void
2311adjust_soft_protection_limit(area *a)
2312{
2313  char *proposed_new_soft_limit = a->softlimit - 4096;
2314  protected_area_ptr p = a->softprot;
2315 
2316  if (proposed_new_soft_limit >= (p->start+16384)) {
2317    p->end = proposed_new_soft_limit;
2318    p->protsize = p->end-p->start;
2319    a->softlimit = proposed_new_soft_limit;
2320  }
2321  protect_area(p);
2322}
2323
2324void
2325restore_soft_stack_limit(unsigned restore_tsp)
2326{
2327  TCR *tcr = get_tcr(false);
2328  area *a;
2329 
2330  if (restore_tsp) {
2331    a = tcr->ts_area;
2332  } else {
2333    a = tcr->vs_area;
2334  }
2335  adjust_soft_protection_limit(a);
2336}
2337
2338
2339#ifdef USE_SIGALTSTACK
2340void
2341setup_sigaltstack(area *a)
2342{
2343  stack_t stack;
2344
2345  stack.ss_size = SIGSTKSZ*8;
2346  stack.ss_flags = 0;
2347#ifdef SEPARATE_ALTSTACK
2348  stack.ss_sp = mmap(NULL,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_ANON|MAP_PRIVATE,-1,0);
2349#else
2350  stack.ss_sp = a->low;
2351  a->low += SIGSTKSZ*8;
2352  mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0);
2353#endif
2354#ifdef LINUX
2355  /* The ucontext pushed on the altstack may not contain the (largish)
2356     __fpregs_mem field; copy_ucontext() wants to copy what it thinks
2357     is a pointer to a full ucontext.  That'll touch a page beyond the
2358     bottom of the altstack, and when this happens on the initial
2359     thread's stack on a recent (2.6.32+?) kernel, we'll SIGBUS instead
2360     of mapping that page.
2361     It's easier to just reserve that page here than it would be to
2362     change copy_ucontext().
2363  */
2364  stack.ss_size -= sizeof(struct ucontext);
2365#endif
2366  if (sigaltstack(&stack, NULL) != 0) {
2367    perror("sigaltstack");
2368    exit(-1);
2369  }
2370}
2371#endif
2372
2373extern opcode egc_write_barrier_start, egc_write_barrier_end,
2374  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
2375  egc_set_hash_key_conditional_retry,
2376  egc_store_node_conditional_success_end, egc_store_node_conditional_retry,
2377  egc_store_node_conditional_success_test,egc_store_node_conditional,
2378  egc_set_hash_key, egc_gvset, egc_rplacd;
2379
2380/* We use (extremely) rigidly defined instruction sequences for consing,
2381   mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted
2382   while consing.
2383
2384   Note that we can usually identify which of these instructions is about
2385   to be executed by a stopped thread without comparing all of the bytes
2386   to those at the stopped program counter, but we generally need to
2387   know the sizes of each of these instructions.
2388*/
2389
2390#ifdef X8664
2391opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2392#ifdef TCR_IN_GPR
2393  {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00}
2394#else
2395  {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00}
2396#endif
2397;
2398opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2399#ifdef TCR_IN_GPR
2400  {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00}
2401#else
2402  {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00}
2403#endif
2404
2405;
2406opcode branch_around_alloc_trap_instruction[] =
2407  {0x77,0x02};
2408opcode alloc_trap_instruction[] =
2409  {0xcd,0xc5};
2410opcode clear_tcr_save_allocptr_tag_instruction[] =
2411#ifdef TCR_IN_GPR
2412  {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0}
2413#else
2414  {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0}
2415#endif
2416;
2417opcode set_allocptr_header_instruction[] =
2418  {0x48,0x89,0x43,0xf3};
2419
2420
2421alloc_instruction_id
2422recognize_alloc_instruction(pc program_counter)
2423{
2424  switch(program_counter[0]) {
2425  case 0xcd: return ID_alloc_trap_instruction;
2426  /* 0x7f is jg, which we used to use here instead of ja */
2427  case 0x7f:
2428  case 0x77: return ID_branch_around_alloc_trap_instruction;
2429  case 0x48: return ID_set_allocptr_header_instruction;
2430#ifdef TCR_IN_GPR
2431  case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction;
2432  case 0x49:
2433    switch(program_counter[1]) {
2434    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2435    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2436    }
2437#else
2438  case 0x65: 
2439    switch(program_counter[1]) {
2440    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2441    case 0x48:
2442      switch(program_counter[2]) {
2443      case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2444      case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2445      }
2446    }
2447#endif
2448  default: break;
2449  }
2450  return ID_unrecognized_alloc_instruction;
2451}
2452#endif
2453#ifdef X8632
2454#define TCR_SEG_PREFIX 0x64
2455
2456#ifdef WIN_32
2457#define SAVE_ALLOCPTR 0x9c,0x0e,0x0,0x0
2458#define SAVE_ALLOCBASE 0x98,0x0e,0x0,0x0
2459#else
2460#define SAVE_ALLOCPTR 0x84,0x0,0x0,0x0
2461#define SAVE_ALLOCBASE 0x88,0x0,0x0,0x0
2462#endif
2463
2464opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
2465  {TCR_SEG_PREFIX,0x8b,0x0d,SAVE_ALLOCPTR};
2466opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
2467  {TCR_SEG_PREFIX,0x3b,0x0d,SAVE_ALLOCBASE};
2468opcode branch_around_alloc_trap_instruction[] =
2469  {0x77,0x02};
2470opcode alloc_trap_instruction[] =
2471  {0xcd,0xc5};
2472opcode clear_tcr_save_allocptr_tag_instruction[] =
2473  {TCR_SEG_PREFIX,0x80,0x25,SAVE_ALLOCPTR,0xf8};
2474opcode set_allocptr_header_instruction[] =
2475  {0x0f,0x7e,0x41,0xfa};
2476
2477alloc_instruction_id
2478recognize_alloc_instruction(pc program_counter)
2479{
2480  switch(program_counter[0]) {
2481  case 0xcd: return ID_alloc_trap_instruction;
2482  case 0x77: return ID_branch_around_alloc_trap_instruction;
2483  case 0x0f: return ID_set_allocptr_header_instruction;
2484  case 0x64: 
2485    switch(program_counter[1]) {
2486    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
2487    case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction;
2488    case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction;
2489    }
2490  }
2491  return ID_unrecognized_alloc_instruction;
2492}
2493#endif     
2494
2495void
2496pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement)
2497{
2498  pc program_counter = (pc)xpPC(xp);
2499  int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr));
2500
2501  if (allocptr_tag != 0) {
2502    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
2503    signed_natural
2504      disp = (allocptr_tag == fulltag_cons) ?
2505      sizeof(cons) - fulltag_cons :
2506#ifdef X8664
2507      xpGPR(xp,Iimm1)
2508#else
2509      xpGPR(xp,Iimm0)
2510#endif
2511      ;
2512    LispObj new_vector;
2513
2514    if ((state == ID_unrecognized_alloc_instruction) ||
2515        ((state == ID_set_allocptr_header_instruction) &&
2516         (allocptr_tag != fulltag_misc))) {
2517      Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr);
2518    }
2519    switch(state) {
2520    case ID_set_allocptr_header_instruction:
2521      /* We were consing a vector and we won.  Set the header of the
2522         new vector (in the allocptr register) to the header in %rax
2523         (%mm0 on ia32) and skip over this instruction, then fall into
2524         the next case. */
2525      new_vector = xpGPR(xp,Iallocptr);
2526      deref(new_vector,0) = 
2527#ifdef X8664
2528        xpGPR(xp,Iimm0)
2529#else
2530        xpMMXreg(xp,Imm0)
2531#endif
2532        ;
2533     
2534      xpPC(xp) += sizeof(set_allocptr_header_instruction);
2535
2536      /* Fall thru */
2537    case ID_clear_tcr_save_allocptr_tag_instruction:
2538      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2539      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2540
2541      break;
2542    case ID_alloc_trap_instruction:
2543      /* If we're looking at another thread, we're pretty much committed to
2544         taking the trap.  We don't want the allocptr register to be pointing
2545         into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp'
2546         was determined above.
2547      */
2548      if (interrupt_displacement == NULL) {
2549        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp;
2550        tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp);
2551      } else {
2552        /* Back out, and tell the caller how to resume the allocation attempt */
2553        *interrupt_displacement = disp;
2554        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2555        tcr->save_allocptr += disp;
2556        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
2557                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2558                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2559      }
2560      break;
2561    case ID_branch_around_alloc_trap_instruction:
2562      /* If we'd take the branch - which is a "ja" - around the alloc trap,
2563         we might as well finish the allocation.  Otherwise, back out of the
2564         attempt. */
2565      {
2566        int flags = (int)eflags_register(xp);
2567       
2568        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
2569            (!(flags & (1 << X86_CARRY_FLAG_BIT)))) {
2570          /* The branch (ja) would have been taken.  Emulate taking it. */
2571          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
2572                       sizeof(alloc_trap_instruction));
2573          if (allocptr_tag == fulltag_misc) {
2574            /* Slap the header on the new uvector */
2575            new_vector = xpGPR(xp,Iallocptr);
2576#ifdef X8664
2577            deref(new_vector,0) = xpGPR(xp,Iimm0);
2578#else
2579            deref(new_vector,0) = xpMMXreg(xp,Imm0);
2580#endif
2581            xpPC(xp) += sizeof(set_allocptr_header_instruction);
2582          }
2583          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
2584          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
2585        } else {
2586          /* Back up */
2587          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
2588                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
2589          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2590          if (interrupt_displacement) {
2591            *interrupt_displacement = disp;
2592            tcr->save_allocptr += disp;
2593          } else {
2594            tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2595          }
2596        }
2597      }
2598      break;
2599    case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction:
2600      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
2601      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
2602      /* Fall through */
2603    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
2604      if (interrupt_displacement) {
2605        tcr->save_allocptr += disp;
2606        *interrupt_displacement = disp;
2607      } else {
2608        tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp);
2609      }
2610      break;
2611    default: 
2612      break;
2613    }
2614    return;
2615  }
2616  if ((program_counter >= &egc_write_barrier_start) &&
2617      (program_counter < &egc_write_barrier_end)) {
2618    LispObj *ea = 0, val, root = 0;
2619    bitvector refbits = (bitvector)(lisp_global(REFBITS));
2620    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
2621
2622    if (program_counter >= &egc_set_hash_key_conditional) {
2623      if (program_counter <= &egc_set_hash_key_conditional_retry) {
2624        return;
2625      }
2626      if (program_counter < &egc_set_hash_key_conditional_success_test) {
2627        /* Back up the PC, try again.  This is necessary since a pending
2628           GC may cause the value in %eax/%rax to move and backing up
2629           will reload %eax/%rax from a node register before trying the
2630           cmpxchg.
2631        */
2632        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry;
2633        return;
2634      }
2635      if ((program_counter == &egc_set_hash_key_conditional_success_test) &&
2636          !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT))) {
2637        /* Conditional store failed.  Return NIL. */
2638        LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2639        xpGPR(xp,Iarg_z) = lisp_nil;
2640        xpPC(xp) = ra;
2641        xpGPR(xp,Isp)=(LispObj)sp;
2642        return;
2643      }
2644      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2645      val = xpGPR(xp,Iarg_z);
2646#ifdef X8664
2647      root = xpGPR(xp,Iarg_x);
2648      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
2649#else
2650      root = xpGPR(xp,Itemp1);
2651      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
2652#endif
2653      need_memoize_root = true;
2654      need_store = false;
2655      xpGPR(xp,Iarg_z) = t_value;
2656    } else if (program_counter >= &egc_store_node_conditional) {
2657      if (program_counter <= &egc_store_node_conditional_retry) {
2658        return;
2659      }
2660      if (program_counter < &egc_store_node_conditional_success_test) {
2661        /* Back up the PC, try again.  Again, this is necessary because
2662           we're possibly keeping a node in %eax/%rax and haven't completed
2663           the cmpxchg yet. */
2664        xpPC(xp) = (LispObj) &egc_store_node_conditional_retry;
2665        return;
2666      }
2667      if ((program_counter == &egc_store_node_conditional_success_test) &&
2668           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT))) {
2669        /* cmpxchg failed.  Return NIL. */
2670        LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2671        xpGPR(xp,Iarg_z) = lisp_nil;
2672        xpPC(xp) = ra;
2673        xpGPR(xp,Isp)=(LispObj)sp;
2674        return;
2675      }
2676
2677      if (program_counter >= &egc_store_node_conditional_success_end) {
2678        return;
2679      }
2680
2681      /* The conditional store succeeded.  Set the refbit, return to ra0 */
2682      val = xpGPR(xp,Iarg_z);
2683#ifdef X8664
2684      ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural)
2685                                                       xpGPR(xp,Itemp0))));
2686#else
2687      ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0));
2688#endif
2689      xpGPR(xp,Iarg_z) = t_value;
2690      need_store = false;
2691    } else if (program_counter >= &egc_set_hash_key) {
2692#ifdef X8664
2693      root = xpGPR(xp,Iarg_x);
2694#else
2695      root = xpGPR(xp,Itemp0);
2696#endif
2697      ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset);
2698      val = xpGPR(xp,Iarg_z);
2699      need_memoize_root = true;
2700    } else if (program_counter >= &egc_gvset) {
2701#ifdef X8664
2702      ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset);
2703#else
2704      ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset);
2705#endif
2706      val = xpGPR(xp,Iarg_z);
2707    } else if (program_counter >= &egc_rplacd) {
2708      ea = (LispObj *) untag(xpGPR(xp,Iarg_y));
2709      val = xpGPR(xp,Iarg_z);
2710    } else {                      /* egc_rplaca */
2711      ea =  ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1;
2712      val = xpGPR(xp,Iarg_z);
2713    }
2714    if (need_store) {
2715      *ea = val;
2716    }
2717    if (need_check_memo) {
2718      if ((LispObj)ea < val) {
2719        natural  bitnumber = area_dnode(ea, lisp_global(REF_BASE)),
2720          rootbitnumber = area_dnode(root, lisp_global(REF_BASE));
2721        if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT))) {
2722          atomic_set_bit(refbits, bitnumber);
2723          if (need_memoize_root) {
2724            atomic_set_bit(refbits, rootbitnumber);
2725          }
2726        }
2727        if (bitnumber < lisp_global(MANAGED_STATIC_DNODES)) {
2728          atomic_set_bit(managed_static_refbits,bitnumber);
2729          if (need_memoize_root) {
2730            atomic_set_bit(managed_static_refbits, rootbitnumber);
2731          }
2732        }
2733      }
2734    }
2735    {
2736      /* These subprimitives are called via CALL/RET; need
2737         to pop the return address off the stack and set
2738         the PC there. */
2739      LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++;
2740      xpPC(xp) = ra;
2741      xpGPR(xp,Isp)=(LispObj)sp;
2742    }
2743    return;
2744  }
2745}
2746
2747
2748void
2749normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr)
2750{
2751  void *cur_allocptr = (void *)(tcr->save_allocptr);
2752  LispObj lisprsp;
2753  area *a;
2754
2755  if (xp) {
2756    if (is_other_tcr) {
2757      pc_luser_xp(xp, tcr, NULL);
2758    }
2759    a = tcr->vs_area;
2760    lisprsp = xpGPR(xp, Isp);
2761    if (((BytePtr)lisprsp >= a->low) &&
2762        ((BytePtr)lisprsp < a->high)) {
2763      a->active = (BytePtr)lisprsp;
2764    } else {
2765      a->active = (BytePtr) tcr->save_vsp;
2766    }
2767    a = tcr->ts_area;
2768    a->active = (BytePtr) tcr->save_tsp;
2769  } else {
2770    /* In ff-call; get area active pointers from tcr */
2771    tcr->vs_area->active = (BytePtr) tcr->save_vsp;
2772    tcr->ts_area->active = (BytePtr) tcr->save_tsp;
2773  }
2774  if (cur_allocptr) {
2775    update_bytes_allocated(tcr, cur_allocptr);
2776  }
2777  tcr->save_allocbase = (void *)VOID_ALLOCPTR;
2778  if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) {
2779    tcr->save_allocptr = (void *)VOID_ALLOCPTR;
2780  }
2781}
2782
2783
2784/* Suspend and "normalize" other tcrs, then call a gc-like function
2785   in that context.  Resume the other tcrs, then return what the
2786   function returned */
2787
2788TCR *gc_tcr = NULL;
2789
2790
2791signed_natural
2792gc_like_from_xp(ExceptionInformation *xp, 
2793                signed_natural(*fun)(TCR *, signed_natural), 
2794                signed_natural param)
2795{
2796  TCR *tcr = get_tcr(false), *other_tcr;
2797  int result;
2798  signed_natural inhibit;
2799
2800  suspend_other_threads(true);
2801  inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT));
2802  if (inhibit != 0) {
2803    if (inhibit > 0) {
2804      lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit);
2805    }
2806    resume_other_threads(true);
2807    gc_deferred++;
2808    return 0;
2809  }
2810  gc_deferred = 0;
2811
2812  gc_tcr = tcr;
2813
2814  /* This is generally necessary if the current thread invoked the GC
2815     via an alloc trap, and harmless if the GC was invoked via a GC
2816     trap.  (It's necessary in the first case because the "allocptr"
2817     register - %rbx - may be pointing into the middle of something
2818     below tcr->save_allocbase, and we wouldn't want the GC to see
2819     that bogus pointer.) */
2820  xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; 
2821
2822  normalize_tcr(xp, tcr, false);
2823
2824
2825  for (other_tcr = TCR_AUX(tcr)->next; other_tcr != tcr;
2826       other_tcr = TCR_AUX(other_tcr)->next) {
2827    if (other_tcr->pending_exception_context) {
2828      TCR_AUX(other_tcr)->gc_context = other_tcr->pending_exception_context;
2829    } else if (other_tcr->valence == TCR_STATE_LISP) {
2830      TCR_AUX(other_tcr)->gc_context = TCR_AUX(other_tcr)->suspend_context;
2831    } else {
2832      /* no pending exception, didn't suspend in lisp state:
2833         must have executed a synchronous ff-call.
2834      */
2835      TCR_AUX(other_tcr)->gc_context = NULL;
2836    }
2837    normalize_tcr(TCR_AUX(other_tcr)->gc_context, other_tcr, true);
2838  }
2839   
2840
2841
2842  result = fun(tcr, param);
2843
2844  other_tcr = tcr;
2845  do {
2846    TCR_AUX(other_tcr)->gc_context = NULL;
2847    other_tcr = TCR_AUX(other_tcr)->next;
2848  } while (other_tcr != tcr);
2849
2850  gc_tcr = NULL;
2851
2852  resume_other_threads(true);
2853
2854  return result;
2855
2856}
2857
2858signed_natural
2859purify_from_xp(ExceptionInformation *xp, signed_natural param)
2860{
2861  return gc_like_from_xp(xp, purify, param);
2862}
2863
2864signed_natural
2865impurify_from_xp(ExceptionInformation *xp, signed_natural param)
2866{
2867  return gc_like_from_xp(xp, impurify, param);
2868}
2869
2870/* Returns #bytes freed by invoking GC */
2871
2872signed_natural
2873gc_from_tcr(TCR *tcr, signed_natural param)
2874{
2875  area *a;
2876  BytePtr oldfree, newfree;
2877  BytePtr oldend, newend;
2878
2879#if 0
2880  fprintf(dbgout, "Start GC  in 0x" LISP "\n", tcr);
2881#endif
2882  a = active_dynamic_area;
2883  oldend = a->high;
2884  oldfree = a->active;
2885  gc(tcr, param);
2886  newfree = a->active;
2887  newend = a->high;
2888#if 0
2889  fprintf(dbgout, "End GC  in 0x" LISP "\n", tcr);
2890#endif
2891  return ((oldfree-newfree)+(newend-oldend));
2892}
2893
2894signed_natural
2895gc_from_xp(ExceptionInformation *xp, signed_natural param)
2896{
2897  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
2898
2899  freeGCptrs();
2900  return status;
2901}
2902
2903
2904/* watchpoint stuff */
2905
2906area *
2907new_watched_area(natural size)
2908{
2909  char *p;
2910
2911  p = MapMemory(NULL, size, MEMPROTECT_RWX);
2912  if ((signed_natural)p == -1) {
2913    allocation_failure(true, size);
2914  }
2915  return new_area(p, p + size, AREA_WATCHED);
2916}
2917
2918void
2919delete_watched_area(area *a, TCR *tcr)
2920{
2921  natural nbytes = a->high - a->low;
2922  char *base = a->low;
2923
2924  condemn_area_holding_area_lock(a);
2925
2926  if (nbytes) {
2927    int err;
2928
2929    err = UnMapMemory(base, nbytes);
2930    if (err != 0)
2931      Fatal("munmap in delete_watched_area", "");
2932  }
2933}
2934
2935natural
2936uvector_total_size_in_bytes(LispObj *u)
2937{
2938  LispObj header = header_of(u);
2939  natural header_tag = fulltag_of(header);
2940  natural subtag = header_subtag(header);
2941  natural element_count = header_element_count(header);
2942  natural nbytes = 0;
2943
2944#ifdef X8632
2945  if ((nodeheader_tag_p(header_tag)) ||
2946      (subtag <= max_32_bit_ivector_subtag)) {
2947    nbytes = element_count << 2;
2948  } else if (subtag <= max_8_bit_ivector_subtag) {
2949    nbytes = element_count;
2950  } else if (subtag <= max_16_bit_ivector_subtag) {
2951    nbytes = element_count << 1;
2952  } else if (subtag == subtag_double_float_vector) {
2953    nbytes = element_count << 3;
2954  } else {
2955    nbytes = (element_count + 7) >> 3;
2956  }
2957  /* add 4 byte header and round up to multiple of 8 bytes */
2958  return ~7 & (4 + nbytes + 7);
2959#endif
2960#ifdef X8664
2961  if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) {
2962    nbytes = element_count << 3;
2963  } else if (header_tag == ivector_class_32_bit) {
2964    nbytes = element_count << 2;
2965  } else {
2966    /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */
2967    if (subtag == subtag_bit_vector) {
2968      nbytes = (element_count + 7) >> 3;
2969    } else if (subtag >= min_8_bit_ivector_subtag) {
2970      nbytes = element_count;
2971    } else {
2972      nbytes = element_count << 1;
2973    }
2974  }
2975  /* add 8 byte header and round up to multiple of 16 bytes */
2976  return ~15 & (8 + nbytes + 15);
2977#endif
2978}
2979
2980extern void wp_update_references(TCR *, LispObj, LispObj);
2981
2982/*
2983 * Other threads are suspended and pc-lusered.
2984 *
2985 * param contains a tagged pointer to a uvector or a cons cell
2986 */
2987signed_natural
2988watch_object(TCR *tcr, signed_natural param)
2989{
2990  LispObj object = (LispObj)param;
2991  unsigned tag = fulltag_of(object);
2992  LispObj *noderef = (LispObj *)untag(object);
2993  area *object_area = area_containing((BytePtr)noderef);
2994  natural size;
2995
2996  if (tag == fulltag_cons)
2997    size = 2 * node_size;
2998  else
2999    size = uvector_total_size_in_bytes(noderef);
3000
3001  if (object_area && object_area->code == AREA_DYNAMIC) {
3002    area *a = new_watched_area(size);
3003    LispObj old = object;
3004    LispObj new = (LispObj)((natural)a->low + tag);
3005
3006    add_area_holding_area_lock(a);
3007
3008    /* move object to watched area */
3009    memcpy(a->low, noderef, size);
3010    ProtectMemory(a->low, size);
3011    memset(noderef, 0, size);
3012    wp_update_references(tcr, old, new);
3013    check_all_areas(tcr);
3014    return 1;
3015  }
3016  return 0;
3017}
3018
3019/*
3020 * We expect the watched object in arg_y, and the new uninitialized
3021 * object (which is just zeroed) in arg_z.
3022 */
3023signed_natural
3024unwatch_object(TCR *tcr, signed_natural param)
3025{
3026  ExceptionInformation *xp = tcr->xframe->curr;
3027  LispObj old = xpGPR(xp, Iarg_y);
3028  unsigned tag = fulltag_of(old);
3029  LispObj new = xpGPR(xp, Iarg_z);
3030  LispObj *oldnode = (LispObj *)untag(old);
3031  LispObj *newnode = (LispObj *)untag(new);
3032  area *a = area_containing((BytePtr)old);
3033  extern void update_managed_refs(area *, BytePtr, natural);
3034
3035  if (a && a->code == AREA_WATCHED) {
3036    natural size;
3037
3038    if (tag == fulltag_cons)
3039      size = 2 * node_size;
3040    else
3041      size = uvector_total_size_in_bytes(oldnode);
3042
3043    memcpy(newnode, oldnode, size);
3044    delete_watched_area(a, tcr);
3045    wp_update_references(tcr, old, new);
3046    /* because wp_update_references doesn't update refbits */
3047    tenure_to_area(tenured_area);
3048    /* Unwatching can (re-)introduce managed_static->dynamic references */
3049    zero_bits(managed_static_area->refbits,managed_static_area->ndnodes);
3050    update_managed_refs(managed_static_area, low_markable_address, area_dnode(active_dynamic_area->active, low_markable_address));
3051    check_all_areas(tcr);
3052    xpGPR(xp, Iarg_z) = new;
3053  }
3054  return 0;
3055}
3056
3057Boolean
3058handle_watch_trap(ExceptionInformation *xp, TCR *tcr)
3059{
3060  LispObj selector = xpGPR(xp,Iimm0);
3061  LispObj object = xpGPR(xp, Iarg_z);
3062  signed_natural result;
3063 
3064  switch (selector) {
3065    case WATCH_TRAP_FUNCTION_WATCH:
3066      result = gc_like_from_xp(xp, watch_object, object);
3067      if (result == 0)
3068        xpGPR(xp,Iarg_z) = lisp_nil;
3069      break;
3070    case WATCH_TRAP_FUNCTION_UNWATCH:
3071      gc_like_from_xp(xp, unwatch_object, 0);
3072      break;
3073    default:
3074      break;
3075  }
3076  return true;
3077}
3078
Note: See TracBrowser for help on using the repository browser.