common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

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

Browse source 
Some people will complain if we don't do this at least for safety 3.
This commit is contained in:
Douglas Katzman 2026-08-04 03:14:55 +00:00
parent 8b4b67101a
commit 503f9b8a34
2 changed files with 40 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
src/compiler/ir1opt.lisp
View file

@ -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.

32
tests/lcse.pure.lisp
View file

@ -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))))