0.7.7.35:

[sbcl.git] / src / compiler / ir1opt.lisp

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 5626039..98f4d9b 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -441,13 +441,25 @@
         (let ((info (combination-kind node)))
           (when (fun-info-p info)
             (let ((attr (fun-info-attributes info)))
-              (when (and (ir1-attributep attr flushable)
+              (when (and (not (ir1-attributep attr call))
                          ;; ### For now, don't delete potentially
                          ;; flushable calls when they have the CALL
                          ;; attribute. Someday we should look at the
                          ;; functional args to determine if they have
                          ;; any side effects.
-                         (not (ir1-attributep attr call)))
+                          (if (policy node (= safety 3))
+                              (and (ir1-attributep attr flushable)
+                                   (every (lambda (arg)
+                                            (member (continuation-type-check arg)
+                                                    '(nil :deleted)))
+                                          (basic-combination-args node))
+                                   (valid-fun-use node
+                                                  (info :function :type
+                                                        (leaf-source-name (ref-leaf (continuation-use (basic-combination-fun node)))))
+                                                  :result-test #'always-subtypep
+                                                  :lossage-fun nil
+                                                  :unwinnage-fun nil))
+                              (ir1-attributep attr unsafely-flushable)))
                 (flush-dest (combination-fun node))
                 (dolist (arg (combination-args node))
                   (flush-dest arg))
@@ -935,31 +947,31 @@
                 (continuation-use (basic-combination-fun call))
                 call))
               ((not leaf))
-              ((or (info :function :source-transform (leaf-source-name leaf))
-                   (and info
-                        (ir1-attributep (fun-info-attributes info)
-                                        predicate)
-                        (let ((dest (continuation-dest (node-cont call))))
-                          (and dest (not (if-p dest))))))
-               (when (and (leaf-has-source-name-p leaf)
-                          ;; FIXME: This SYMBOLP is part of a literal
-                          ;; translation of a test in the old CMU CL
-                          ;; source, and it's not quite clear what
-                          ;; the old source meant. Did it mean "has a
-                          ;; valid name"? Or did it mean "is an
-                          ;; ordinary function name, not a SETF
-                          ;; function"? Either way, the old CMU CL
-                          ;; code probably didn't deal with SETF
-                          ;; functions correctly, and neither does
-                          ;; this new SBCL code, and that should be fixed.
-                          (symbolp (leaf-source-name leaf)))
-                 (let ((dummies (make-gensym-list (length
-                                                   (combination-args call)))))
-                   (transform-call call
-                                   `(lambda ,dummies
-                                      (,(leaf-source-name leaf)
-                                       ,@dummies))
-                                   (leaf-source-name leaf))))))))))
+              ((and (leaf-has-source-name-p leaf)
+                     (or (info :function :source-transform (leaf-source-name leaf))
+                         (and info
+                              (ir1-attributep (fun-info-attributes info)
+                                              predicate)
+                              (let ((dest (continuation-dest (node-cont call))))
+                                (and dest (not (if-p dest)))))))
+                ;; FIXME: This SYMBOLP is part of a literal
+                ;; translation of a test in the old CMU CL
+                ;; source, and it's not quite clear what
+                ;; the old source meant. Did it mean "has a
+                ;; valid name"? Or did it mean "is an
+                ;; ordinary function name, not a SETF
+                ;; function"? Either way, the old CMU CL
+                ;; code probably didn't deal with SETF
+                ;; functions correctly, and neither does
+                ;; this new SBCL code, and that should be fixed.
+               (when (symbolp (leaf-source-name leaf))
+                  (let ((dummies (make-gensym-list
+                                  (length (combination-args call)))))
+                    (transform-call call
+                                    `(lambda ,dummies
+                                      (,(leaf-source-name leaf)
+                                       ,@dummies))
+                                    (leaf-source-name leaf))))))))))
   (values))
 \f
 ;;;; known function optimization
@@ -1228,7 +1240,7 @@
   (derive-node-type node (continuation-type (set-value node)))
   (values))
 
-;;; Return true if the value of Ref will always be the same (and is
+;;; Return true if the value of REF will always be the same (and is
 ;;; thus legal to substitute.)
 (defun constant-reference-p (ref)
   (declare (type ref ref))