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