master: Return NIL from ok-to-flush for potentially trapping special refs

The branch "master" has been updated in SBCL:
       via  503f9b8a34f1d3c4787b4ca4055a6ef66fd2bb1c (commit)
      from  8b4b67101ac8218e3a072dcb06262c2ab593db80 (commit)

- Log -----------------------------------------------------------------
commit 503f9b8a34f1d3c4787b4ca4055a6ef66fd2bb1c
Author: Douglas Katzman <[email protected]>
Date:   Tue Aug 4 03:14:55 2026 +0000

    Return NIL from ok-to-flush for potentially trapping special refs
    
    Some people will complain if we don't do this at least for safety 3.
---
 src/compiler/ir1opt.lisp |  8 ++++++++
 tests/lcse.pure.lisp     | 32 ++++++++++++++++++++++++++++++++
 2 files changed, 40 insertions(+)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index d9ada3778..286b98f9e 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1350,6 +1350,14 @@
                (cond ((set-p node) (not (member (set-var node) vars)))
                      ((combination-p node) (flushable-combination-p node))
                      ((basic-combination-p node) nil)
+                     ((ref-p node)
+                      (let ((leaf (ref-leaf node)))
+                        (if (and (global-var-p leaf)
+                                 (member (global-var-kind leaf) '(:special :global))
+                                 (not (always-boundp (leaf-source-name leaf) node))
+                                 (policy node (= safety 3)))
+                            nil
+                            t)))
                      (t t)))) ; anything else the backwards search allowed is ok
       ;; When lookback>0 it's possible for the equivalent node to be the final node
       ;; of its block, in which case its NODE-NEXT is null.
diff --git a/tests/lcse.pure.lisp b/tests/lcse.pure.lisp
index 43b34e998..1bae6e35f 100644
--- a/tests/lcse.pure.lisp
+++ b/tests/lcse.pure.lisp
@@ -232,3 +232,35 @@
     (if (car cons)
         (princ (cdr cons))
         nil)))
+
+(defvar *a*)
+(defvar *b*)
+
+(macrolet ((guts-of-g ()
+             '(let ((x 0))
+                (opaque-identity x)
+                (opaque-identity (incf x (random 2)))
+                (let ((a *a*))
+                  (list (car a) *b* (car a))))))
+(defun g-regular () (guts-of-g))
+(defun g-safe ()
+  (declare (optimize safety))
+  ;; Don't treat (CAR A) as a common subexpression if the ref of *B*
+  ;; could perform memory stores.
+  (guts-of-g)))
+(compile 'g-regular)
+(compile 'g-safe)
+
+(defun try-trapping-ref (safep)
+  (setf *a* (cons 5 'foo))
+  (handler-bind ((cell-error
+                  (lambda (c)
+                    (declare (ignore c))
+                    (setf (car *a*) -1)
+                    (use-value 32))))
+    (if safep (g-safe) (g-regular))))
+
+(with-test (:name :test-trapping-ref)
+  (assert (equal (try-trapping-ref nil) '(5 32 5))))
+(with-test (:name :test-trapping-ref-safe)
+  (assert (equal (try-trapping-ref t) '(5 32 -1))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL