From adc39015302751dbd18f02166f5ae605a9d3bbfb Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Thu, 20 Aug 2026 12:31:45 +0200 Subject: [PATCH 1/6] Poll interrupts on bytecode backward branches so loops stay cancellable MP:PROCESS-KILL cannot stop a loop whose body compiles to pure opcodes. The VM polls queued interrupts only on function entry, in bytecode_call, so a loop that calls nothing never reaches a safepoint and no interrupt is ever delivered to it. (LOOP), (LOOP UNTIL *FLAG*), (LOOP FOR I FROM 0), (LOOP (SETQ X (1+ X))) and (DO ((I 0 (1+ I))) (NIL)) all survive PROCESS-KILL and run until the image exits. A loop containing any call, and a thread blocked in SLEEP, were always killable; this is specifically the call-free case. That defect blocks any deadline or timeout facility built on cancellation, since the one workload a timeout most needs to interrupt -- a spinning thread -- is the one that cannot be interrupted. Note that the return value never indicated this. MP:PROCESS-KILL and MP:PROCESS-CANCEL are both (MP:INTERRUPT process 'MP:CANCELLATION-INTERRUPT) and the C++ entry point is void, so they answer NIL whether or not the target dies. MP:PROCESS-ACTIVE-P is the only way to tell. This polls on backward branches, which is where a loop must pass regardless of its body. All eight jump sites route through one helper rather than repeating the test; a forward branch pays only a predictable rel < 0 comparison. Two details matter for correctness and cost: The handler can cons or unwind, so vm._pc and vm._stackPointer are synced before polling -- the GC scans the bytecode stack up to _stackPointer. The fast path tests the pending-interrupt state through the ThreadLocalState pointer the VM already caches per frame, not through my_thread. On Darwin every my_thread access is a _tlv_get_addr thunk, which per loop iteration would cost far more than the poll itself. It also cannot use interrupt_queue_validp(): the queue keeps a dummy head node so it is never empty, and that predicate is true whenever the queue exists. The real test is that the head's cdr is non-nil. Cost, measured against the same source revision without this patch, alternating runs, on a loop whose entire body is one opcode: about 1-2%, and in one of three rounds the patched build was faster. Regression suite 2014 -> 2017, the three new tests, no other change. --- src/core/bytecode.cc | 32 +++++++++++++++++++++++-------- src/lisp/regression-tests/mp.lisp | 22 +++++++++++++++++++++ 2 files changed, 46 insertions(+), 8 deletions(-) diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc index 2b4cc0649d..4a50e487dd 100644 --- a/src/core/bytecode.cc +++ b/src/core/bytecode.cc @@ -217,6 +217,22 @@ static unsigned char* long_dispatch(VirtualMachine&, unsigned char*, MultipleVal core::T_O**, core::T_O**, size_t, core::T_O**, uint8_t); SYMBOL_EXPORT_SC_(KeywordPkg, name); + +// Poll interrupts on backward branches so loops of pure opcodes stay cancellable. +static inline unsigned char* vm_branch(VirtualMachine& vm, ThreadLocalState* thread, unsigned char* pc, core::T_O** sp, + int32_t rel) { + pc += rel; + if (rel < 0) { + core::Cons_sp head = thread->_PendingInterruptsHead.load(std::memory_order_acquire); + if (thread->pending_signals_p() || (static_cast(head) && head->cdr().notnilp())) { + // The handler can cons or unwind, so the GC must see the current frame. + vm._pc = pc; + vm._stackPointer = sp; + gctools::handle_all_queued_interrupts(); + } + } + return pc; +} #ifdef DEBUG_VIRTUAL_MACHINE __attribute__((optnone)) #endif @@ -564,19 +580,19 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure case vm_code::jump_8: { int8_t rel = *(pc + 1); DBG_VM1("jump %" PRId8 "\n", rel); - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); break; } case vm_code::jump_16: { int16_t rel = read_s16(pc + 1); DBG_VM("jump %" PRId16 "\n", rel); - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); break; } case vm_code::jump_24: { int32_t rel = read_label(pc, 3); DBG_VM("jump %" PRId32 "\n", rel); - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); break; } case vm_code::jump_if_8: { @@ -585,7 +601,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure T_sp tval((gctools::Tagged)vm.pop(sp)); VM_RECORD_PLAYBACK(tval.raw_(), "vm_jump_if_8"); if (tval.notnilp()) - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); else pc += 2; break; @@ -595,7 +611,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure DBG_VM("jump-if %" PRId16 "\n", rel); T_sp tval((gctools::Tagged)vm.pop(sp)); if (tval.notnilp()) - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); else pc += 3; break; @@ -605,7 +621,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure DBG_VM("jump-if %" PRId32 "\n", rel); T_sp tval((gctools::Tagged)vm.pop(sp)); if (tval.notnilp()) - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); else pc += 4; break; @@ -618,7 +634,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc += 2; } else { vm.push(sp, tval.raw_()); - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); } break; } @@ -630,7 +646,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc += 3; } else { vm.push(sp, tval.raw_()); - pc += rel; + pc = vm_branch(vm, thread, pc, sp, rel); } break; } diff --git a/src/lisp/regression-tests/mp.lisp b/src/lisp/regression-tests/mp.lisp index baf8b26c03..927a451570 100644 --- a/src/lisp/regression-tests/mp.lisp +++ b/src/lisp/regression-tests/mp.lisp @@ -253,3 +253,25 @@ (spam-processes nthreads (lambda () (mp:atomic-push nil (car place)))) (car place)) ((nil nil nil nil nil nil nil))) + +;;; Returns true if THUNK's process is gone within SECONDS of being killed. +(defun cancelled-within-p (thunk seconds) + (let ((p (mp:process-run-function nil thunk))) + (loop repeat 200 until (mp:process-active-p p) do (sleep 0.01)) + (mp:process-kill p) + (loop repeat (ceiling seconds 0.01) + while (mp:process-active-p p) + do (sleep 0.01)) + (not (mp:process-active-p p)))) + +;;; A loop body of pure VM opcodes reaches no function-call safepoint, so it is +;;; cancellable only if the interpreter polls interrupts on backward branches. +(test-true cancel-opcode-only-loop + (cancelled-within-p (lambda () (loop)) 3)) + +(test-true cancel-arithmetic-loop + (cancelled-within-p (lambda () (let ((x 0)) (loop (setq x (1+ x))))) 3)) + +;;; Control: a loop that calls a function was always cancellable. +(test-true cancel-loop-with-call + (cancelled-within-p (lambda () (loop (funcall #'identity 1))) 3)) From ad3c3aaa08c838ebf6e27175a89bcb9e5b61fead Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Thu, 20 Aug 2026 13:30:38 +0200 Subject: [PATCH 2/6] Sample back edges in native code so native loops are cancellable too The bytecode VM now polls interrupts on backward branches, but native code reached a safepoint only at function entry, in the XEP before the tail call. A natively compiled loop whose body calls nothing therefore still could not be cancelled: PROCESS-KILL on (COMPILE NIL '(LAMBDA () (LOOP))) had no effect, with the function confirmed to be a SIMPLE-CORE-FUN rather than bytecode. BIR has no loop or dominance analysis, but its iblocks are laid out in forward flow order, so a branch to an already-laid-out iblock is a back edge -- the same test the VM makes with a negative jump offset. TRANSLATE-TERMINATOR's :AROUND method is the one place covering JUMP, IFI and CASE. Polling every back edge is not affordable. cc_safepoint is an out-of-line call declared PRIMITIVE-UNWINDS, so LLVM must treat it as possibly-throwing and cannot hoist loop-invariant work or keep values in registers across it; on a loop whose body is a single increment that costs about 3x. It cannot be declared non-throwing, since the handler really can unwind, and cleavir/primitives.lisp warns against exactly that change. So this samples. A counter in the function's alloca block is incremented at each back edge and the call is made once every 256, leaving cancellation latency at most 255 iterations -- submicrosecond -- for an add, a mask and a predictable branch per iteration. Measured over nine alternating runs against the same source revision without this patch: about 8% on that worst case, down from 3x. Loops doing more per iteration pay proportionally less, and loops containing a call were always cancellable. The residual 8% is the inline counter rather than the call, so raising the sample interval will not help much. Two options not taken: read a global pending-interrupt flag instead of counting, which requires an atomic load so LLVM cannot hoist it out of the loop; or instrument only call-free loops, which would make almost all real code pay nothing. The new test is vacuous where no native compiler exists; it asserts SIMPLE-CORE-FUN so it cannot pass by silently testing bytecode. Regression suite 2017 -> 2018, the one new test. --- src/lisp/kernel/cleavir/translate.lisp | 51 +++++++++++++++++++++++--- src/lisp/regression-tests/mp.lisp | 11 ++++++ 2 files changed, 57 insertions(+), 5 deletions(-) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index bc0f7d658d..a7af3132ff 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -255,12 +255,44 @@ function-or-placeholder - the llvm function or a placeholder for (inst-source instruction) 999902)) (call-next-method))) +(defvar *laid-out-iblocks*) +(defvar *safepoint-counter* nil) + +;; Iblocks are laid out in forward flow order, so a branch to one already laid +;; out is a back edge - the native counterpart of the VM's negative jump offset. +(defun back-edge-p (instruction) + (and (boundp '*laid-out-iblocks*) + (loop for succ in (bir:next instruction) + thereis (gethash succ *laid-out-iblocks*)))) + +;; cc_safepoint is an out-of-line unwinding call, so polling every back edge +;; costs ~3x on a tight loop; sample one edge in +safepoint-sample+ instead. +(defparameter +safepoint-sample+ 255) + +(defun emit-back-edge-safepoint () + (let* ((n (cmp:irc-typed-load cmp:%size_t% *safepoint-counter*)) + (n1 (cmp:irc-add n (cmp:jit-constant-size_t 1))) + (poll (cmp:irc-basic-block-create "safepoint-poll")) + (cont (cmp:irc-basic-block-create "safepoint-cont"))) + (cmp:irc-store n1 *safepoint-counter*) + (cmp:irc-cond-br (cmp:irc-icmp-eq + (cmp:irc-and n1 (cmp:jit-constant-size_t +safepoint-sample+)) + (cmp:jit-constant-size_t 0)) + poll cont) + (cmp:irc-begin-block poll) + (%intrinsic-invoke-if-landing-pad-or-call "cc_safepoint" ()) + (cmp:irc-br cont) + (cmp:irc-begin-block cont))) + (defmethod translate-terminator :around ((instruction bir:instruction) abi next) (declare (ignore abi next)) (cmp:with-debug-info-source-position ((ensure-origin (inst-source instruction) 999903)) + ;; Poll interrupts on back edges so native loops stay cancellable. + (when (and *safepoint-counter* (back-edge-p instruction)) + (emit-back-edge-safepoint)) (call-next-method))) (defmethod translate-terminator ((instruction bir:unreachable) @@ -1876,6 +1908,8 @@ function-or-placeholder - the llvm function or a placeholder for do (setf (gethash phi *datum-values*) dat)))))) (defun layout-iblock (iblock abi) + (when (boundp '*laid-out-iblocks*) + (setf (gethash iblock *laid-out-iblocks*) t)) (cmp:irc-begin-block (iblock-tag iblock)) (cmp:with-landing-pad (maybe-entry-landing-pad (bir:dynamic-environment iblock) *tags*) @@ -1991,11 +2025,18 @@ function-or-placeholder - the llvm function or a placeholder for (arguments llvm-function-info)) when lexical ; skip unused fixed do (setf (gethash lexical *datum-values*) arg))) - ;; Branch to the start block. - (cmp:irc-br (iblock-tag (bir:start ir))) - ;; Lay out blocks. - (bir:do-iblocks (ib ir) - (layout-iblock ib abi)))))) + ;; Counter for sampled back-edge safepoints; must live in the alloca block. + (let ((*safepoint-counter* + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (let ((c (cmp:alloca-size_t "safepoint-counter"))) + (cmp:irc-store (cmp:jit-constant-size_t 0) c) + c))) + (*laid-out-iblocks* (make-hash-table :test #'eq))) + ;; Branch to the start block. + (cmp:irc-br (iblock-tag (bir:start ir))) + ;; Lay out blocks. + (bir:do-iblocks (ib ir) + (layout-iblock ib abi))))))) ;; Finish up by jumping from the entry block to the body block (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) (cmp:irc-br body-block)) diff --git a/src/lisp/regression-tests/mp.lisp b/src/lisp/regression-tests/mp.lisp index 927a451570..8f7f9f947c 100644 --- a/src/lisp/regression-tests/mp.lisp +++ b/src/lisp/regression-tests/mp.lisp @@ -275,3 +275,14 @@ ;;; Control: a loop that calls a function was always cancellable. (test-true cancel-loop-with-call (cancelled-within-p (lambda () (loop (funcall #'identity 1))) 3)) + +;;; Native code reaches its own safepoints, so the VM's back-edge poll does not +;;; cover it. Asserts SIMPLE-CORE-FUN so it cannot pass by testing bytecode; +;;; vacuous where no native compiler exists. +(test-true cancel-native-opcode-only-loop + (let ((f (ignore-errors + (let ((cmp:*compile-native* t)) + (compile nil '(lambda () (loop))))))) + (if (typep f 'core:simple-core-fun) + (cancelled-within-p f 3) + t))) From 22417fc71ae7b0e0ba556a4efc547ed42a72e408 Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Thu, 20 Aug 2026 13:30:58 +0200 Subject: [PATCH 3/6] Add MP:WITH-TIMEOUT, a deadline facility built on cancellation Clasp had no way to bound the running time of a form. The only timeout primitive in MP was CONDITION-VARIABLE-TIMEDWAIT, which bounds one wait rather than an arbitrary body, so every timeout-dependent test had to be written without one. WITH-TIMEOUT runs BODY and signals TIMEOUT in the calling process if it has not finished within SECONDS. The deadline is delivered as an interrupt, so it lands at the next safepoint and inherits exactly the coverage interrupts have. That is why this could not usefully exist until loops polled on back edges: the workload a timeout most needs to interrupt is a spinning thread, and that was the one workload no interrupt could reach. The watchdog waits on a condition variable rather than sleeping, so a body that finishes early wakes it immediately instead of stranding a thread for the full duration; (WITH-TIMEOUT (3600) ...) must not hold a thread for an hour. The wait is a deadline loop because CONDITION-VARIABLE-TIMEDWAIT may return early, and a single unguarded wait would produce spurious timeouts. Both threads touch the completion flag only under the lock. TIMEOUT is a subtype of ERROR rather than SERIOUS-CONDITION, where SBCL and bordeaux-threads put theirs. A condition that slips through HANDLER-CASE on ERROR and IGNORE-ERRORS is a footgun, and a timeout does mean the operation failed. This is a deliberate deviation. Regression suite 2018 -> 2021: the body completes, the body times out, and the timeout does not fire late after the body has already returned. --- src/lisp/kernel/lsp/mp-package.lisp | 2 ++ src/lisp/kernel/lsp/mp.lisp | 46 +++++++++++++++++++++++++++++ src/lisp/regression-tests/mp.lisp | 16 ++++++++++ 3 files changed, 64 insertions(+) diff --git a/src/lisp/kernel/lsp/mp-package.lisp b/src/lisp/kernel/lsp/mp-package.lisp index 70e9c24f37..7f703642e6 100644 --- a/src/lisp/kernel/lsp/mp-package.lisp +++ b/src/lisp/kernel/lsp/mp-package.lisp @@ -21,5 +21,7 @@ signal-pending-interrupts raise without-interrupts with-interrupts with-local-interrupts with-restored-interrupts allow-with-interrupts interruptiblep + ;; deadlines + timeout timeout-seconds with-timeout call-with-timeout )) ) ; eval-when diff --git a/src/lisp/kernel/lsp/mp.lisp b/src/lisp/kernel/lsp/mp.lisp index ea45cc08eb..369027c478 100644 --- a/src/lisp/kernel/lsp/mp.lisp +++ b/src/lisp/kernel/lsp/mp.lisp @@ -158,3 +158,49 @@ If DATUM is provided, it and ARGUMENTS designate a condition of default type SIM (if datum (core::coerce-to-condition datum arguments 'simple-error 'abort-process) nil))) + +#+threads +;; A subtype of ERROR, not just SERIOUS-CONDITION, so HANDLER-CASE on ERROR and +;; IGNORE-ERRORS catch it; SBCL and bordeaux-threads use SERIOUS-CONDITION. +(define-condition timeout (error) + ((%seconds :initarg :seconds :reader timeout-seconds)) + (:report (lambda (condition stream) + (format stream "Timed out after ~a second~:p." + (timeout-seconds condition))))) + +#+threads +(defun call-with-timeout (seconds function) + "Call FUNCTION, signalling TIMEOUT in this process if it runs longer than SECONDS. +The timeout is delivered as an interrupt, so it lands at the next safepoint." + (let* ((lock (make-lock :name 'with-timeout)) + (cv (make-condition-variable :name 'with-timeout)) + (target *current-process*) + (deadline (+ (get-internal-real-time) + (round (* seconds internal-time-units-per-second)))) + (donep nil) + (watchdog + (process-run-function + 'with-timeout-watchdog + (lambda () + (with-lock (lock) + ;; Re-check DONEP because a timedwait may return early. + (loop until donep + for remaining = (/ (- deadline (get-internal-real-time)) + internal-time-units-per-second) + while (plusp remaining) + do (condition-variable-timedwait cv lock (float remaining 1d0))) + (unless donep + (interrupt-process + target + (lambda () (error 'timeout :seconds seconds))))))))) + (unwind-protect (funcall function) + (with-lock (lock) + (setf donep t) + (condition-variable-signal cv)) + (process-join watchdog)))) + +#+threads +(defmacro with-timeout ((seconds) &body body) + "Execute BODY, signalling MP:TIMEOUT in this process if it has not finished +within SECONDS." + `(call-with-timeout ,seconds (lambda () ,@body))) diff --git a/src/lisp/regression-tests/mp.lisp b/src/lisp/regression-tests/mp.lisp index 8f7f9f947c..50b1d26a77 100644 --- a/src/lisp/regression-tests/mp.lisp +++ b/src/lisp/regression-tests/mp.lisp @@ -286,3 +286,19 @@ (if (typep f 'core:simple-core-fun) (cancelled-within-p f 3) t))) + +;;; A body that finishes in time returns normally and signals nothing. +(test with-timeout-completes + (mp:with-timeout (30) (+ 1 2)) + (3)) + +;;; A spinning body is interrupted; this only works because loops now poll. +(test-expect-error with-timeout-fires + (mp:with-timeout (0.2) (loop)) + :type mp:timeout) + +;;; The timeout must not fire after the body has already returned. +(test-true with-timeout-no-late-fire + (progn (mp:with-timeout (0.2) t) + (sleep 0.5) + t)) From 567e14e30e77e14f3c9d4bd4ea3e036e884a01cd Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Thu, 20 Aug 2026 14:25:19 +0200 Subject: [PATCH 4/6] Park around blocking syscalls, and don't let a queued timeout outlive its body MP:WITH-TIMEOUT could not interrupt a body blocked in a foreign call. The deadline expired, the interrupt was queued, and nothing happened until the call returned on its own -- after which the interrupt was delivered with the caller's handler long gone, so TIMEOUT escaped to the debugger instead of unwinding the body. The wake-up machinery already existed and was correct. Process_O::interrupt does pthread_kill(SIGCONT) and handle_SIGCONT exists precisely to interrupt a thread blocked on a syscall. Both gate on ThreadLocalState::blockingp(), which is set by BEGIN_PARK -- and ext__system called system() without it, so the thread was never marked blocking and neither half engaged. Four Lisp-callable entry points blocked without parking: ext__system, core__wait, core__select, and the two wait() calls in the fork/exec paths. Each is also a garbage collection defect independent of interrupts, since a thread blocking outside a GC-safe region stalls stop-the-world for its whole duration -- (core:wait) with no child exiting stalls it indefinitely. clasp_musleep and ConditionVariable::wait were already correct and are the model. Measured on a five second system("sleep 5"): a 0.3s deadline now returns after 0.318s and a 1.0s deadline after 1.001s, where both previously took the full five seconds. Separately, CALL-WITH-TIMEOUT had a race that parking narrows but does not close: DONEP stopped the watchdog from sending a late interrupt, but nothing discarded one already sent. The interrupt thunk now re-checks DONEP at delivery, and if the deadline passed without the interrupt landing in time, the expiry is signalled on return -- inside the caller's dynamic extent, where handlers still exist. Regression suite 2021 -> 2024. WITH-TIMEOUT-FOREIGN-IS-PROMPT is the test that distinguishes a prompt wakeup from a late report; the earlier tests passed either way, which is how this hid. --- src/core/unixfsys.cc | 17 ++++++++++++----- src/lisp/kernel/lsp/mp.lisp | 24 +++++++++++++++++------- src/lisp/regression-tests/mp.lisp | 24 +++++++++++++++++++++++- 3 files changed, 52 insertions(+), 13 deletions(-) diff --git a/src/core/unixfsys.cc b/src/core/unixfsys.cc index 3b05d316a9..ec0bc00cb6 100644 --- a/src/core/unixfsys.cc +++ b/src/core/unixfsys.cc @@ -37,6 +37,7 @@ THE SOFTWARE. */ #include +#include #include #include @@ -294,7 +295,8 @@ The status can be passed to //core:wifexited// and //core:wifsignaled//. )") DOCGROUP(clasp); CL_DEFUN T_mv core__wait() { int status; - pid_t p = wait(&status); + // Park: wait() blocks until a child exits, which may be never. + pid_t p = BEGIN_PARK { return wait(&status); } END_PARK; return Values(make_fixnum(p), make_fixnum(status)); }; @@ -1707,7 +1709,9 @@ DOCGROUP(clasp); CL_DEFUN T_mv ext__system(String_sp cmd) { ASSERT(cl__stringp(cmd)); string command = cmd->get_std_string(); - int ret = system(command.c_str()); + // Park: system() blocks for an unbounded time, so the thread must be GC-safe + // and marked blocking, which is what lets an interrupt wake it with SIGCONT. + int ret = BEGIN_PARK { return system(command.c_str()); } END_PARK; if (ret == 0) { return Values(core::make_fixnum(0)); } else { @@ -1828,7 +1832,7 @@ CL_DEFUN T_mv ext__vfork_execvp(List_sp call_and_arguments, T_sp return_stream) while (b_done == false) { errno = 0; - wait_ret = wait(&status); + wait_ret = BEGIN_PARK { return wait(&status); } END_PARK; if (WIFEXITED(status)) { child_exit_status = WEXITSTATUS(status); @@ -1946,7 +1950,7 @@ CL_DEFUN T_mv ext__fork_execvp(List_sp call_and_arguments, T_sp return_stream) { } else { // Parent int status; - pid_t wait_ret = wait(&status); + pid_t wait_ret = BEGIN_PARK { return wait(&status); } END_PARK; // Clean up args for (int i(0); i < execvp_args.size() - 1; ++i) free((void*)execvp_args[i]); @@ -2003,7 +2007,10 @@ CL_DEFUN T_mv core__select(int nfds, FdSet_sp readfds, FdSet_sp writefds, FdSet_ struct timeval timeout; timeout.tv_sec = seconds; timeout.tv_usec = microseconds; - int num = select(nfds, &readfds->_fd_set, &writefds->_fd_set, &errorfds->_fd_set, &timeout); + // Park: select() blocks for up to the caller's timeout. + int num = BEGIN_PARK { + return select(nfds, &readfds->_fd_set, &writefds->_fd_set, &errorfds->_fd_set, &timeout); + } END_PARK; if (num < 0) { return Values(make_fixnum(num), make_fixnum(errno)); } diff --git a/src/lisp/kernel/lsp/mp.lisp b/src/lisp/kernel/lsp/mp.lisp index 369027c478..976fc3c41e 100644 --- a/src/lisp/kernel/lsp/mp.lisp +++ b/src/lisp/kernel/lsp/mp.lisp @@ -171,13 +171,17 @@ If DATUM is provided, it and ARGUMENTS designate a condition of default type SIM #+threads (defun call-with-timeout (seconds function) "Call FUNCTION, signalling TIMEOUT in this process if it runs longer than SECONDS. -The timeout is delivered as an interrupt, so it lands at the next safepoint." +The timeout is delivered as an interrupt, so it lands at the next safepoint. A body +blocked in a foreign call reaches no safepoint until the call returns, so there the +expiry is detected on return instead; either way TIMEOUT is signalled inside the +dynamic extent of the caller, where handlers are still established." (let* ((lock (make-lock :name 'with-timeout)) (cv (make-condition-variable :name 'with-timeout)) (target *current-process*) (deadline (+ (get-internal-real-time) (round (* seconds internal-time-units-per-second)))) (donep nil) + (firedp nil) (watchdog (process-run-function 'with-timeout-watchdog @@ -190,14 +194,20 @@ The timeout is delivered as an interrupt, so it lands at the next safepoint." while (plusp remaining) do (condition-variable-timedwait cv lock (float remaining 1d0))) (unless donep + (setf firedp t) (interrupt-process target - (lambda () (error 'timeout :seconds seconds))))))))) - (unwind-protect (funcall function) - (with-lock (lock) - (setf donep t) - (condition-variable-signal cv)) - (process-join watchdog)))) + ;; Re-check at delivery: an interrupt queued while the body was + ;; in a foreign call arrives after the body has already returned. + (lambda () (unless donep (error 'timeout :seconds seconds)))))))))) + (let ((values (unwind-protect (multiple-value-list (funcall function)) + (with-lock (lock) + (setf donep t) + (condition-variable-signal cv)) + (process-join watchdog)))) + ;; The deadline passed but the interrupt could not land in time. + (when firedp (error 'timeout :seconds seconds)) + (values-list values)))) #+threads (defmacro with-timeout ((seconds) &body body) diff --git a/src/lisp/regression-tests/mp.lisp b/src/lisp/regression-tests/mp.lisp index 50b1d26a77..7405d94715 100644 --- a/src/lisp/regression-tests/mp.lisp +++ b/src/lisp/regression-tests/mp.lisp @@ -297,8 +297,30 @@ (mp:with-timeout (0.2) (loop)) :type mp:timeout) -;;; The timeout must not fire after the body has already returned. +;;; The timeout must not fire after the body has already returned. An instant body +;;; never enqueues an interrupt, so this alone does not cover the race below. (test-true with-timeout-no-late-fire (progn (mp:with-timeout (0.2) t) (sleep 0.5) t)) + +;;; A blocking foreign call must park, so an interrupt can wake it with SIGCONT +;;; rather than sitting queued until the call returns on its own. +(test-expect-error with-timeout-blocking-foreign + (mp:with-timeout (0.5) (ext:system "sleep 3")) + :type mp:timeout) + +;;; ...and it must be woken PROMPTLY, not merely reported late on return. Three +;;; seconds of sleep must not elapse; without parking this takes the full 3s. +(test-true with-timeout-foreign-is-prompt + (let ((start (get-internal-real-time))) + (ignore-errors (mp:with-timeout (0.5) (ext:system "sleep 3"))) + (< (/ (- (get-internal-real-time) start) + internal-time-units-per-second) + 2.0))) + +;;; ...and the interrupt queued during that call must not fire afterwards. +(test-true with-timeout-foreign-no-late-fire + (progn (ignore-errors (mp:with-timeout (0.5) (ext:system "sleep 2"))) + (sleep 1) + t)) From ba652c834fc884fcb3e92b987c68032ebfd91e6f Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Thu, 20 Aug 2026 14:43:53 +0200 Subject: [PATCH 5/6] Park the serve-event selects and CORE:READ-FD Three more Lisp-callable entry points blocked without going GC-safe, so a thread in any of them could neither be woken by an interrupt nor let stop-the-world proceed. SERVE-EVENT-INTERNAL::LL-SERVE-EVENT-NO-TIMEOUT passes a NULL timeout to select, so it blocks indefinitely; the with-timeout variant blocks for as long as the caller asks. Both operate on fd_sets held in ForeignData, i.e. malloc'd memory, so parking around them raises no question about object lifetime. CORE:READ-FD blocks in read(2) until data arrives. It writes through a raw pointer into a SimpleBaseString, which is only safe to hold across a park because no collector here relocates -- NON_MOVING_GC in memoryManagement.h. If a moving plan is ever adopted this park needs the buffer pinned. The new test cancels a thread blocked reading an empty pipe, built from CORE:PIPE so it adds no external dependency. It is deliberately bounded rather than waiting on the read to return: an unbounded form would hang the suite instead of failing it, which is how a six hour CI timeout happens. Verified as a real discriminator rather than assumed: the same form answers NO on a build without these parks and YES with them. Regression suite 2024 -> 2025. --- src/core/lispStream.cc | 4 +++- src/lisp/regression-tests/mp.lisp | 10 ++++++++++ src/serveEvent/serveEvent.cc | 11 +++++++++-- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/src/core/lispStream.cc b/src/core/lispStream.cc index b35cb3a7c6..9113554630 100644 --- a/src/core/lispStream.cc +++ b/src/core/lispStream.cc @@ -1353,7 +1353,9 @@ CL_DEFUN T_mv core__read_fd(int filedes, SimpleBaseString_sp buffer) { size_t buffer_length = cl__length(buffer); unsigned char* buffer_data = &(*buffer)[0]; while (1) { - int num = read(filedes, buffer_data, buffer_length); + // Park: read() blocks until data arrives. Safe to hold BUFFER_DATA across it + // because no GC variant relocates (NON_MOVING_GC). + int num = BEGIN_PARK { return (int)read(filedes, buffer_data, buffer_length); } END_PARK; if (!(num < 0 && errno == EINTR)) { if (num < 0) { return Values(make_fixnum(num), make_fixnum(errno)); diff --git a/src/lisp/regression-tests/mp.lisp b/src/lisp/regression-tests/mp.lisp index 7405d94715..3868a46903 100644 --- a/src/lisp/regression-tests/mp.lisp +++ b/src/lisp/regression-tests/mp.lisp @@ -324,3 +324,13 @@ (progn (ignore-errors (mp:with-timeout (0.5) (ext:system "sleep 2"))) (sleep 1) t)) + +;;; A thread blocked in read(2) on an empty pipe must be cancellable. Without +;;; parking the thread is never marked blocking, so no SIGCONT is sent and it +;;; blocks forever. Bounded deliberately: an unbounded form would hang the whole +;;; suite rather than fail, which is how a 6-hour CI timeout happens. +(test-true cancel-blocking-read + (multiple-value-bind (r w) (core:pipe) + (declare (ignore w)) + (let ((buf (make-string 16 :element-type 'base-char))) + (cancelled-within-p (lambda () (core:read-fd r buf)) 3)))) diff --git a/src/serveEvent/serveEvent.cc b/src/serveEvent/serveEvent.cc index d7cab9e7da..12f8f2bcf5 100644 --- a/src/serveEvent/serveEvent.cc +++ b/src/serveEvent/serveEvent.cc @@ -26,6 +26,7 @@ THE SOFTWARE. /* -^- */ #include +#include #include #include #include @@ -55,7 +56,10 @@ CL_DEFUN int serve_event_internal__ll_fdset_size() { return sizeof(fd_set); } DOCGROUP(clasp); CL_DEFUN core::Integer_mv serve_event_internal__ll_serveEventNoTimeout(clasp_ffi::ForeignData_sp rfd, clasp_ffi::ForeignData_sp wfd, int maxfdp1) { - gc::Fixnum selectRet = select(maxfdp1, rfd->data(), wfd->data(), NULL, NULL); + // Park: a NULL timeout blocks indefinitely. The fd_sets are foreign memory. + gc::Fixnum selectRet = BEGIN_PARK { + return (gc::Fixnum)select(maxfdp1, rfd->data(), wfd->data(), NULL, NULL); + } END_PARK; return Values(Integer_O::create(selectRet), Integer_O::create((gc::Fixnum)errno)); } @@ -69,7 +73,10 @@ CL_DEFUN core::Integer_mv serve_event_internal__ll_serveEventWithTimeout(clasp_f struct timeval tv; tv.tv_sec = seconds; tv.tv_usec = ((seconds - floor(seconds)) * 1e6); - gc::Fixnum selectRet = select(maxfdp1, rfd->data(), wfd->data(), NULL, &tv); + // Park: blocks for up to the caller's timeout. + gc::Fixnum selectRet = BEGIN_PARK { + return (gc::Fixnum)select(maxfdp1, rfd->data(), wfd->data(), NULL, &tv); + } END_PARK; return Values(Integer_O::create(selectRet), Integer_O::create((gc::Fixnum)errno)); } From 271cb91d57a17f22c8edea69c3726addf23a98e3 Mon Sep 17 00:00:00 2001 From: dg1sbg Date: Thu, 20 Aug 2026 16:13:19 +0200 Subject: [PATCH 6/6] Park the socket accept, connect and select calls Five blocking entry points ran outside a GC-safe region: accept and connect for inet and local sockets, and the select in ll-socket-receive-timeout, which passes NULL when given no timeout and so blocks indefinitely. Sockets block by default here -- non-blocking mode is opt-in -- so socket flags do not save them. Each was both an interruptibility bug and a garbage collection bug: a thread in accept could not be cancelled, and stalled stop-the-world for as long as no connection arrived, which for a server socket is unbounded. All five act on stack-local sockaddr structs, or a ForeignData pointer for the select, so unlike CORE:READ-FD no pointer into the Lisp heap is held across the park. The test blocks a thread in accept on a local socket and cancels it, needing neither a port nor the network. It answered NO before these parks and YES after. CANCELLED-WITHIN-P now requires the process to still be running when it is killed. A thunk that dies on its own was previously indistinguishable from one that was cancelled, so a broken test could pass vacuously -- which one of mine briefly did. Regression suite 2025 -> 2026. --- src/lisp/regression-tests/mp.lisp | 33 +++++++++++++++++++++++++------ src/sockets/sockets.cc | 21 +++++++++++++++----- 2 files changed, 43 insertions(+), 11 deletions(-) diff --git a/src/lisp/regression-tests/mp.lisp b/src/lisp/regression-tests/mp.lisp index 3868a46903..daa07f4ac9 100644 --- a/src/lisp/regression-tests/mp.lisp +++ b/src/lisp/regression-tests/mp.lisp @@ -254,15 +254,20 @@ (car place)) ((nil nil nil nil nil nil nil))) -;;; Returns true if THUNK's process is gone within SECONDS of being killed. + +;;; Returns true if THUNK's process is gone within SECONDS of being killed. The +;;; process must still be running when it is killed: a thunk that dies on its own +;;; would otherwise look exactly like a cancelled one and pass vacuously. (defun cancelled-within-p (thunk seconds) (let ((p (mp:process-run-function nil thunk))) (loop repeat 200 until (mp:process-active-p p) do (sleep 0.01)) - (mp:process-kill p) - (loop repeat (ceiling seconds 0.01) - while (mp:process-active-p p) - do (sleep 0.01)) - (not (mp:process-active-p p)))) + (and (mp:process-active-p p) + (progn + (mp:process-kill p) + (loop repeat (ceiling seconds 0.01) + while (mp:process-active-p p) + do (sleep 0.01)) + (not (mp:process-active-p p)))))) ;;; A loop body of pure VM opcodes reaches no function-call safepoint, so it is ;;; cancellable only if the interpreter polls interrupts on backward branches. @@ -334,3 +339,19 @@ (declare (ignore w)) (let ((buf (make-string 16 :element-type 'base-char))) (cancelled-within-p (lambda () (core:read-fd r buf)) 3)))) + +;;; A thread blocked in accept(2) must be cancellable. A local socket is used so +;;; the test needs no port and no network. Verified to answer NO before the +;;; sockets were parked and YES after, so it is a real discriminator. +(test-true cancel-blocking-accept + (let* ((path (format nil "/tmp/clasp-accept-test-~a.sock" (get-universal-time))) + (sock (make-instance 'sb-bsd-sockets:local-socket :type :stream))) + (unwind-protect + (progn (sb-bsd-sockets:socket-bind sock path) + (sb-bsd-sockets:socket-listen sock 1) + (cancelled-within-p + (lambda () (sb-bsd-sockets:socket-accept sock)) 3)) + (ignore-errors (sb-bsd-sockets:socket-close sock)) + (ignore-errors (delete-file path))))) + + diff --git a/src/sockets/sockets.cc b/src/sockets/sockets.cc index 43bfdcf1b2..6c31b8b2d1 100644 --- a/src/sockets/sockets.cc +++ b/src/sockets/sockets.cc @@ -315,7 +315,8 @@ CL_DEFUN core::T_mv sockets_internal__ll_socketAccept_inetSocket(int sfd) { socklen_t addr_len = (socklen_t)sizeof(struct sockaddr_in); int new_fd; - new_fd = accept(sfd, (struct sockaddr*)&sockaddr, &addr_len); + // Park: accept() blocks until a connection arrives. + new_fd = BEGIN_PARK { return accept(sfd, (struct sockaddr*)&sockaddr, &addr_len); } END_PARK; int return0 = new_fd; core::T_sp return1 = nil(); @@ -343,7 +344,10 @@ CL_DEFUN int sockets_internal__ll_socketConnect_inetSocket(int port, int ip0, in struct sockaddr_in sockaddr; int output; fill_inet_sockaddr(&sockaddr, port, ip0, ip1, ip2, ip3); - output = connect(socket_file_descriptor, (struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in)); + // Park: connect() blocks for the handshake. + output = BEGIN_PARK { + return connect(socket_file_descriptor, (struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in)); + } END_PARK; return output; } @@ -512,7 +516,10 @@ DOCGROUP(clasp); CL_DEFUN core::T_mv sockets_internal__ll_socketAccept_localSocket(int socketFileDescriptor) { struct sockaddr_un sockaddr; socklen_t addr_len = (socklen_t)sizeof(struct sockaddr_un); - int new_fd = accept(socketFileDescriptor, (struct sockaddr*)&sockaddr, &addr_len); + // Park: accept() blocks until a connection arrives. + int new_fd = BEGIN_PARK { + return accept(socketFileDescriptor, (struct sockaddr*)&sockaddr, &addr_len); + } END_PARK; core::T_sp second_ret = nil(); if (new_fd != -1) { second_ret = core::SimpleBaseString_O::make(sockaddr.sun_path); @@ -534,7 +541,8 @@ CL_DEFUN int sockets_internal__ll_socketConnect_localSocket(int fd, int family, strncpy(sockaddr.sun_path, path.c_str(), sizeof(sockaddr.sun_path)); sockaddr.sun_path[sizeof(sockaddr.sun_path) - 1] = '\0'; - output = connect(fd, (struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un)); + // Park: connect() blocks for the handshake. + output = BEGIN_PARK { return connect(fd, (struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un)); } END_PARK; return output; } @@ -752,7 +760,10 @@ CL_DEFUN int sockets_internal__do_select(core::T_sp to_secs, unsigned int to_mus tv.tv_sec = to_secs.unsafe_fixnum(); tv.tv_usec = to_musecs; } - return select(max_fd + 1, (fd_set*)rfds->ptr(), NULL, NULL, (to_secs.fixnump()) ? &tv : NULL); + // Park: a non-fixnum timeout means NULL, i.e. block indefinitely. + return BEGIN_PARK { + return select(max_fd + 1, (fd_set*)rfds->ptr(), NULL, NULL, (to_secs.fixnump()) ? &tv : NULL); + } END_PARK; } void initialize_sockets_globals() {