X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Finterrupt.c;h=882e2bb322e64bda821c0c90dadee262911685f5;hb=bf40ae88bc289fd765a33861cc4bc0853ed483ba;hp=2a82a2eca22b2ea43f19575c189e3ffeba79a875;hpb=e6f4c7523aa628ece995ee01879d3fb90eed6d9f;p=sbcl.git diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 2a82a2e..882e2bb 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -102,7 +102,7 @@ union interrupt_handler interrupt_handlers[NSIG]; * work for SIGSEGV and similar. It is good enough for timers, and * maybe all deferrables. */ -#ifdef LISP_FEATURE_SB_THREAD +#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_WIN32) static void add_handled_signals(sigset_t *sigset) { @@ -121,7 +121,7 @@ void block_signals(sigset_t *what, sigset_t *where, sigset_t *old); static boolean maybe_resignal_to_lisp_thread(int signal, os_context_t *context) { -#ifdef LISP_FEATURE_SB_THREAD +#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_WIN32) if (!pthread_getspecific(lisp_thread)) { if (!(sigismember(&deferrable_sigset,signal))) { corruption_warning_and_maybe_lose @@ -175,7 +175,7 @@ maybe_resignal_to_lisp_thread(int signal, os_context_t *context) static void run_deferred_handler(struct interrupt_data *data, os_context_t *context); -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) static void store_signal_data_for_later (struct interrupt_data *data, void *handler, int signal, siginfo_t *info, @@ -240,7 +240,7 @@ boolean all_signals_blocked_p(sigset_t *sigset, sigset_t *sigset2, const char *name) { -#if !defined(LISP_FEATURE_WIN32) +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) int i; boolean has_blocked = 0, has_unblocked = 0; sigset_t current; @@ -314,7 +314,7 @@ sigset_t gc_sigset; #endif -#if !defined(LISP_FEATURE_WIN32) +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) boolean deferrables_blocked_p(sigset_t *sigset) { @@ -325,7 +325,7 @@ deferrables_blocked_p(sigset_t *sigset) void check_deferrables_unblocked_or_lose(sigset_t *sigset) { -#if !defined(LISP_FEATURE_WIN32) +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) if (deferrables_blocked_p(sigset)) lose("deferrables blocked\n"); #endif @@ -334,13 +334,13 @@ check_deferrables_unblocked_or_lose(sigset_t *sigset) void check_deferrables_blocked_or_lose(sigset_t *sigset) { -#if !defined(LISP_FEATURE_WIN32) +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) if (!deferrables_blocked_p(sigset)) lose("deferrables unblocked\n"); #endif } -#if !defined(LISP_FEATURE_WIN32) +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) boolean blockables_blocked_p(sigset_t *sigset) { @@ -351,7 +351,7 @@ blockables_blocked_p(sigset_t *sigset) void check_blockables_unblocked_or_lose(sigset_t *sigset) { -#if !defined(LISP_FEATURE_WIN32) +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) if (blockables_blocked_p(sigset)) lose("blockables blocked\n"); #endif @@ -361,6 +361,24 @@ void check_blockables_blocked_or_lose(sigset_t *sigset) { #if !defined(LISP_FEATURE_WIN32) + /* On Windows, there are no actual signals, but since the win32 port + * tracks the sigmask and checks it explicitly, some functions are + * still required to keep the mask set up properly. (After all, the + * goal of the sigmask emulation is to not have to change all the + * call sites in the first place.) + * + * However, this does not hold for all signals equally: While + * deferrables matter ("is interrupt-thread okay?"), it is not worth + * having to set up blockables properly (which include the + * non-existing GC signals). + * + * Yet, as the original comment explains it: + * Adjusting FREE-INTERRUPT-CONTEXT-INDEX* and other aspecs of + * fake_foreign_function_call machinery are sometimes useful here[...]. + * + * So we merely skip this assertion. + * -- DFL, trying to expand on a comment by AK. + */ if (!blockables_blocked_p(sigset)) lose("blockables unblocked\n"); #endif @@ -397,7 +415,7 @@ check_gc_signals_blocked_or_lose(sigset_t *sigset) void block_deferrable_signals(sigset_t *where, sigset_t *old) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) block_signals(&deferrable_sigset, where, old); #endif } @@ -405,7 +423,7 @@ block_deferrable_signals(sigset_t *where, sigset_t *old) void block_blockable_signals(sigset_t *where, sigset_t *old) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) block_signals(&blockable_sigset, where, old); #endif } @@ -414,7 +432,7 @@ block_blockable_signals(sigset_t *where, sigset_t *old) void block_gc_signals(sigset_t *where, sigset_t *old) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) block_signals(&gc_sigset, where, old); #endif } @@ -423,7 +441,7 @@ block_gc_signals(sigset_t *where, sigset_t *old) void unblock_deferrable_signals(sigset_t *where, sigset_t *old) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) if (interrupt_handler_pending_p()) lose("unblock_deferrable_signals: losing proposition\n"); #ifndef LISP_FEATURE_SB_SAFEPOINT @@ -436,7 +454,7 @@ unblock_deferrable_signals(sigset_t *where, sigset_t *old) void unblock_blockable_signals(sigset_t *where, sigset_t *old) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) unblock_signals(&blockable_sigset, where, old); #endif } @@ -454,7 +472,7 @@ unblock_gc_signals(sigset_t *where, sigset_t *old) void unblock_signals_in_context_and_maybe_warn(os_context_t *context) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) sigset_t *sigset = os_context_sigmask_addr(context); #ifndef LISP_FEATURE_SB_SAFEPOINT if (all_signals_blocked_p(sigset, &gc_sigset, "gc")) { @@ -548,7 +566,7 @@ in_leaving_without_gcing_race_p(struct thread *thread) void check_interrupt_context_or_lose(os_context_t *context) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) struct thread *thread = arch_os_get_current_thread(); struct interrupt_data *data = thread->interrupt_data; int interrupt_deferred_p = (data->pending_handler != 0); @@ -556,7 +574,7 @@ check_interrupt_context_or_lose(os_context_t *context) sigset_t *sigset = os_context_sigmask_addr(context); /* On PPC pseudo_atomic_interrupted is cleared when coming out of * handle_allocation_trap. */ -#if defined(LISP_FEATURE_GENCGC) && !defined(LISP_FEATURE_PPC) +#if defined(LISP_FEATURE_GENCGC) && !defined(GENCGC_IS_PRECISE) int interrupts_enabled = (SymbolValue(INTERRUPTS_ENABLED,thread) != NIL); int gc_inhibit = (SymbolValue(GC_INHIBIT,thread) != NIL); int gc_pending = (SymbolValue(GC_PENDING,thread) == T); @@ -624,9 +642,9 @@ build_fake_control_stack_frames(struct thread *th,os_context_t *context) /* Build a fake stack frame or frames */ access_control_frame_pointer(th) = - (lispobj *)(unsigned long) + (lispobj *)(uword_t) (*os_context_register_addr(context, reg_CSP)); - if ((lispobj *)(unsigned long) + if ((lispobj *)(uword_t) (*os_context_register_addr(context, reg_CFP)) == access_control_frame_pointer(th)) { /* There is a small window during call where the callee's @@ -684,19 +702,19 @@ fake_foreign_function_call(os_context_t *context) thread->pseudo_atomic_bits = #else dynamic_space_free_pointer = - (lispobj *)(unsigned long) + (lispobj *)(uword_t) #endif (*os_context_register_addr(context, reg_ALLOC)); /* fprintf(stderr,"dynamic_space_free_pointer: %p\n", */ /* dynamic_space_free_pointer); */ #if defined(LISP_FEATURE_ALPHA) || defined(LISP_FEATURE_MIPS) - if ((long)dynamic_space_free_pointer & 1) { + if ((sword_t)dynamic_space_free_pointer & 1) { lose("dead in fake_foreign_function_call, context = %x\n", context); } #endif /* why doesnt PPC and SPARC do something like this: */ #if defined(LISP_FEATURE_HPPA) - if ((long)dynamic_space_free_pointer & 4) { + if ((sword_t)dynamic_space_free_pointer & 4) { lose("dead in fake_foreign_function_call, context = %x, d_s_f_p = %x\n", context, dynamic_space_free_pointer); } #endif @@ -748,13 +766,13 @@ undo_fake_foreign_function_call(os_context_t *context) #if defined(reg_ALLOC) && !defined(LISP_FEATURE_SB_THREAD) /* Put the dynamic space free pointer back into the context. */ *os_context_register_addr(context, reg_ALLOC) = - (unsigned long) dynamic_space_free_pointer + (uword_t) dynamic_space_free_pointer | (*os_context_register_addr(context, reg_ALLOC) & LOWTAG_MASK); /* - ((unsigned long)(*os_context_register_addr(context, reg_ALLOC)) + ((uword_t)(*os_context_register_addr(context, reg_ALLOC)) & ~LOWTAG_MASK) - | ((unsigned long) dynamic_space_free_pointer & LOWTAG_MASK); + | ((uword_t) dynamic_space_free_pointer & LOWTAG_MASK); */ #endif #if defined(reg_ALLOC) && defined(LISP_FEATURE_SB_THREAD) @@ -762,7 +780,7 @@ undo_fake_foreign_function_call(os_context_t *context) * into the context (p-a-bits for p-a, and dynamic space free * pointer for ROOM). */ *os_context_register_addr(context, reg_ALLOC) = - (unsigned long) dynamic_space_free_pointer + (uword_t) dynamic_space_free_pointer | (thread->pseudo_atomic_bits & LOWTAG_MASK); /* And clear them so we don't get bit later by call-in/call-out * not updating them. */ @@ -793,7 +811,7 @@ interrupt_internal_error(os_context_t *context, boolean continuable) #endif context_sap = alloc_sap(context); -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); #endif @@ -808,7 +826,7 @@ interrupt_internal_error(os_context_t *context, boolean continuable) #endif SHOW("in interrupt_internal_error"); -#if QSHOW +#if QSHOW == 2 /* Display some rudimentary debugging information about the * error, so that even if the Lisp error handler gets badly * confused, we have a chance to determine what's going on. */ @@ -842,9 +860,14 @@ interrupt_handle_pending(os_context_t *context) * thus we end up here again. Third, when calling GC-ON or at the * end of a WITHOUT-GCING, MAYBE-HANDLE-PENDING-GC will trap to * here if there is a pending GC. Fourth, ahem, at the end of - * WITHOUT-INTERRUPTS (bar complications with nesting). */ - - /* Win32 only needs to handle the GC cases (for now?) */ + * WITHOUT-INTERRUPTS (bar complications with nesting). + * + * A fourth way happens with safepoints: In addition to a stop for + * GC that is pending, there are thruptions. Both mechanisms are + * mostly signal-free, yet also of an asynchronous nature, so it makes + * sense to let interrupt_handle_pending take care of running them: + * It gets run precisely at those places where it is safe to process + * pending asynchronous tasks. */ struct thread *thread = arch_os_get_current_thread(); struct interrupt_data *data = thread->interrupt_data; @@ -890,8 +913,15 @@ interrupt_handle_pending(os_context_t *context) void *original_pending_handler = data->pending_handler; #ifdef LISP_FEATURE_SB_SAFEPOINT - /* handles the STOP_FOR_GC_PENDING case */ - thread_pitstop(context); + /* handles the STOP_FOR_GC_PENDING case, plus THRUPTIONS */ + if (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL +# ifdef LISP_FEATURE_SB_THRUPTION + || (SymbolValue(THRUPTION_PENDING,thread) != NIL + && SymbolValue(INTERRUPTS_ENABLED, thread) != NIL) +# endif + ) + /* We ought to take this chance to do a pitstop now. */ + thread_in_lisp_raised(context); #elif defined(LISP_FEATURE_SB_THREAD) if (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL) { /* STOP_FOR_GC_PENDING and GC_PENDING are cleared by @@ -959,7 +989,7 @@ interrupt_handle_pending(os_context_t *context) * an interrupt arrived during GC (POST-GC, really) it was * handled. */ if (original_pending_handler != data->pending_handler) - lose("pending handler changed in gc: %x -> %d.", + lose("pending handler changed in gc: %x -> %x.", original_pending_handler, data->pending_handler); } @@ -978,6 +1008,17 @@ interrupt_handle_pending(os_context_t *context) sigcopyset(os_context_sigmask_addr(context), &data->pending_mask); run_deferred_handler(data, context); } +#ifdef LISP_FEATURE_SB_THRUPTION + if (SymbolValue(THRUPTION_PENDING,thread)==T) + /* Special case for the following situation: There is a + * thruption pending, but a signal had been deferred. The + * pitstop at the top of this function could only take care + * of GC, and skipped the thruption, so we need to try again + * now that INTERRUPT_PENDING and the sigmask have been + * reset. */ + while (check_pending_thruptions(context)) + ; +#endif #endif #ifdef LISP_FEATURE_GENCGC if (get_pseudo_atomic_interrupted(thread)) @@ -998,7 +1039,7 @@ interrupt_handle_now(int signal, siginfo_t *info, os_context_t *context) check_blockables_blocked_or_lose(0); -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) if (sigismember(&deferrable_sigset,signal)) check_interrupts_enabled_or_lose(context); #endif @@ -1065,11 +1106,11 @@ interrupt_handle_now(int signal, siginfo_t *info, os_context_t *context) FSHOW_SIGNAL((stderr,"/calling C-level handler\n")); -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) /* Allow signals again. */ thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); -#endif (*handler.c)(signal, info, context); +#endif } if (were_in_lisp) @@ -1524,7 +1565,7 @@ arrange_return_to_c_function(os_context_t *context, void arrange_return_to_lisp_function(os_context_t *context, lispobj function) { -#if defined(LISP_FEATURE_DARWIN) +#if defined(LISP_FEATURE_DARWIN) && defined(LISP_FEATURE_X86) arrange_return_to_c_function(context, call_into_lisp_tramp, function); #else arrange_return_to_c_function(context, call_into_lisp, function); @@ -1738,6 +1779,89 @@ see_if_sigaction_nodefer_works(void) #undef SA_NODEFER_TEST_BLOCK_SIGNAL #undef SA_NODEFER_TEST_KILL_SIGNAL +#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32) + +static void * +signal_thread_trampoline(void *pthread_arg) +{ + int signo = (int) pthread_arg; + os_context_t fake_context; + siginfo_t fake_info; +#ifdef LISP_FEATURE_PPC + mcontext_t uc_regs; +#endif + + memset(&fake_info, 0, sizeof(fake_info)); + memset(&fake_context, 0, sizeof(fake_context)); +#ifdef LISP_FEATURE_PPC + memset(&uc_regs, 0, sizeof(uc_regs)); + fake_context.uc_mcontext.uc_regs = &uc_regs; +#endif + + *os_context_pc_addr(&fake_context) = &signal_thread_trampoline; +#ifdef ARCH_HAS_STACK_POINTER /* aka x86(-64) */ + *os_context_sp_addr(&fake_context) = __builtin_frame_address(0); +#endif + + signal_handler_callback(interrupt_handlers[signo].lisp, + signo, &fake_info, &fake_context); + return 0; +} + +static void +sigprof_handler_trampoline(int signal, siginfo_t *info, void *void_context) +{ + SAVE_ERRNO(signal,context,void_context); + struct thread *self = arch_os_get_current_thread(); + + /* alloc() is not re-entrant and still uses pseudo atomic (even though + * inline allocation does not). In this case, give up. */ + if (get_pseudo_atomic_atomic(self)) + goto cleanup; + + struct alloc_region tmp = self->alloc_region; + self->alloc_region = self->sprof_alloc_region; + self->sprof_alloc_region = tmp; + + interrupt_handle_now_handler(signal, info, void_context); + + /* And we're back. We know that the SIGPROF handler never unwinds + * non-locally, and can simply swap things back: */ + + tmp = self->alloc_region; + self->alloc_region = self->sprof_alloc_region; + self->sprof_alloc_region = tmp; + +cleanup: + ; /* Dear C compiler, it's OK to have a label here. */ + RESTORE_ERRNO; +} + +static void +spawn_signal_thread_handler(int signal, siginfo_t *info, void *void_context) +{ + SAVE_ERRNO(signal,context,void_context); + + pthread_attr_t attr; + pthread_t th; + + if (pthread_attr_init(&attr)) + goto lost; + if (pthread_attr_setstacksize(&attr, thread_control_stack_size)) + goto lost; + if (pthread_create(&th, &attr, &signal_thread_trampoline, (void*) signal)) + goto lost; + if (pthread_attr_destroy(&attr)) + goto lost; + + RESTORE_ERRNO; + return; + +lost: + lose("spawn_signal_thread_handler"); +} +#endif + static void unblock_me_trampoline(int signal, siginfo_t *info, void *void_context) { @@ -1792,6 +1916,15 @@ undoably_install_low_level_interrupt_handler (int signal, else sa.sa_sigaction = low_level_handle_now_handler; +#ifdef LISP_FEATURE_SB_THRUPTION + /* It's in `deferrable_sigset' so that we block&unblock it properly, + * but we don't actually want to defer it. And if we put it only + * into blockable_sigset, we'd have to special-case it around thread + * creation at least. */ + if (signal == SIGPIPE) + sa.sa_sigaction = low_level_handle_now_handler; +#endif + sigcopyset(&sa.sa_mask, &blockable_sigset); sa.sa_flags = SA_SIGINFO | SA_RESTART | (sigaction_nodefer_works ? SA_NODEFER : 0); @@ -1812,8 +1945,9 @@ undoably_install_low_level_interrupt_handler (int signal, #endif /* This is called from Lisp. */ -unsigned long -install_handler(int signal, void handler(int, siginfo_t*, os_context_t*)) +uword_t +install_handler(int signal, void handler(int, siginfo_t*, os_context_t*), + int synchronous) { #ifndef LISP_FEATURE_WIN32 struct sigaction sa; @@ -1830,6 +1964,12 @@ install_handler(int signal, void handler(int, siginfo_t*, os_context_t*)) if (ARE_SAME_HANDLER(handler, SIG_DFL) || ARE_SAME_HANDLER(handler, SIG_IGN)) sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))handler; +#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY + else if (signal == SIGPROF) + sa.sa_sigaction = sigprof_handler_trampoline; + else if (!synchronous) + sa.sa_sigaction = spawn_signal_thread_handler; +#endif else if (sigismember(&deferrable_sigset, signal)) sa.sa_sigaction = maybe_now_maybe_later; else if (!sigaction_nodefer_works && @@ -1851,7 +1991,7 @@ install_handler(int signal, void handler(int, siginfo_t*, os_context_t*)) FSHOW((stderr, "/leaving POSIX install_handler(%d, ..)\n", signal)); - return (unsigned long)oldhandler.lisp; + return (uword_t)oldhandler.lisp; #else /* Probably-wrong Win32 hack */ return 0; @@ -1869,17 +2009,21 @@ sigabrt_handler(int signal, siginfo_t *info, os_context_t *context) void interrupt_init(void) { -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) int i; SHOW("entering interrupt_init()"); +#ifndef LISP_FEATURE_WIN32 see_if_sigaction_nodefer_works(); +#endif sigemptyset(&deferrable_sigset); sigemptyset(&blockable_sigset); sigemptyset(&gc_sigset); sigaddset_deferrable(&deferrable_sigset); sigaddset_blockable(&blockable_sigset); sigaddset_gc(&gc_sigset); +#endif +#ifndef LISP_FEATURE_WIN32 /* Set up high level handler information. */ for (i = 0; i < NSIG; i++) { interrupt_handlers[i].c = @@ -1891,8 +2035,8 @@ interrupt_init(void) (void (*)(int, siginfo_t*, os_context_t*))SIG_DFL; } undoably_install_low_level_interrupt_handler(SIGABRT, sigabrt_handler); - SHOW("returning from interrupt_init()"); #endif + SHOW("returning from interrupt_init()"); } #ifndef LISP_FEATURE_WIN32 @@ -1941,7 +2085,7 @@ unhandled_trap_error(os_context_t *context) unblock_gc_signals(0, 0); #endif context_sap = alloc_sap(context); -#ifndef LISP_FEATURE_WIN32 +#if !defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_THREAD) thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); #endif funcall1(StaticSymbolFunction(UNHANDLED_TRAP_ERROR), context_sap); @@ -1955,11 +2099,13 @@ void handle_trap(os_context_t *context, int trap) { switch(trap) { +#if !(defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD)) case trap_PendingInterrupt: FSHOW((stderr, "/\n")); arch_skip_instruction(context); interrupt_handle_pending(context); break; +#endif case trap_Error: case trap_Cerror: FSHOW((stderr, "/\n", trap)); @@ -1982,7 +2128,7 @@ handle_trap(os_context_t *context, int trap) arch_handle_single_step_trap(context, trap); break; #endif -#ifdef LISP_FEATURE_SB_SAFEPOINT +#ifdef trap_GlobalSafepoint case trap_GlobalSafepoint: fake_foreign_function_call(context); thread_in_lisp_raised(context); @@ -1996,6 +2142,12 @@ handle_trap(os_context_t *context, int trap) arch_skip_instruction(context); break; #endif +#if defined(LISP_FEATURE_SPARC) && defined(LISP_FEATURE_GENCGC) + case trap_Allocation: + arch_handle_allocation_trap(context); + arch_skip_instruction(context); + break; +#endif case trap_Halt: fake_foreign_function_call(context); lose("%%PRIMITIVE HALT called; the party is over.\n");