src/runtime/interrupt.c

   1 /*
   2  * interrupt-handling magic
   3  */
   4
   5 /*
   6  * This software is part of the SBCL system. See the README file for
   7  * more information.
   8  *
   9  * This software is derived from the CMU CL system, which was
  10  * written at Carnegie Mellon University and released into the
  11  * public domain. The software is in the public domain and is
  12  * provided with absolutely no warranty. See the COPYING and CREDITS
  13  * files for more information.
  14  */
  15
  16
  17 /* As far as I can tell, what's going on here is:
  18  *
  19  * In the case of most signals, when Lisp asks us to handle the
  20  * signal, the outermost handler (the one actually passed to UNIX) is
  21  * either interrupt_handle_now(..) or maybe_now_maybe_later(..).
  22  * In that case, the Lisp-level handler is stored in interrupt_handlers[..]
  23  * and interrupt_low_level_handlers[..] is cleared.
  24  *
  25  * However, some signals need special handling, e.g.
  26  *
  27  * o the SIGSEGV (for e.g. Linux) or SIGBUS (for e.g. FreeBSD) used by the
  28  *   garbage collector to detect violations of write protection,
  29  *   because some cases of such signals (e.g. GC-related violations of
  30  *   write protection) are handled at C level and never passed on to
  31  *   Lisp. For such signals, we still store any Lisp-level handler
  32  *   in interrupt_handlers[..], but for the outermost handle we use
  33  *   the value from interrupt_low_level_handlers[..], instead of the
  34  *   ordinary interrupt_handle_now(..) or interrupt_handle_later(..).
  35  *
  36  * o the SIGTRAP (Linux/Alpha) which Lisp code uses to handle breakpoints,
  37  *   pseudo-atomic sections, and some classes of error (e.g. "function
  38  *   not defined").  This never goes anywhere near the Lisp handlers at all.
  39  *   See runtime/alpha-arch.c and code/signal.lisp
  40  *
  41  * - WHN 20000728, dan 20010128 */
  42
  43 #include "sbcl.h"
  44
  45 #include <stdio.h>
  46 #include <stdlib.h>
  47 #include <string.h>
  48 #include <signal.h>
  49 #include <sys/types.h>
  50 #ifndef LISP_FEATURE_WIN32
  51 #include <sys/wait.h>
  52 #endif
  53 #include <errno.h>
  54
  55 #include "runtime.h"
  56 #include "arch.h"
  57 #include "os.h"
  58 #include "interrupt.h"
  59 #include "globals.h"
  60 #include "lispregs.h"
  61 #include "validate.h"
  62 #include "interr.h"
  63 #include "gc.h"
  64 #include "alloc.h"
  65 #include "dynbind.h"
  66 #include "pseudo-atomic.h"
  67 #include "genesis/fdefn.h"
  68 #include "genesis/simple-fun.h"
  69 #include "genesis/cons.h"
  70
  71 /* When we catch an internal error, should we pass it back to Lisp to
  72  * be handled in a high-level way? (Early in cold init, the answer is
  73  * 'no', because Lisp is still too brain-dead to handle anything.
  74  * After sufficient initialization has been completed, the answer
  75  * becomes 'yes'.) */
  76 boolean internal_errors_enabled = 0;
  77
  78 #ifndef LISP_FEATURE_WIN32
  79 static
  80 void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, os_context_t*);
  81 #endif
  82 union interrupt_handler interrupt_handlers[NSIG];
  83
  84 /* Under Linux on some architectures, we appear to have to restore the
  85  * FPU control word from the context, as after the signal is delivered
  86  * we appear to have a null FPU control word. */
  87 #if defined(RESTORE_FP_CONTROL_FROM_CONTEXT)
  88 #define RESTORE_FP_CONTROL_WORD(context,void_context)           \
  89     os_context_t *context = arch_os_get_context(&void_context); \
  90     os_restore_fp_control(context);
  91 #else
  92 #define RESTORE_FP_CONTROL_WORD(context,void_context)           \
  93     os_context_t *context = arch_os_get_context(&void_context);
  94 #endif
  95
  96 /* Foreign code may want to start some threads on its own.
  97  * Non-targetted, truly asynchronous signals can be delivered to
  98  * basically any thread, but invoking Lisp handlers in such foregign
  99  * threads is really bad, so let's resignal it.
 100  *
 101  * This should at least bring attention to the problem, but it cannot
 102  * work for SIGSEGV and similar. It is good enough for timers, and
 103  * maybe all deferrables. */
 104
 105 #ifdef LISP_FEATURE_SB_THREAD
 106 static void
 107 add_handled_signals(sigset_t *sigset)
 108 {
 109     int i;
 110     for(i = 1; i < NSIG; i++) {
 111         if (!(ARE_SAME_HANDLER(interrupt_low_level_handlers[i], SIG_DFL)) ||
 112             !(ARE_SAME_HANDLER(interrupt_handlers[i].c, SIG_DFL))) {
 113             sigaddset(sigset, i);
 114         }
 115     }
 116 }
 117
 118 void block_signals(sigset_t *what, sigset_t *where, sigset_t *old);
 119 #endif
 120
 121 static boolean
 122 maybe_resignal_to_lisp_thread(int signal, os_context_t *context)
 123 {
 124 #ifdef LISP_FEATURE_SB_THREAD
 125     if (!pthread_getspecific(lisp_thread)) {
 126         if (!(sigismember(&deferrable_sigset,signal))) {
 127             corruption_warning_and_maybe_lose
 128                 ("Received signal %d in non-lisp thread %lu, resignalling to a lisp thread.",
 129                  signal,
 130                  pthread_self());
 131         }
 132         {
 133             sigset_t sigset;
 134             sigemptyset(&sigset);
 135             add_handled_signals(&sigset);
 136             block_signals(&sigset, 0, 0);
 137             block_signals(&sigset, os_context_sigmask_addr(context), 0);
 138             kill(getpid(), signal);
 139         }
 140         return 1;
 141     } else
 142 #endif
 143         return 0;
 144 }
 145
 146 /* These are to be used in signal handlers. Currently all handlers are
 147  * called from one of:
 148  *
 149  * interrupt_handle_now_handler
 150  * maybe_now_maybe_later
 151  * unblock_me_trampoline
 152  * low_level_handle_now_handler
 153  * low_level_maybe_now_maybe_later
 154  * low_level_unblock_me_trampoline
 155  *
 156  * This gives us a single point of control (or six) over errno, fp
 157  * control word, and fixing up signal context on sparc.
 158  *
 159  * The SPARC/Linux platform doesn't quite do signals the way we want
 160  * them done. The third argument in the handler isn't filled in by the
 161  * kernel properly, so we fix it up ourselves in the
 162  * arch_os_get_context(..) function. -- CSR, 2002-07-23
 163  */
 164 #define SAVE_ERRNO(signal,context,void_context)                 \
 165     {                                                           \
 166         int _saved_errno = errno;                               \
 167         RESTORE_FP_CONTROL_WORD(context,void_context);          \
 168         if (!maybe_resignal_to_lisp_thread(signal, context))    \
 169         {
 170
 171 #define RESTORE_ERRNO                                           \
 172         }                                                       \
 173         errno = _saved_errno;                                   \
 174     }
 175
 176 static void run_deferred_handler(struct interrupt_data *data,
 177                                  os_context_t *context);
 178 #ifndef LISP_FEATURE_WIN32
 179 static void store_signal_data_for_later (struct interrupt_data *data,
 180                                          void *handler, int signal,
 181                                          siginfo_t *info,
 182                                          os_context_t *context);
 183 \f
 184
 185 /* Generic signal related utilities. */
 186
 187 void
 188 get_current_sigmask(sigset_t *sigset)
 189 {
 190     /* Get the current sigmask, by blocking the empty set. */
 191     thread_sigmask(SIG_BLOCK, 0, sigset);
 192 }
 193
 194 void
 195 block_signals(sigset_t *what, sigset_t *where, sigset_t *old)
 196 {
 197     if (where) {
 198         int i;
 199         if (old)
 200             sigcopyset(old, where);
 201         for(i = 1; i < NSIG; i++) {
 202             if (sigismember(what, i))
 203                 sigaddset(where, i);
 204         }
 205     } else {
 206         thread_sigmask(SIG_BLOCK, what, old);
 207     }
 208 }
 209
 210 void
 211 unblock_signals(sigset_t *what, sigset_t *where, sigset_t *old)
 212 {
 213     if (where) {
 214         int i;
 215         if (old)
 216             sigcopyset(old, where);
 217         for(i = 1; i < NSIG; i++) {
 218             if (sigismember(what, i))
 219                 sigdelset(where, i);
 220         }
 221     } else {
 222         thread_sigmask(SIG_UNBLOCK, what, old);
 223     }
 224 }
 225
 226 static void
 227 print_sigset(sigset_t *sigset)
 228 {
 229   int i;
 230   for(i = 1; i < NSIG; i++) {
 231     if (sigismember(sigset, i))
 232       fprintf(stderr, "Signal %d masked\n", i);
 233   }
 234 }
 235
 236 /* Return 1 is all signals is sigset2 are masked in sigset, return 0
 237  * if all re unmasked else die. Passing NULL for sigset is a shorthand
 238  * for the current sigmask. */
 239 boolean
 240 all_signals_blocked_p(sigset_t *sigset, sigset_t *sigset2,
 241                                 const char *name)
 242 {
 243 #if !defined(LISP_FEATURE_WIN32)
 244     int i;
 245     boolean has_blocked = 0, has_unblocked = 0;
 246     sigset_t current;
 247     if (sigset == 0) {
 248         get_current_sigmask(&current);
 249         sigset = &current;
 250     }
 251     for(i = 1; i < NSIG; i++) {
 252         if (sigismember(sigset2, i)) {
 253             if (sigismember(sigset, i))
 254                 has_blocked = 1;
 255             else
 256                 has_unblocked = 1;
 257         }
 258     }
 259     if (has_blocked && has_unblocked) {
 260         print_sigset(sigset);
 261         lose("some %s signals blocked, some unblocked\n", name);
 262     }
 263     if (has_blocked)
 264         return 1;
 265     else
 266         return 0;
 267 #endif
 268 }
 269 \f
 270
 271 /* Deferrables, blockables, gc signals. */
 272
 273 void
 274 sigaddset_deferrable(sigset_t *s)
 275 {
 276     sigaddset(s, SIGHUP);
 277     sigaddset(s, SIGINT);
 278     sigaddset(s, SIGTERM);
 279     sigaddset(s, SIGQUIT);
 280     sigaddset(s, SIGPIPE);
 281     sigaddset(s, SIGALRM);
 282     sigaddset(s, SIGURG);
 283     sigaddset(s, SIGTSTP);
 284     sigaddset(s, SIGCHLD);
 285     sigaddset(s, SIGIO);
 286 #ifndef LISP_FEATURE_HPUX
 287     sigaddset(s, SIGXCPU);
 288     sigaddset(s, SIGXFSZ);
 289 #endif
 290     sigaddset(s, SIGVTALRM);
 291     sigaddset(s, SIGPROF);
 292     sigaddset(s, SIGWINCH);
 293 }
 294
 295 void
 296 sigaddset_blockable(sigset_t *sigset)
 297 {
 298     sigaddset_deferrable(sigset);
 299     sigaddset_gc(sigset);
 300 }
 301
 302 void
 303 sigaddset_gc(sigset_t *sigset)
 304 {
 305 #ifdef LISP_FEATURE_SB_THREAD
 306     sigaddset(sigset,SIG_STOP_FOR_GC);
 307 #endif
 308 }
 309
 310 /* initialized in interrupt_init */
 311 sigset_t deferrable_sigset;
 312 sigset_t blockable_sigset;
 313 sigset_t gc_sigset;
 314
 315 #endif
 316
 317 #if !defined(LISP_FEATURE_WIN32)
 318 boolean
 319 deferrables_blocked_p(sigset_t *sigset)
 320 {
 321     return all_signals_blocked_p(sigset, &deferrable_sigset, "deferrable");
 322 }
 323 #endif
 324
 325 void
 326 check_deferrables_unblocked_or_lose(sigset_t *sigset)
 327 {
 328 #if !defined(LISP_FEATURE_WIN32)
 329     if (deferrables_blocked_p(sigset))
 330         lose("deferrables blocked\n");
 331 #endif
 332 }
 333
 334 void
 335 check_deferrables_blocked_or_lose(sigset_t *sigset)
 336 {
 337 #if !defined(LISP_FEATURE_WIN32)
 338     if (!deferrables_blocked_p(sigset))
 339         lose("deferrables unblocked\n");
 340 #endif
 341 }
 342
 343 #if !defined(LISP_FEATURE_WIN32)
 344 boolean
 345 blockables_blocked_p(sigset_t *sigset)
 346 {
 347     return all_signals_blocked_p(sigset, &blockable_sigset, "blockable");
 348 }
 349 #endif
 350
 351 void
 352 check_blockables_unblocked_or_lose(sigset_t *sigset)
 353 {
 354 #if !defined(LISP_FEATURE_WIN32)
 355     if (blockables_blocked_p(sigset))
 356         lose("blockables blocked\n");
 357 #endif
 358 }
 359
 360 void
 361 check_blockables_blocked_or_lose(sigset_t *sigset)
 362 {
 363 #if !defined(LISP_FEATURE_WIN32)
 364     if (!blockables_blocked_p(sigset))
 365         lose("blockables unblocked\n");
 366 #endif
 367 }
 368
 369 #if !defined(LISP_FEATURE_WIN32)
 370 boolean
 371 gc_signals_blocked_p(sigset_t *sigset)
 372 {
 373     return all_signals_blocked_p(sigset, &gc_sigset, "gc");
 374 }
 375 #endif
 376
 377 void
 378 check_gc_signals_unblocked_or_lose(sigset_t *sigset)
 379 {
 380 #if !defined(LISP_FEATURE_WIN32)
 381     if (gc_signals_blocked_p(sigset))
 382         lose("gc signals blocked\n");
 383 #endif
 384 }
 385
 386 void
 387 check_gc_signals_blocked_or_lose(sigset_t *sigset)
 388 {
 389 #if !defined(LISP_FEATURE_WIN32)
 390     if (!gc_signals_blocked_p(sigset))
 391         lose("gc signals unblocked\n");
 392 #endif
 393 }
 394
 395 void
 396 block_deferrable_signals(sigset_t *where, sigset_t *old)
 397 {
 398 #ifndef LISP_FEATURE_WIN32
 399     block_signals(&deferrable_sigset, where, old);
 400 #endif
 401 }
 402
 403 void
 404 block_blockable_signals(sigset_t *where, sigset_t *old)
 405 {
 406 #ifndef LISP_FEATURE_WIN32
 407     block_signals(&blockable_sigset, where, old);
 408 #endif
 409 }
 410
 411 void
 412 block_gc_signals(sigset_t *where, sigset_t *old)
 413 {
 414 #ifndef LISP_FEATURE_WIN32
 415     block_signals(&gc_sigset, where, old);
 416 #endif
 417 }
 418
 419 void
 420 unblock_deferrable_signals(sigset_t *where, sigset_t *old)
 421 {
 422 #ifndef LISP_FEATURE_WIN32
 423     if (interrupt_handler_pending_p())
 424         lose("unblock_deferrable_signals: losing proposition\n");
 425     check_gc_signals_unblocked_or_lose(where);
 426     unblock_signals(&deferrable_sigset, where, old);
 427 #endif
 428 }
 429
 430 void
 431 unblock_blockable_signals(sigset_t *where, sigset_t *old)
 432 {
 433 #ifndef LISP_FEATURE_WIN32
 434     unblock_signals(&blockable_sigset, where, old);
 435 #endif
 436 }
 437
 438 void
 439 unblock_gc_signals(sigset_t *where, sigset_t *old)
 440 {
 441 #ifndef LISP_FEATURE_WIN32
 442     unblock_signals(&gc_sigset, where, old);
 443 #endif
 444 }
 445
 446 void
 447 unblock_signals_in_context_and_maybe_warn(os_context_t *context)
 448 {
 449 #ifndef LISP_FEATURE_WIN32
 450     sigset_t *sigset = os_context_sigmask_addr(context);
 451     if (all_signals_blocked_p(sigset, &gc_sigset, "gc")) {
 452         corruption_warning_and_maybe_lose(
 453 "Enabling blocked gc signals to allow returning to Lisp without risking\n\
 454 gc deadlocks. Since GC signals are only blocked in signal handlers when \n\
 455 they are not safe to interrupt at all, this is a pretty severe occurrence.\n");
 456         unblock_gc_signals(sigset, 0);
 457     }
 458     if (!interrupt_handler_pending_p()) {
 459         unblock_deferrable_signals(sigset, 0);
 460     }
 461 #endif
 462 }
 463 \f
 464
 465 inline static void
 466 check_interrupts_enabled_or_lose(os_context_t *context)
 467 {
 468     struct thread *thread=arch_os_get_current_thread();
 469     if (SymbolValue(INTERRUPTS_ENABLED,thread) == NIL)
 470         lose("interrupts not enabled\n");
 471     if (arch_pseudo_atomic_atomic(context))
 472         lose ("in pseudo atomic section\n");
 473 }
 474
 475 /* Save sigset (or the current sigmask if 0) if there is no pending
 476  * handler, because that means that deferabbles are already blocked.
 477  * The purpose is to avoid losing the pending gc signal if a
 478  * deferrable interrupt async unwinds between clearing the pseudo
 479  * atomic and trapping to GC.*/
 480 void
 481 maybe_save_gc_mask_and_block_deferrables(sigset_t *sigset)
 482 {
 483 #ifndef LISP_FEATURE_WIN32
 484     struct thread *thread = arch_os_get_current_thread();
 485     struct interrupt_data *data = thread->interrupt_data;
 486     sigset_t oldset;
 487     /* Obviously, this function is called when signals may not be
 488      * blocked. Let's make sure we are not interrupted. */
 489     block_blockable_signals(0, &oldset);
 490 #ifndef LISP_FEATURE_SB_THREAD
 491     /* With threads a SIG_STOP_FOR_GC and a normal GC may also want to
 492      * block. */
 493     if (data->gc_blocked_deferrables)
 494         lose("gc_blocked_deferrables already true\n");
 495 #endif
 496     if ((!data->pending_handler) &&
 497         (!data->gc_blocked_deferrables)) {
 498         FSHOW_SIGNAL((stderr,"/setting gc_blocked_deferrables\n"));
 499         data->gc_blocked_deferrables = 1;
 500         if (sigset) {
 501             /* This is the sigmask of some context. */
 502             sigcopyset(&data->pending_mask, sigset);
 503             sigaddset_deferrable(sigset);
 504             thread_sigmask(SIG_SETMASK,&oldset,0);
 505             return;
 506         } else {
 507             /* Operating on the current sigmask. Save oldset and
 508              * unblock gc signals. In the end, this is equivalent to
 509              * blocking the deferrables. */
 510             sigcopyset(&data->pending_mask, &oldset);
 511             thread_sigmask(SIG_UNBLOCK, &gc_sigset, 0);
 512             return;
 513         }
 514     }
 515     thread_sigmask(SIG_SETMASK,&oldset,0);
 516 #endif
 517 }
 518
 519 /* Are we leaving WITH-GCING and already running with interrupts
 520  * enabled, without the protection of *GC-INHIBIT* T and there is gc
 521  * (or stop for gc) pending, but we haven't trapped yet? */
 522 int
 523 in_leaving_without_gcing_race_p(struct thread *thread)
 524 {
 525     return ((SymbolValue(IN_WITHOUT_GCING,thread) != NIL) &&
 526             (SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) &&
 527             (SymbolValue(GC_INHIBIT,thread) == NIL) &&
 528             ((SymbolValue(GC_PENDING,thread) != NIL)
 529 #if defined(LISP_FEATURE_SB_THREAD)
 530              || (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL)
 531 #endif
 532              ));
 533 }
 534
 535 /* Check our baroque invariants. */
 536 void
 537 check_interrupt_context_or_lose(os_context_t *context)
 538 {
 539 #ifndef LISP_FEATURE_WIN32
 540     struct thread *thread = arch_os_get_current_thread();
 541     struct interrupt_data *data = thread->interrupt_data;
 542     int interrupt_deferred_p = (data->pending_handler != 0);
 543     int interrupt_pending = (SymbolValue(INTERRUPT_PENDING,thread) != NIL);
 544     sigset_t *sigset = os_context_sigmask_addr(context);
 545     /* On PPC pseudo_atomic_interrupted is cleared when coming out of
 546      * handle_allocation_trap. */
 547 #if defined(LISP_FEATURE_GENCGC) && !defined(LISP_FEATURE_PPC)
 548     int interrupts_enabled = (SymbolValue(INTERRUPTS_ENABLED,thread) != NIL);
 549     int gc_inhibit = (SymbolValue(GC_INHIBIT,thread) != NIL);
 550     int gc_pending = (SymbolValue(GC_PENDING,thread) == T);
 551     int pseudo_atomic_interrupted = get_pseudo_atomic_interrupted(thread);
 552     int in_race_p = in_leaving_without_gcing_race_p(thread);
 553     /* In the time window between leaving the *INTERRUPTS-ENABLED* NIL
 554      * section and trapping, a SIG_STOP_FOR_GC would see the next
 555      * check fail, for this reason sig_stop_for_gc handler does not
 556      * call this function. */
 557     if (interrupt_deferred_p) {
 558         if (!(!interrupts_enabled || pseudo_atomic_interrupted || in_race_p))
 559             lose("Stray deferred interrupt.\n");
 560     }
 561     if (gc_pending)
 562         if (!(pseudo_atomic_interrupted || gc_inhibit || in_race_p))
 563             lose("GC_PENDING, but why?\n");
 564 #if defined(LISP_FEATURE_SB_THREAD)
 565     {
 566         int stop_for_gc_pending =
 567             (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL);
 568         if (stop_for_gc_pending)
 569             if (!(pseudo_atomic_interrupted || gc_inhibit || in_race_p))
 570                 lose("STOP_FOR_GC_PENDING, but why?\n");
 571         if (pseudo_atomic_interrupted)
 572             if (!(gc_pending || stop_for_gc_pending || interrupt_deferred_p))
 573                 lose("pseudo_atomic_interrupted, but why?\n");
 574     }
 575 #else
 576     if (pseudo_atomic_interrupted)
 577         if (!(gc_pending || interrupt_deferred_p))
 578             lose("pseudo_atomic_interrupted, but why?\n");
 579 #endif
 580 #endif
 581     if (interrupt_pending && !interrupt_deferred_p)
 582         lose("INTERRUPT_PENDING but not pending handler.\n");
 583     if ((data->gc_blocked_deferrables) && interrupt_pending)
 584         lose("gc_blocked_deferrables and interrupt pending\n.");
 585     if (data->gc_blocked_deferrables)
 586         check_deferrables_blocked_or_lose(sigset);
 587     if (interrupt_pending || interrupt_deferred_p ||
 588         data->gc_blocked_deferrables)
 589         check_deferrables_blocked_or_lose(sigset);
 590     else {
 591         check_deferrables_unblocked_or_lose(sigset);
 592         /* If deferrables are unblocked then we are open to signals
 593          * that run lisp code. */
 594         check_gc_signals_unblocked_or_lose(sigset);
 595     }
 596 #endif
 597 }
 598 \f
 599 /*
 600  * utility routines used by various signal handlers
 601  */
 602
 603 static void
 604 build_fake_control_stack_frames(struct thread *th,os_context_t *context)
 605 {
 606 #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
 607
 608     lispobj oldcont;
 609
 610     /* Build a fake stack frame or frames */
 611
 612     current_control_frame_pointer =
 613         (lispobj *)(unsigned long)
 614             (*os_context_register_addr(context, reg_CSP));
 615     if ((lispobj *)(unsigned long)
 616             (*os_context_register_addr(context, reg_CFP))
 617         == current_control_frame_pointer) {
 618         /* There is a small window during call where the callee's
 619          * frame isn't built yet. */
 620         if (lowtag_of(*os_context_register_addr(context, reg_CODE))
 621             == FUN_POINTER_LOWTAG) {
 622             /* We have called, but not built the new frame, so
 623              * build it for them. */
 624             current_control_frame_pointer[0] =
 625                 *os_context_register_addr(context, reg_OCFP);
 626             current_control_frame_pointer[1] =
 627                 *os_context_register_addr(context, reg_LRA);
 628             current_control_frame_pointer += 8;
 629             /* Build our frame on top of it. */
 630             oldcont = (lispobj)(*os_context_register_addr(context, reg_CFP));
 631         }
 632         else {
 633             /* We haven't yet called, build our frame as if the
 634              * partial frame wasn't there. */
 635             oldcont = (lispobj)(*os_context_register_addr(context, reg_OCFP));
 636         }
 637     }
 638     /* We can't tell whether we are still in the caller if it had to
 639      * allocate a stack frame due to stack arguments. */
 640     /* This observation provoked some past CMUCL maintainer to ask
 641      * "Can anything strange happen during return?" */
 642     else {
 643         /* normal case */
 644         oldcont = (lispobj)(*os_context_register_addr(context, reg_CFP));
 645     }
 646
 647     current_control_stack_pointer = current_control_frame_pointer + 8;
 648
 649     current_control_frame_pointer[0] = oldcont;
 650     current_control_frame_pointer[1] = NIL;
 651     current_control_frame_pointer[2] =
 652         (lispobj)(*os_context_register_addr(context, reg_CODE));
 653 #endif
 654 }
 655
 656 /* Stores the context for gc to scavange and builds fake stack
 657  * frames. */
 658 void
 659 fake_foreign_function_call(os_context_t *context)
 660 {
 661     int context_index;
 662     struct thread *thread=arch_os_get_current_thread();
 663
 664     /* context_index incrementing must not be interrupted */
 665     check_blockables_blocked_or_lose(0);
 666
 667     /* Get current Lisp state from context. */
 668 #ifdef reg_ALLOC
 669     dynamic_space_free_pointer =
 670         (lispobj *)(unsigned long)
 671             (*os_context_register_addr(context, reg_ALLOC));
 672 /*     fprintf(stderr,"dynamic_space_free_pointer: %p\n", */
 673 /*             dynamic_space_free_pointer); */
 674 #if defined(LISP_FEATURE_ALPHA) || defined(LISP_FEATURE_MIPS)
 675     if ((long)dynamic_space_free_pointer & 1) {
 676         lose("dead in fake_foreign_function_call, context = %x\n", context);
 677     }
 678 #endif
 679 /* why doesnt PPC and SPARC do something like this: */
 680 #if defined(LISP_FEATURE_HPPA)
 681     if ((long)dynamic_space_free_pointer & 4) {
 682         lose("dead in fake_foreign_function_call, context = %x, d_s_f_p = %x\n", context, dynamic_space_free_pointer);
 683     }
 684 #endif
 685 #endif
 686 #ifdef reg_BSP
 687     current_binding_stack_pointer =
 688         (lispobj *)(unsigned long)
 689             (*os_context_register_addr(context, reg_BSP));
 690 #endif
 691
 692     build_fake_control_stack_frames(thread,context);
 693
 694     /* Do dynamic binding of the active interrupt context index
 695      * and save the context in the context array. */
 696     context_index =
 697         fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread));
 698
 699     if (context_index >= MAX_INTERRUPTS) {
 700         lose("maximum interrupt nesting depth (%d) exceeded\n", MAX_INTERRUPTS);
 701     }
 702
 703     bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,
 704                   make_fixnum(context_index + 1),thread);
 705
 706     thread->interrupt_contexts[context_index] = context;
 707
 708 #ifdef FOREIGN_FUNCTION_CALL_FLAG
 709     foreign_function_call_active = 1;
 710 #endif
 711 }
 712
 713 /* blocks all blockable signals.  If you are calling from a signal handler,
 714  * the usual signal mask will be restored from the context when the handler
 715  * finishes.  Otherwise, be careful */
 716 void
 717 undo_fake_foreign_function_call(os_context_t *context)
 718 {
 719     struct thread *thread=arch_os_get_current_thread();
 720     /* Block all blockable signals. */
 721     block_blockable_signals(0, 0);
 722
 723 #ifdef FOREIGN_FUNCTION_CALL_FLAG
 724     foreign_function_call_active = 0;
 725 #endif
 726
 727     /* Undo dynamic binding of FREE_INTERRUPT_CONTEXT_INDEX */
 728     unbind(thread);
 729
 730 #ifdef reg_ALLOC
 731     /* Put the dynamic space free pointer back into the context. */
 732     *os_context_register_addr(context, reg_ALLOC) =
 733         (unsigned long) dynamic_space_free_pointer
 734         | (*os_context_register_addr(context, reg_ALLOC)
 735            & LOWTAG_MASK);
 736     /*
 737       ((unsigned long)(*os_context_register_addr(context, reg_ALLOC))
 738       & ~LOWTAG_MASK)
 739       | ((unsigned long) dynamic_space_free_pointer & LOWTAG_MASK);
 740     */
 741 #endif
 742 }
 743
 744 /* a handler for the signal caused by execution of a trap opcode
 745  * signalling an internal error */
 746 void
 747 interrupt_internal_error(os_context_t *context, boolean continuable)
 748 {
 749     lispobj context_sap;
 750
 751     fake_foreign_function_call(context);
 752
 753     if (!internal_errors_enabled) {
 754         describe_internal_error(context);
 755         /* There's no good way to recover from an internal error
 756          * before the Lisp error handling mechanism is set up. */
 757         lose("internal error too early in init, can't recover\n");
 758     }
 759
 760     /* Allocate the SAP object while the interrupts are still
 761      * disabled. */
 762     unblock_gc_signals(0, 0);
 763     context_sap = alloc_sap(context);
 764
 765 #ifndef LISP_FEATURE_WIN32
 766     thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
 767 #endif
 768
 769 #if defined(LISP_FEATURE_LINUX) && defined(LISP_FEATURE_MIPS)
 770     /* Workaround for blocked SIGTRAP. */
 771     {
 772         sigset_t newset;
 773         sigemptyset(&newset);
 774         sigaddset(&newset, SIGTRAP);
 775         thread_sigmask(SIG_UNBLOCK, &newset, 0);
 776     }
 777 #endif
 778
 779     SHOW("in interrupt_internal_error");
 780 #if QSHOW
 781     /* Display some rudimentary debugging information about the
 782      * error, so that even if the Lisp error handler gets badly
 783      * confused, we have a chance to determine what's going on. */
 784     describe_internal_error(context);
 785 #endif
 786     funcall2(StaticSymbolFunction(INTERNAL_ERROR), context_sap,
 787              continuable ? T : NIL);
 788
 789     undo_fake_foreign_function_call(context); /* blocks signals again */
 790     if (continuable)
 791         arch_skip_instruction(context);
 792 }
 793
 794 boolean
 795 interrupt_handler_pending_p(void)
 796 {
 797     struct thread *thread = arch_os_get_current_thread();
 798     struct interrupt_data *data = thread->interrupt_data;
 799     return (data->pending_handler != 0);
 800 }
 801
 802 void
 803 interrupt_handle_pending(os_context_t *context)
 804 {
 805     /* There are three ways we can get here. First, if an interrupt
 806      * occurs within pseudo-atomic, it will be deferred, and we'll
 807      * trap to here at the end of the pseudo-atomic block. Second, if
 808      * the GC (in alloc()) decides that a GC is required, it will set
 809      * *GC-PENDING* and pseudo-atomic-interrupted if not *GC-INHIBIT*,
 810      * and alloc() is always called from within pseudo-atomic, and
 811      * thus we end up here again. Third, when calling GC-ON or at the
 812      * end of a WITHOUT-GCING, MAYBE-HANDLE-PENDING-GC will trap to
 813      * here if there is a pending GC. Fourth, ahem, at the end of
 814      * WITHOUT-INTERRUPTS (bar complications with nesting). */
 815
 816     /* Win32 only needs to handle the GC cases (for now?) */
 817
 818     struct thread *thread = arch_os_get_current_thread();
 819     struct interrupt_data *data = thread->interrupt_data;
 820
 821     if (arch_pseudo_atomic_atomic(context)) {
 822         lose("Handling pending interrupt in pseudo atomic.");
 823     }
 824
 825     FSHOW_SIGNAL((stderr, "/entering interrupt_handle_pending\n"));
 826
 827     check_blockables_blocked_or_lose(0);
 828
 829     /* If GC/SIG_STOP_FOR_GC struck during PA and there was no pending
 830      * handler, then the pending mask was saved and
 831      * gc_blocked_deferrables set. Hence, there can be no pending
 832      * handler and it's safe to restore the pending mask.
 833      *
 834      * Note, that if gc_blocked_deferrables is false we may still have
 835      * to GC. In this case, we are coming out of a WITHOUT-GCING or a
 836      * pseudo atomic was interrupt be a deferrable first. */
 837     if (data->gc_blocked_deferrables) {
 838         if (data->pending_handler)
 839             lose("GC blocked deferrables but still got a pending handler.");
 840         if (SymbolValue(GC_INHIBIT,thread)!=NIL)
 841             lose("GC blocked deferrables while GC is inhibited.");
 842         /* Restore the saved signal mask from the original signal (the
 843          * one that interrupted us during the critical section) into
 844          * the os_context for the signal we're currently in the
 845          * handler for. This should ensure that when we return from
 846          * the handler the blocked signals are unblocked. */
 847 #ifndef LISP_FEATURE_WIN32
 848         sigcopyset(os_context_sigmask_addr(context), &data->pending_mask);
 849 #endif
 850         data->gc_blocked_deferrables = 0;
 851     }
 852
 853     if (SymbolValue(GC_INHIBIT,thread)==NIL) {
 854         void *original_pending_handler = data->pending_handler;
 855
 856 #ifdef LISP_FEATURE_SB_THREAD
 857         if (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL) {
 858             /* STOP_FOR_GC_PENDING and GC_PENDING are cleared by
 859              * the signal handler if it actually stops us. */
 860             arch_clear_pseudo_atomic_interrupted(context);
 861             sig_stop_for_gc_handler(SIG_STOP_FOR_GC,NULL,context);
 862         } else
 863 #endif
 864          /* Test for T and not for != NIL since the value :IN-PROGRESS
 865           * is used in SUB-GC as part of the mechanism to supress
 866           * recursive gcs.*/
 867         if (SymbolValue(GC_PENDING,thread) == T) {
 868
 869             /* Two reasons for doing this. First, if there is a
 870              * pending handler we don't want to run. Second, we are
 871              * going to clear pseudo atomic interrupted to avoid
 872              * spurious trapping on every allocation in SUB_GC and
 873              * having a pending handler with interrupts enabled and
 874              * without pseudo atomic interrupted breaks an
 875              * invariant. */
 876             if (data->pending_handler) {
 877                 bind_variable(ALLOW_WITH_INTERRUPTS, NIL, thread);
 878                 bind_variable(INTERRUPTS_ENABLED, NIL, thread);
 879             }
 880
 881             arch_clear_pseudo_atomic_interrupted(context);
 882
 883             /* GC_PENDING is cleared in SUB-GC, or if another thread
 884              * is doing a gc already we will get a SIG_STOP_FOR_GC and
 885              * that will clear it.
 886              *
 887              * If there is a pending handler or gc was triggerred in a
 888              * signal handler then maybe_gc won't run POST_GC and will
 889              * return normally. */
 890             if (!maybe_gc(context))
 891                 lose("GC not inhibited but maybe_gc did not GC.");
 892
 893             if (data->pending_handler) {
 894                 unbind(thread);
 895                 unbind(thread);
 896             }
 897         } else if (SymbolValue(GC_PENDING,thread) != NIL) {
 898             /* It's not NIL or T so GC_PENDING is :IN-PROGRESS. If
 899              * GC-PENDING is not NIL then we cannot trap on pseudo
 900              * atomic due to GC (see if(GC_PENDING) logic in
 901              * cheneygc.c an gengcgc.c), plus there is a outer
 902              * WITHOUT-INTERRUPTS SUB_GC, so how did we end up
 903              * here? */
 904             lose("Trapping to run pending handler while GC in progress.");
 905         }
 906
 907         check_blockables_blocked_or_lose(0);
 908
 909         /* No GC shall be lost. If SUB_GC triggers another GC then
 910          * that should be handled on the spot. */
 911         if (SymbolValue(GC_PENDING,thread) != NIL)
 912             lose("GC_PENDING after doing gc.");
 913 #ifdef LISP_FEATURE_SB_THREAD
 914         if (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL)
 915             lose("STOP_FOR_GC_PENDING after doing gc.");
 916 #endif
 917         /* Check two things. First, that gc does not clobber a handler
 918          * that's already pending. Second, that there is no interrupt
 919          * lossage: if original_pending_handler was NULL then even if
 920          * an interrupt arrived during GC (POST-GC, really) it was
 921          * handled. */
 922         if (original_pending_handler != data->pending_handler)
 923             lose("pending handler changed in gc: %x -> %d.",
 924                  original_pending_handler, data->pending_handler);
 925     }
 926
 927 #ifndef LISP_FEATURE_WIN32
 928     /* There may be no pending handler, because it was only a gc that
 929      * had to be executed or because Lisp is a bit too eager to call
 930      * DO-PENDING-INTERRUPT. */
 931     if ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) &&
 932         (data->pending_handler))  {
 933         /* No matter how we ended up here, clear both
 934          * INTERRUPT_PENDING and pseudo atomic interrupted. It's safe
 935          * because we checked above that there is no GC pending. */
 936         SetSymbolValue(INTERRUPT_PENDING, NIL, thread);
 937         arch_clear_pseudo_atomic_interrupted(context);
 938         /* Restore the sigmask in the context. */
 939         sigcopyset(os_context_sigmask_addr(context), &data->pending_mask);
 940         run_deferred_handler(data, context);
 941     }
 942 #endif
 943 #ifdef LISP_FEATURE_GENCGC
 944     if (get_pseudo_atomic_interrupted(thread))
 945         lose("pseudo_atomic_interrupted after interrupt_handle_pending\n");
 946 #endif
 947     /* It is possible that the end of this function was reached
 948      * without never actually doing anything, the tests in Lisp for
 949      * when to call receive-pending-interrupt are not exact. */
 950     FSHOW_SIGNAL((stderr, "/exiting interrupt_handle_pending\n"));
 951 }
 952 \f
 953
 954 void
 955 interrupt_handle_now(int signal, siginfo_t *info, os_context_t *context)
 956 {
 957 #ifdef FOREIGN_FUNCTION_CALL_FLAG
 958     boolean were_in_lisp;
 959 #endif
 960     union interrupt_handler handler;
 961
 962     check_blockables_blocked_or_lose(0);
 963
 964 #ifndef LISP_FEATURE_WIN32
 965     if (sigismember(&deferrable_sigset,signal))
 966         check_interrupts_enabled_or_lose(context);
 967 #endif
 968
 969     handler = interrupt_handlers[signal];
 970
 971     if (ARE_SAME_HANDLER(handler.c, SIG_IGN)) {
 972         return;
 973     }
 974
 975 #ifdef FOREIGN_FUNCTION_CALL_FLAG
 976     were_in_lisp = !foreign_function_call_active;
 977     if (were_in_lisp)
 978 #endif
 979     {
 980         fake_foreign_function_call(context);
 981     }
 982
 983     FSHOW_SIGNAL((stderr,
 984                   "/entering interrupt_handle_now(%d, info, context)\n",
 985                   signal));
 986
 987     if (ARE_SAME_HANDLER(handler.c, SIG_DFL)) {
 988
 989         /* This can happen if someone tries to ignore or default one
 990          * of the signals we need for runtime support, and the runtime
 991          * support decides to pass on it. */
 992         lose("no handler for signal %d in interrupt_handle_now(..)\n", signal);
 993
 994     } else if (lowtag_of(handler.lisp) == FUN_POINTER_LOWTAG) {
 995         /* Once we've decided what to do about contexts in a
 996          * return-elsewhere world (the original context will no longer
 997          * be available; should we copy it or was nobody using it anyway?)
 998          * then we should convert this to return-elsewhere */
 999
1000         /* CMUCL comment said "Allocate the SAPs while the interrupts
1001          * are still disabled.".  I (dan, 2003.08.21) assume this is
1002          * because we're not in pseudoatomic and allocation shouldn't
1003          * be interrupted.  In which case it's no longer an issue as
1004          * all our allocation from C now goes through a PA wrapper,
1005          * but still, doesn't hurt.
1006          *
1007          * Yeah, but non-gencgc platforms don't really wrap allocation
1008          * in PA. MG - 2005-08-29  */
1009
1010         lispobj info_sap, context_sap;
1011         /* Leave deferrable signals blocked, the handler itself will
1012          * allow signals again when it sees fit. */
1013         unblock_gc_signals(0, 0);
1014         context_sap = alloc_sap(context);
1015         info_sap = alloc_sap(info);
1016
1017         FSHOW_SIGNAL((stderr,"/calling Lisp-level handler\n"));
1018
1019         funcall3(handler.lisp,
1020                  make_fixnum(signal),
1021                  info_sap,
1022                  context_sap);
1023     } else {
1024         /* This cannot happen in sane circumstances. */
1025
1026         FSHOW_SIGNAL((stderr,"/calling C-level handler\n"));
1027
1028 #ifndef LISP_FEATURE_WIN32
1029         /* Allow signals again. */
1030         thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
1031 #endif
1032         (*handler.c)(signal, info, context);
1033     }
1034
1035 #ifdef FOREIGN_FUNCTION_CALL_FLAG
1036     if (were_in_lisp)
1037 #endif
1038     {
1039         undo_fake_foreign_function_call(context); /* block signals again */
1040     }
1041
1042     FSHOW_SIGNAL((stderr,
1043                   "/returning from interrupt_handle_now(%d, info, context)\n",
1044                   signal));
1045 }
1046
1047 /* This is called at the end of a critical section if the indications
1048  * are that some signal was deferred during the section.  Note that as
1049  * far as C or the kernel is concerned we dealt with the signal
1050  * already; we're just doing the Lisp-level processing now that we
1051  * put off then */
1052 static void
1053 run_deferred_handler(struct interrupt_data *data, os_context_t *context)
1054 {
1055     /* The pending_handler may enable interrupts and then another
1056      * interrupt may hit, overwrite interrupt_data, so reset the
1057      * pending handler before calling it. Trust the handler to finish
1058      * with the siginfo before enabling interrupts. */
1059     void (*pending_handler) (int, siginfo_t*, os_context_t*) =
1060         data->pending_handler;
1061
1062     data->pending_handler=0;
1063     FSHOW_SIGNAL((stderr, "/running deferred handler %p\n", pending_handler));
1064     (*pending_handler)(data->pending_signal,&(data->pending_info), context);
1065 }
1066
1067 #ifndef LISP_FEATURE_WIN32
1068 boolean
1069 maybe_defer_handler(void *handler, struct interrupt_data *data,
1070                     int signal, siginfo_t *info, os_context_t *context)
1071 {
1072     struct thread *thread=arch_os_get_current_thread();
1073
1074     check_blockables_blocked_or_lose(0);
1075
1076     if (SymbolValue(INTERRUPT_PENDING,thread) != NIL)
1077         lose("interrupt already pending\n");
1078     if (thread->interrupt_data->pending_handler)
1079         lose("there is a pending handler already (PA)\n");
1080     if (data->gc_blocked_deferrables)
1081         lose("maybe_defer_handler: gc_blocked_deferrables true\n");
1082     check_interrupt_context_or_lose(context);
1083     /* If interrupts are disabled then INTERRUPT_PENDING is set and
1084      * not PSEDUO_ATOMIC_INTERRUPTED. This is important for a pseudo
1085      * atomic section inside a WITHOUT-INTERRUPTS.
1086      *
1087      * Also, if in_leaving_without_gcing_race_p then
1088      * interrupt_handle_pending is going to be called soon, so
1089      * stashing the signal away is safe.
1090      */
1091     if ((SymbolValue(INTERRUPTS_ENABLED,thread) == NIL) ||
1092         in_leaving_without_gcing_race_p(thread)) {
1093         FSHOW_SIGNAL((stderr,
1094                       "/maybe_defer_handler(%x,%d): deferred (RACE=%d)\n",
1095                       (unsigned int)handler,signal,
1096                       in_leaving_without_gcing_race_p(thread)));
1097         store_signal_data_for_later(data,handler,signal,info,context);
1098         SetSymbolValue(INTERRUPT_PENDING, T,thread);
1099         check_interrupt_context_or_lose(context);
1100         return 1;
1101     }
1102     /* a slightly confusing test. arch_pseudo_atomic_atomic() doesn't
1103      * actually use its argument for anything on x86, so this branch
1104      * may succeed even when context is null (gencgc alloc()) */
1105     if (arch_pseudo_atomic_atomic(context)) {
1106         FSHOW_SIGNAL((stderr,
1107                       "/maybe_defer_handler(%x,%d): deferred(PA)\n",
1108                       (unsigned int)handler,signal));
1109         store_signal_data_for_later(data,handler,signal,info,context);
1110         arch_set_pseudo_atomic_interrupted(context);
1111         check_interrupt_context_or_lose(context);
1112         return 1;
1113     }
1114     FSHOW_SIGNAL((stderr,
1115                   "/maybe_defer_handler(%x,%d): not deferred\n",
1116                   (unsigned int)handler,signal));
1117     return 0;
1118 }
1119
1120 static void
1121 store_signal_data_for_later (struct interrupt_data *data, void *handler,
1122                              int signal,
1123                              siginfo_t *info, os_context_t *context)
1124 {
1125     if (data->pending_handler)
1126         lose("tried to overwrite pending interrupt handler %x with %x\n",
1127              data->pending_handler, handler);
1128     if (!handler)
1129         lose("tried to defer null interrupt handler\n");
1130     data->pending_handler = handler;
1131     data->pending_signal = signal;
1132     if(info)
1133         memcpy(&(data->pending_info), info, sizeof(siginfo_t));
1134
1135     FSHOW_SIGNAL((stderr, "/store_signal_data_for_later: signal: %d\n",
1136                   signal));
1137
1138     if(!context)
1139         lose("Null context");
1140
1141     /* the signal mask in the context (from before we were
1142      * interrupted) is copied to be restored when run_deferred_handler
1143      * happens. Then the usually-blocked signals are added to the mask
1144      * in the context so that we are running with blocked signals when
1145      * the handler returns */
1146     sigcopyset(&(data->pending_mask),os_context_sigmask_addr(context));
1147     sigaddset_deferrable(os_context_sigmask_addr(context));
1148 }
1149
1150 static void
1151 maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
1152 {
1153     SAVE_ERRNO(signal,context,void_context);
1154     struct thread *thread = arch_os_get_current_thread();
1155     struct interrupt_data *data = thread->interrupt_data;
1156     if(!maybe_defer_handler(interrupt_handle_now,data,signal,info,context))
1157         interrupt_handle_now(signal, info, context);
1158     RESTORE_ERRNO;
1159 }
1160
1161 static void
1162 low_level_interrupt_handle_now(int signal, siginfo_t *info,
1163                                os_context_t *context)
1164 {
1165     /* No FP control fixage needed, caller has done that. */
1166     check_blockables_blocked_or_lose(0);
1167     check_interrupts_enabled_or_lose(context);
1168     (*interrupt_low_level_handlers[signal])(signal, info, context);
1169     /* No Darwin context fixage needed, caller does that. */
1170 }
1171
1172 static void
1173 low_level_maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
1174 {
1175     SAVE_ERRNO(signal,context,void_context);
1176     struct thread *thread = arch_os_get_current_thread();
1177     struct interrupt_data *data = thread->interrupt_data;
1178
1179     if(!maybe_defer_handler(low_level_interrupt_handle_now,data,
1180                             signal,info,context))
1181         low_level_interrupt_handle_now(signal, info, context);
1182     RESTORE_ERRNO;
1183 }
1184 #endif
1185
1186 #ifdef LISP_FEATURE_SB_THREAD
1187
1188 /* This function must not cons, because that may trigger a GC. */
1189 void
1190 sig_stop_for_gc_handler(int signal, siginfo_t *info, os_context_t *context)
1191 {
1192     struct thread *thread=arch_os_get_current_thread();
1193
1194     /* Test for GC_INHIBIT _first_, else we'd trap on every single
1195      * pseudo atomic until gc is finally allowed. */
1196     if (SymbolValue(GC_INHIBIT,thread) != NIL) {
1197         FSHOW_SIGNAL((stderr, "sig_stop_for_gc deferred (*GC-INHIBIT*)\n"));
1198         SetSymbolValue(STOP_FOR_GC_PENDING,T,thread);
1199         return;
1200     } else if (arch_pseudo_atomic_atomic(context)) {
1201         FSHOW_SIGNAL((stderr,"sig_stop_for_gc deferred (PA)\n"));
1202         SetSymbolValue(STOP_FOR_GC_PENDING,T,thread);
1203         arch_set_pseudo_atomic_interrupted(context);
1204         maybe_save_gc_mask_and_block_deferrables
1205             (os_context_sigmask_addr(context));
1206         return;
1207     }
1208
1209     FSHOW_SIGNAL((stderr, "/sig_stop_for_gc_handler\n"));
1210
1211     /* Not PA and GC not inhibited -- we can stop now. */
1212
1213     /* need the context stored so it can have registers scavenged */
1214     fake_foreign_function_call(context);
1215
1216     /* Not pending anymore. */
1217     SetSymbolValue(GC_PENDING,NIL,thread);
1218     SetSymbolValue(STOP_FOR_GC_PENDING,NIL,thread);
1219
1220     /* Consider this: in a PA section GC is requested: GC_PENDING,
1221      * pseudo_atomic_interrupted and gc_blocked_deferrables are set,
1222      * deferrables are blocked then pseudo_atomic_atomic is cleared,
1223      * but a SIG_STOP_FOR_GC arrives before trapping to
1224      * interrupt_handle_pending. Here, GC_PENDING is cleared but
1225      * pseudo_atomic_interrupted is not and we go on running with
1226      * pseudo_atomic_interrupted but without a pending interrupt or
1227      * GC. GC_BLOCKED_DEFERRABLES is also left at 1. So let's tidy it
1228      * up. */
1229     if (thread->interrupt_data->gc_blocked_deferrables) {
1230         FSHOW_SIGNAL((stderr,"cleaning up after gc_blocked_deferrables\n"));
1231         clear_pseudo_atomic_interrupted(thread);
1232         sigcopyset(os_context_sigmask_addr(context),
1233                    &thread->interrupt_data->pending_mask);
1234         thread->interrupt_data->gc_blocked_deferrables = 0;
1235     }
1236
1237     if(thread_state(thread)!=STATE_RUNNING) {
1238         lose("sig_stop_for_gc_handler: wrong thread state: %ld\n",
1239              fixnum_value(thread->state));
1240     }
1241
1242     set_thread_state(thread,STATE_SUSPENDED);
1243     FSHOW_SIGNAL((stderr,"suspended\n"));
1244
1245     /* While waiting for gc to finish occupy ourselves with zeroing
1246      * the unused portion of the control stack to reduce conservatism.
1247      * On hypothetic platforms with threads and exact gc it is
1248      * actually a must. */
1249     scrub_control_stack();
1250
1251     wait_for_thread_state_change(thread, STATE_SUSPENDED);
1252     FSHOW_SIGNAL((stderr,"resumed\n"));
1253
1254     if(thread_state(thread)!=STATE_RUNNING) {
1255         lose("sig_stop_for_gc_handler: wrong thread state on wakeup: %ld\n",
1256              fixnum_value(thread_state(thread)));
1257     }
1258
1259     undo_fake_foreign_function_call(context);
1260 }
1261
1262 #endif
1263
1264 void
1265 interrupt_handle_now_handler(int signal, siginfo_t *info, void *void_context)
1266 {
1267     SAVE_ERRNO(signal,context,void_context);
1268 #ifndef LISP_FEATURE_WIN32
1269     if ((signal == SIGILL) || (signal == SIGBUS)
1270 #ifndef LISP_FEATURE_LINUX
1271         || (signal == SIGEMT)
1272 #endif
1273         )
1274         corruption_warning_and_maybe_lose("Signal %d recieved", signal);
1275 #endif
1276     interrupt_handle_now(signal, info, context);
1277     RESTORE_ERRNO;
1278 }
1279
1280 /* manipulate the signal context and stack such that when the handler
1281  * returns, it will call function instead of whatever it was doing
1282  * previously
1283  */
1284
1285 #if (defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
1286 extern int *context_eflags_addr(os_context_t *context);
1287 #endif
1288
1289 extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
1290 extern void post_signal_tramp(void);
1291 extern void call_into_lisp_tramp(void);
1292 void
1293 arrange_return_to_lisp_function(os_context_t *context, lispobj function)
1294 {
1295 #ifndef LISP_FEATURE_WIN32
1296     check_gc_signals_unblocked_or_lose
1297         (os_context_sigmask_addr(context));
1298 #endif
1299 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
1300     void * fun=native_pointer(function);
1301     void *code = &(((struct simple_fun *) fun)->code);
1302 #endif
1303
1304     /* Build a stack frame showing `interrupted' so that the
1305      * user's backtrace makes (as much) sense (as usual) */
1306
1307     /* fp state is saved and restored by call_into_lisp */
1308     /* FIXME: errno is not restored, but since current uses of this
1309      * function only call Lisp code that signals an error, it's not
1310      * much of a problem. In other words, running out of the control
1311      * stack between a syscall and (GET-ERRNO) may clobber errno if
1312      * something fails during signalling or in the handler. But I
1313      * can't see what can go wrong as long as there is no CONTINUE
1314      * like restart on them. */
1315 #ifdef LISP_FEATURE_X86
1316     /* Suppose the existence of some function that saved all
1317      * registers, called call_into_lisp, then restored GP registers and
1318      * returned.  It would look something like this:
1319
1320      push   ebp
1321      mov    ebp esp
1322      pushfl
1323      pushal
1324      push   $0
1325      push   $0
1326      pushl  {address of function to call}
1327      call   0x8058db0 <call_into_lisp>
1328      addl   $12,%esp
1329      popal
1330      popfl
1331      leave
1332      ret
1333
1334      * What we do here is set up the stack that call_into_lisp would
1335      * expect to see if it had been called by this code, and frob the
1336      * signal context so that signal return goes directly to call_into_lisp,
1337      * and when that function (and the lisp function it invoked) returns,
1338      * it returns to the second half of this imaginary function which
1339      * restores all registers and returns to C
1340
1341      * For this to work, the latter part of the imaginary function
1342      * must obviously exist in reality.  That would be post_signal_tramp
1343      */
1344
1345     u32 *sp=(u32 *)*os_context_register_addr(context,reg_ESP);
1346
1347 #if defined(LISP_FEATURE_DARWIN)
1348     u32 *register_save_area = (u32 *)os_validate(0, 0x40);
1349
1350     FSHOW_SIGNAL((stderr, "/arrange_return_to_lisp_function: preparing to go to function %x, sp: %x\n", function, sp));
1351     FSHOW_SIGNAL((stderr, "/arrange_return_to_lisp_function: context: %x, &context %x\n", context, &context));
1352
1353     /* 1. os_validate (malloc/mmap) register_save_block
1354      * 2. copy register state into register_save_block
1355      * 3. put a pointer to register_save_block in a register in the context
1356      * 4. set the context's EIP to point to a trampoline which:
1357      *    a. builds the fake stack frame from the block
1358      *    b. frees the block
1359      *    c. calls the function
1360      */
1361
1362     *register_save_area = *os_context_pc_addr(context);
1363     *(register_save_area + 1) = function;
1364     *(register_save_area + 2) = *os_context_register_addr(context,reg_EDI);
1365     *(register_save_area + 3) = *os_context_register_addr(context,reg_ESI);
1366     *(register_save_area + 4) = *os_context_register_addr(context,reg_EDX);
1367     *(register_save_area + 5) = *os_context_register_addr(context,reg_ECX);
1368     *(register_save_area + 6) = *os_context_register_addr(context,reg_EBX);
1369     *(register_save_area + 7) = *os_context_register_addr(context,reg_EAX);
1370     *(register_save_area + 8) = *context_eflags_addr(context);
1371
1372     *os_context_pc_addr(context) =
1373       (os_context_register_t) call_into_lisp_tramp;
1374     *os_context_register_addr(context,reg_ECX) =
1375       (os_context_register_t) register_save_area;
1376 #else
1377
1378     /* return address for call_into_lisp: */
1379     *(sp-15) = (u32)post_signal_tramp;
1380     *(sp-14) = function;        /* args for call_into_lisp : function*/
1381     *(sp-13) = 0;               /*                           arg array */
1382     *(sp-12) = 0;               /*                           no. args */
1383     /* this order matches that used in POPAD */
1384     *(sp-11)=*os_context_register_addr(context,reg_EDI);
1385     *(sp-10)=*os_context_register_addr(context,reg_ESI);
1386
1387     *(sp-9)=*os_context_register_addr(context,reg_ESP)-8;
1388     /* POPAD ignores the value of ESP:  */
1389     *(sp-8)=0;
1390     *(sp-7)=*os_context_register_addr(context,reg_EBX);
1391
1392     *(sp-6)=*os_context_register_addr(context,reg_EDX);
1393     *(sp-5)=*os_context_register_addr(context,reg_ECX);
1394     *(sp-4)=*os_context_register_addr(context,reg_EAX);
1395     *(sp-3)=*context_eflags_addr(context);
1396     *(sp-2)=*os_context_register_addr(context,reg_EBP);
1397     *(sp-1)=*os_context_pc_addr(context);
1398
1399 #endif
1400
1401 #elif defined(LISP_FEATURE_X86_64)
1402     u64 *sp=(u64 *)*os_context_register_addr(context,reg_RSP);
1403
1404     /* return address for call_into_lisp: */
1405     *(sp-18) = (u64)post_signal_tramp;
1406
1407     *(sp-17)=*os_context_register_addr(context,reg_R15);
1408     *(sp-16)=*os_context_register_addr(context,reg_R14);
1409     *(sp-15)=*os_context_register_addr(context,reg_R13);
1410     *(sp-14)=*os_context_register_addr(context,reg_R12);
1411     *(sp-13)=*os_context_register_addr(context,reg_R11);
1412     *(sp-12)=*os_context_register_addr(context,reg_R10);
1413     *(sp-11)=*os_context_register_addr(context,reg_R9);
1414     *(sp-10)=*os_context_register_addr(context,reg_R8);
1415     *(sp-9)=*os_context_register_addr(context,reg_RDI);
1416     *(sp-8)=*os_context_register_addr(context,reg_RSI);
1417     /* skip RBP and RSP */
1418     *(sp-7)=*os_context_register_addr(context,reg_RBX);
1419     *(sp-6)=*os_context_register_addr(context,reg_RDX);
1420     *(sp-5)=*os_context_register_addr(context,reg_RCX);
1421     *(sp-4)=*os_context_register_addr(context,reg_RAX);
1422     *(sp-3)=*context_eflags_addr(context);
1423     *(sp-2)=*os_context_register_addr(context,reg_RBP);
1424     *(sp-1)=*os_context_pc_addr(context);
1425
1426     *os_context_register_addr(context,reg_RDI) =
1427         (os_context_register_t)function; /* function */
1428     *os_context_register_addr(context,reg_RSI) = 0;        /* arg. array */
1429     *os_context_register_addr(context,reg_RDX) = 0;        /* no. args */
1430 #else
1431     struct thread *th=arch_os_get_current_thread();
1432     build_fake_control_stack_frames(th,context);
1433 #endif
1434
1435 #ifdef LISP_FEATURE_X86
1436
1437 #if !defined(LISP_FEATURE_DARWIN)
1438     *os_context_pc_addr(context) = (os_context_register_t)call_into_lisp;
1439     *os_context_register_addr(context,reg_ECX) = 0;
1440     *os_context_register_addr(context,reg_EBP) = (os_context_register_t)(sp-2);
1441 #ifdef __NetBSD__
1442     *os_context_register_addr(context,reg_UESP) =
1443         (os_context_register_t)(sp-15);
1444 #else
1445     *os_context_register_addr(context,reg_ESP) = (os_context_register_t)(sp-15);
1446 #endif /* __NETBSD__ */
1447 #endif /* LISP_FEATURE_DARWIN */
1448
1449 #elif defined(LISP_FEATURE_X86_64)
1450     *os_context_pc_addr(context) = (os_context_register_t)call_into_lisp;
1451     *os_context_register_addr(context,reg_RCX) = 0;
1452     *os_context_register_addr(context,reg_RBP) = (os_context_register_t)(sp-2);
1453     *os_context_register_addr(context,reg_RSP) = (os_context_register_t)(sp-18);
1454 #else
1455     /* this much of the calling convention is common to all
1456        non-x86 ports */
1457     *os_context_pc_addr(context) = (os_context_register_t)(unsigned long)code;
1458     *os_context_register_addr(context,reg_NARGS) = 0;
1459     *os_context_register_addr(context,reg_LIP) =
1460         (os_context_register_t)(unsigned long)code;
1461     *os_context_register_addr(context,reg_CFP) =
1462         (os_context_register_t)(unsigned long)current_control_frame_pointer;
1463 #endif
1464 #ifdef ARCH_HAS_NPC_REGISTER
1465     *os_context_npc_addr(context) =
1466         4 + *os_context_pc_addr(context);
1467 #endif
1468 #ifdef LISP_FEATURE_SPARC
1469     *os_context_register_addr(context,reg_CODE) =
1470         (os_context_register_t)(fun + FUN_POINTER_LOWTAG);
1471 #endif
1472     FSHOW((stderr, "/arranged return to Lisp function (0x%lx)\n",
1473            (long)function));
1474 }
1475
1476 /* KLUDGE: Theoretically the approach we use for undefined alien
1477  * variables should work for functions as well, but on PPC/Darwin
1478  * we get bus error at bogus addresses instead, hence this workaround,
1479  * that has the added benefit of automatically discriminating between
1480  * functions and variables.
1481  */
1482 void
1483 undefined_alien_function(void)
1484 {
1485     funcall0(StaticSymbolFunction(UNDEFINED_ALIEN_FUNCTION_ERROR));
1486 }
1487
1488 /* Called from the REPL, too. */
1489 void reset_control_stack_guard_page(void)
1490 {
1491     struct thread *th=arch_os_get_current_thread();
1492     if (th->control_stack_guard_page_protected == NIL) {
1493         memset(CONTROL_STACK_GUARD_PAGE(th), 0, os_vm_page_size);
1494         protect_control_stack_guard_page(1, NULL);
1495         protect_control_stack_return_guard_page(0, NULL);
1496         th->control_stack_guard_page_protected = T;
1497         fprintf(stderr, "INFO: Control stack guard page reprotected\n");
1498     }
1499 }
1500
1501 boolean
1502 handle_guard_page_triggered(os_context_t *context,os_vm_address_t addr)
1503 {
1504     struct thread *th=arch_os_get_current_thread();
1505
1506     if(addr >= CONTROL_STACK_HARD_GUARD_PAGE(th) &&
1507        addr < CONTROL_STACK_HARD_GUARD_PAGE(th) + os_vm_page_size) {
1508         lose("Control stack exhausted");
1509     }
1510     else if(addr >= CONTROL_STACK_GUARD_PAGE(th) &&
1511             addr < CONTROL_STACK_GUARD_PAGE(th) + os_vm_page_size) {
1512         /* We hit the end of the control stack: disable guard page
1513          * protection so the error handler has some headroom, protect the
1514          * previous page so that we can catch returns from the guard page
1515          * and restore it. */
1516         if (th->control_stack_guard_page_protected == NIL)
1517             lose("control_stack_guard_page_protected NIL");
1518         protect_control_stack_guard_page(0, NULL);
1519         protect_control_stack_return_guard_page(1, NULL);
1520         th->control_stack_guard_page_protected = NIL;
1521         fprintf(stderr, "INFO: Control stack guard page unprotected\n");
1522
1523 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
1524         /* For the unfortunate case, when the control stack is
1525          * exhausted in a signal handler. */
1526         unblock_signals_in_context_and_maybe_warn(context);
1527 #endif
1528         arrange_return_to_lisp_function
1529             (context, StaticSymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR));
1530         return 1;
1531     }
1532     else if(addr >= CONTROL_STACK_RETURN_GUARD_PAGE(th) &&
1533             addr < CONTROL_STACK_RETURN_GUARD_PAGE(th) + os_vm_page_size) {
1534         /* We're returning from the guard page: reprotect it, and
1535          * unprotect this one. This works even if we somehow missed
1536          * the return-guard-page, and hit it on our way to new
1537          * exhaustion instead. */
1538         if (th->control_stack_guard_page_protected != NIL)
1539             lose("control_stack_guard_page_protected not NIL");
1540         reset_control_stack_guard_page();
1541         return 1;
1542     }
1543     else if(addr >= BINDING_STACK_HARD_GUARD_PAGE(th) &&
1544             addr < BINDING_STACK_HARD_GUARD_PAGE(th) + os_vm_page_size) {
1545         lose("Binding stack exhausted");
1546     }
1547     else if(addr >= BINDING_STACK_GUARD_PAGE(th) &&
1548             addr < BINDING_STACK_GUARD_PAGE(th) + os_vm_page_size) {
1549         protect_binding_stack_guard_page(0, NULL);
1550         protect_binding_stack_return_guard_page(1, NULL);
1551         fprintf(stderr, "INFO: Binding stack guard page unprotected\n");
1552
1553         /* For the unfortunate case, when the binding stack is
1554          * exhausted in a signal handler. */
1555         unblock_signals_in_context_and_maybe_warn(context);
1556         arrange_return_to_lisp_function
1557             (context, StaticSymbolFunction(BINDING_STACK_EXHAUSTED_ERROR));
1558         return 1;
1559     }
1560     else if(addr >= BINDING_STACK_RETURN_GUARD_PAGE(th) &&
1561             addr < BINDING_STACK_RETURN_GUARD_PAGE(th) + os_vm_page_size) {
1562         protect_binding_stack_guard_page(1, NULL);
1563         protect_binding_stack_return_guard_page(0, NULL);
1564         fprintf(stderr, "INFO: Binding stack guard page reprotected\n");
1565         return 1;
1566     }
1567     else if(addr >= ALIEN_STACK_HARD_GUARD_PAGE(th) &&
1568             addr < ALIEN_STACK_HARD_GUARD_PAGE(th) + os_vm_page_size) {
1569         lose("Alien stack exhausted");
1570     }
1571     else if(addr >= ALIEN_STACK_GUARD_PAGE(th) &&
1572             addr < ALIEN_STACK_GUARD_PAGE(th) + os_vm_page_size) {
1573         protect_alien_stack_guard_page(0, NULL);
1574         protect_alien_stack_return_guard_page(1, NULL);
1575         fprintf(stderr, "INFO: Alien stack guard page unprotected\n");
1576
1577         /* For the unfortunate case, when the alien stack is
1578          * exhausted in a signal handler. */
1579         unblock_signals_in_context_and_maybe_warn(context);
1580         arrange_return_to_lisp_function
1581             (context, StaticSymbolFunction(ALIEN_STACK_EXHAUSTED_ERROR));
1582         return 1;
1583     }
1584     else if(addr >= ALIEN_STACK_RETURN_GUARD_PAGE(th) &&
1585             addr < ALIEN_STACK_RETURN_GUARD_PAGE(th) + os_vm_page_size) {
1586         protect_alien_stack_guard_page(1, NULL);
1587         protect_alien_stack_return_guard_page(0, NULL);
1588         fprintf(stderr, "INFO: Alien stack guard page reprotected\n");
1589         return 1;
1590     }
1591     else if (addr >= undefined_alien_address &&
1592              addr < undefined_alien_address + os_vm_page_size) {
1593         arrange_return_to_lisp_function
1594             (context, StaticSymbolFunction(UNDEFINED_ALIEN_VARIABLE_ERROR));
1595         return 1;
1596     }
1597     else return 0;
1598 }
1599 \f
1600 /*
1601  * noise to install handlers
1602  */
1603
1604 #ifndef LISP_FEATURE_WIN32
1605 /* In Linux 2.4 synchronous signals (sigtrap & co) can be delivered if
1606  * they are blocked, in Linux 2.6 the default handler is invoked
1607  * instead that usually coredumps. One might hastily think that adding
1608  * SA_NODEFER helps, but until ~2.6.13 if SA_NODEFER is specified then
1609  * the whole sa_mask is ignored and instead of not adding the signal
1610  * in question to the mask. That means if it's not blockable the
1611  * signal must be unblocked at the beginning of signal handlers.
1612  *
1613  * It turns out that NetBSD's SA_NODEFER doesn't DTRT in a different
1614  * way: if SA_NODEFER is set and the signal is in sa_mask, the signal
1615  * will be unblocked in the sigmask during the signal handler.  -- RMK
1616  * X-mas day, 2005
1617  */
1618 static volatile int sigaction_nodefer_works = -1;
1619
1620 #define SA_NODEFER_TEST_BLOCK_SIGNAL SIGABRT
1621 #define SA_NODEFER_TEST_KILL_SIGNAL SIGUSR1
1622
1623 static void
1624 sigaction_nodefer_test_handler(int signal, siginfo_t *info, void *void_context)
1625 {
1626     sigset_t current;
1627     int i;
1628     get_current_sigmask(&current);
1629     /* There should be exactly two blocked signals: the two we added
1630      * to sa_mask when setting up the handler.  NetBSD doesn't block
1631      * the signal we're handling when SA_NODEFER is set; Linux before
1632      * 2.6.13 or so also doesn't block the other signal when
1633      * SA_NODEFER is set. */
1634     for(i = 1; i < NSIG; i++)
1635         if (sigismember(&current, i) !=
1636             (((i == SA_NODEFER_TEST_BLOCK_SIGNAL) || (i == signal)) ? 1 : 0)) {
1637             FSHOW_SIGNAL((stderr, "SA_NODEFER doesn't work, signal %d\n", i));
1638             sigaction_nodefer_works = 0;
1639         }
1640     if (sigaction_nodefer_works == -1)
1641         sigaction_nodefer_works = 1;
1642 }
1643
1644 static void
1645 see_if_sigaction_nodefer_works(void)
1646 {
1647     struct sigaction sa, old_sa;
1648
1649     sa.sa_flags = SA_SIGINFO | SA_NODEFER;
1650     sa.sa_sigaction = sigaction_nodefer_test_handler;
1651     sigemptyset(&sa.sa_mask);
1652     sigaddset(&sa.sa_mask, SA_NODEFER_TEST_BLOCK_SIGNAL);
1653     sigaddset(&sa.sa_mask, SA_NODEFER_TEST_KILL_SIGNAL);
1654     sigaction(SA_NODEFER_TEST_KILL_SIGNAL, &sa, &old_sa);
1655     /* Make sure no signals are blocked. */
1656     {
1657         sigset_t empty;
1658         sigemptyset(&empty);
1659         thread_sigmask(SIG_SETMASK, &empty, 0);
1660     }
1661     kill(getpid(), SA_NODEFER_TEST_KILL_SIGNAL);
1662     while (sigaction_nodefer_works == -1);
1663     sigaction(SA_NODEFER_TEST_KILL_SIGNAL, &old_sa, NULL);
1664 }
1665
1666 #undef SA_NODEFER_TEST_BLOCK_SIGNAL
1667 #undef SA_NODEFER_TEST_KILL_SIGNAL
1668
1669 static void
1670 unblock_me_trampoline(int signal, siginfo_t *info, void *void_context)
1671 {
1672     SAVE_ERRNO(signal,context,void_context);
1673     sigset_t unblock;
1674
1675     sigemptyset(&unblock);
1676     sigaddset(&unblock, signal);
1677     thread_sigmask(SIG_UNBLOCK, &unblock, 0);
1678     interrupt_handle_now(signal, info, context);
1679     RESTORE_ERRNO;
1680 }
1681
1682 static void
1683 low_level_unblock_me_trampoline(int signal, siginfo_t *info, void *void_context)
1684 {
1685     SAVE_ERRNO(signal,context,void_context);
1686     sigset_t unblock;
1687
1688     sigemptyset(&unblock);
1689     sigaddset(&unblock, signal);
1690     thread_sigmask(SIG_UNBLOCK, &unblock, 0);
1691     (*interrupt_low_level_handlers[signal])(signal, info, context);
1692     RESTORE_ERRNO;
1693 }
1694
1695 static void
1696 low_level_handle_now_handler(int signal, siginfo_t *info, void *void_context)
1697 {
1698     SAVE_ERRNO(signal,context,void_context);
1699     (*interrupt_low_level_handlers[signal])(signal, info, context);
1700     RESTORE_ERRNO;
1701 }
1702
1703 void
1704 undoably_install_low_level_interrupt_handler (int signal,
1705                                               interrupt_handler_t handler)
1706 {
1707     struct sigaction sa;
1708
1709     if (0 > signal || signal >= NSIG) {
1710         lose("bad signal number %d\n", signal);
1711     }
1712
1713     if (ARE_SAME_HANDLER(handler, SIG_DFL))
1714         sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))handler;
1715     else if (sigismember(&deferrable_sigset,signal))
1716         sa.sa_sigaction = low_level_maybe_now_maybe_later;
1717     else if (!sigaction_nodefer_works &&
1718              !sigismember(&blockable_sigset, signal))
1719         sa.sa_sigaction = low_level_unblock_me_trampoline;
1720     else
1721         sa.sa_sigaction = low_level_handle_now_handler;
1722
1723     sigcopyset(&sa.sa_mask, &blockable_sigset);
1724     sa.sa_flags = SA_SIGINFO | SA_RESTART
1725         | (sigaction_nodefer_works ? SA_NODEFER : 0);
1726 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
1727     if((signal==SIG_MEMORY_FAULT))
1728         sa.sa_flags |= SA_ONSTACK;
1729 #endif
1730
1731     sigaction(signal, &sa, NULL);
1732     interrupt_low_level_handlers[signal] =
1733         (ARE_SAME_HANDLER(handler, SIG_DFL) ? 0 : handler);
1734 }
1735 #endif
1736
1737 /* This is called from Lisp. */
1738 unsigned long
1739 install_handler(int signal, void handler(int, siginfo_t*, os_context_t*))
1740 {
1741 #ifndef LISP_FEATURE_WIN32
1742     struct sigaction sa;
1743     sigset_t old;
1744     union interrupt_handler oldhandler;
1745
1746     FSHOW((stderr, "/entering POSIX install_handler(%d, ..)\n", signal));
1747
1748     block_blockable_signals(0, &old);
1749
1750     FSHOW((stderr, "/interrupt_low_level_handlers[signal]=%x\n",
1751            (unsigned int)interrupt_low_level_handlers[signal]));
1752     if (interrupt_low_level_handlers[signal]==0) {
1753         if (ARE_SAME_HANDLER(handler, SIG_DFL) ||
1754             ARE_SAME_HANDLER(handler, SIG_IGN))
1755             sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))handler;
1756         else if (sigismember(&deferrable_sigset, signal))
1757             sa.sa_sigaction = maybe_now_maybe_later;
1758         else if (!sigaction_nodefer_works &&
1759                  !sigismember(&blockable_sigset, signal))
1760             sa.sa_sigaction = unblock_me_trampoline;
1761         else
1762             sa.sa_sigaction = interrupt_handle_now_handler;
1763
1764         sigcopyset(&sa.sa_mask, &blockable_sigset);
1765         sa.sa_flags = SA_SIGINFO | SA_RESTART |
1766             (sigaction_nodefer_works ? SA_NODEFER : 0);
1767         sigaction(signal, &sa, NULL);
1768     }
1769
1770     oldhandler = interrupt_handlers[signal];
1771     interrupt_handlers[signal].c = handler;
1772
1773     thread_sigmask(SIG_SETMASK, &old, 0);
1774
1775     FSHOW((stderr, "/leaving POSIX install_handler(%d, ..)\n", signal));
1776
1777     return (unsigned long)oldhandler.lisp;
1778 #else
1779     /* Probably-wrong Win32 hack */
1780     return 0;
1781 #endif
1782 }
1783
1784 /* This must not go through lisp as it's allowed anytime, even when on
1785  * the altstack. */
1786 void
1787 sigabrt_handler(int signal, siginfo_t *info, os_context_t *context)
1788 {
1789     lose("SIGABRT received.\n");
1790 }
1791
1792 void
1793 interrupt_init(void)
1794 {
1795 #ifndef LISP_FEATURE_WIN32
1796     int i;
1797     SHOW("entering interrupt_init()");
1798     see_if_sigaction_nodefer_works();
1799     sigemptyset(&deferrable_sigset);
1800     sigemptyset(&blockable_sigset);
1801     sigemptyset(&gc_sigset);
1802     sigaddset_deferrable(&deferrable_sigset);
1803     sigaddset_blockable(&blockable_sigset);
1804     sigaddset_gc(&gc_sigset);
1805
1806     /* Set up high level handler information. */
1807     for (i = 0; i < NSIG; i++) {
1808         interrupt_handlers[i].c =
1809             /* (The cast here blasts away the distinction between
1810              * SA_SIGACTION-style three-argument handlers and
1811              * signal(..)-style one-argument handlers, which is OK
1812              * because it works to call the 1-argument form where the
1813              * 3-argument form is expected.) */
1814             (void (*)(int, siginfo_t*, os_context_t*))SIG_DFL;
1815     }
1816     undoably_install_low_level_interrupt_handler(SIGABRT, sigabrt_handler);
1817     SHOW("returning from interrupt_init()");
1818 #endif
1819 }
1820
1821 #ifndef LISP_FEATURE_WIN32
1822 int
1823 siginfo_code(siginfo_t *info)
1824 {
1825     return info->si_code;
1826 }
1827 os_vm_address_t current_memory_fault_address;
1828
1829 void
1830 lisp_memory_fault_error(os_context_t *context, os_vm_address_t addr)
1831 {
1832    /* FIXME: This is lossy: if we get another memory fault (eg. from
1833     * another thread) before lisp has read this, we lose the information.
1834     * However, since this is mostly informative, we'll live with that for
1835     * now -- some address is better then no address in this case.
1836     */
1837     current_memory_fault_address = addr;
1838     /* To allow debugging memory faults in signal handlers and such. */
1839     corruption_warning_and_maybe_lose("Memory fault at %x (pc=%p, sp=%p)",
1840                                       addr,
1841                                       *os_context_pc_addr(context),
1842 #ifdef ARCH_HAS_STACK_POINTER
1843                                       *os_context_sp_addr(context)
1844 #else
1845                                       0
1846 #endif
1847                                       );
1848     unblock_signals_in_context_and_maybe_warn(context);
1849 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
1850     arrange_return_to_lisp_function(context,
1851                                     StaticSymbolFunction(MEMORY_FAULT_ERROR));
1852 #else
1853     funcall0(StaticSymbolFunction(MEMORY_FAULT_ERROR));
1854 #endif
1855 }
1856 #endif
1857
1858 static void
1859 unhandled_trap_error(os_context_t *context)
1860 {
1861     lispobj context_sap;
1862     fake_foreign_function_call(context);
1863     unblock_gc_signals(0, 0);
1864     context_sap = alloc_sap(context);
1865 #ifndef LISP_FEATURE_WIN32
1866     thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
1867 #endif
1868     funcall1(StaticSymbolFunction(UNHANDLED_TRAP_ERROR), context_sap);
1869     lose("UNHANDLED-TRAP-ERROR fell through");
1870 }
1871
1872 /* Common logic for trapping instructions. How we actually handle each
1873  * case is highly architecture dependent, but the overall shape is
1874  * this. */
1875 void
1876 handle_trap(os_context_t *context, int trap)
1877 {
1878     switch(trap) {
1879     case trap_PendingInterrupt:
1880         FSHOW((stderr, "/<trap pending interrupt>\n"));
1881         arch_skip_instruction(context);
1882         interrupt_handle_pending(context);
1883         break;
1884     case trap_Error:
1885     case trap_Cerror:
1886         FSHOW((stderr, "/<trap error/cerror %d>\n", trap));
1887         interrupt_internal_error(context, trap==trap_Cerror);
1888         break;
1889     case trap_Breakpoint:
1890         arch_handle_breakpoint(context);
1891         break;
1892     case trap_FunEndBreakpoint:
1893         arch_handle_fun_end_breakpoint(context);
1894         break;
1895 #ifdef trap_AfterBreakpoint
1896     case trap_AfterBreakpoint:
1897         arch_handle_after_breakpoint(context);
1898         break;
1899 #endif
1900 #ifdef trap_SingleStepAround
1901     case trap_SingleStepAround:
1902     case trap_SingleStepBefore:
1903         arch_handle_single_step_trap(context, trap);
1904         break;
1905 #endif
1906     case trap_Halt:
1907         fake_foreign_function_call(context);
1908         lose("%%PRIMITIVE HALT called; the party is over.\n");
1909     default:
1910         unhandled_trap_error(context);
1911     }
1912 }