src/runtime/interrupt.c

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