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