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