X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=5d74523af8a4ada18b832eff22d42fefa6b2e1c3;hb=fae139755a81c0431e7f12f2af9b5f3abc1326dc;hp=5929a328ee877f4b372f2dbb3a3ba8e96407c1ac;hpb=2ad51f7553081cce0924ace6b215c01ff9f075eb;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 5929a32..5d74523 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -80,7 +80,7 @@
 ;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
 ;;; be given a new use.
 (defun %delete-lvar-use (node)
-  (let* ((lvar (node-lvar node)))
+  (let ((lvar (node-lvar node)))
     (when lvar
       (if (listp (lvar-uses lvar))
           (let ((new-uses (delq node (lvar-uses lvar))))
@@ -164,17 +164,27 @@
   (values))
 
 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
-;;; arbitary number of uses.
-(defun substitute-lvar-uses (new old)
+;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
+(defun substitute-lvar-uses (new old propagate-dx)
   (declare (type lvar old)
-           (type (or lvar null) new))
-
-  (do-uses (node old)
-    (%delete-lvar-use node)
-    (when new
-      (add-lvar-use node new)))
+           (type (or lvar null) new)
+           (type boolean propagate-dx))
+
+  (cond (new
+         (do-uses (node old)
+           (%delete-lvar-use node)
+           (add-lvar-use node new))
+         (reoptimize-lvar new)
+         (awhen (and propagate-dx (lvar-dynamic-extent old))
+           (setf (lvar-dynamic-extent old) nil)
+           (unless (lvar-dynamic-extent new)
+             (setf (lvar-dynamic-extent new) it)
+             (setf (cleanup-info it) (substitute new old (cleanup-info it)))))
+         (when (lvar-dynamic-extent new)
+           (do-uses (node new)
+             (node-ends-block node))))
+        (t (flush-dest old)))
 
-  (when new (reoptimize-lvar new))
   (values))
 
 ;;;; block starting/creation
@@ -221,6 +231,25 @@
       ((:inside-block)
        (node-ends-block (ctran-use ctran)))))
   (values))
+
+;;; CTRAN must be the last ctran in an incomplete block; finish the
+;;; block and start a new one if necessary.
+(defun start-block (ctran)
+  (declare (type ctran ctran))
+  (aver (not (ctran-next ctran)))
+  (ecase (ctran-kind ctran)
+    (:inside-block
+     (let ((block (ctran-block ctran))
+           (node (ctran-use ctran)))
+       (aver (not (block-last block)))
+       (aver node)
+       (setf (block-last block) node)
+       (setf (node-next node) nil)
+       (setf (ctran-use ctran) nil)
+       (setf (ctran-kind ctran) :unused)
+       (setf (ctran-block ctran) nil)
+       (link-blocks block (ctran-starts-block ctran))))
+    (:block-start)))
 
 ;;;;
 
@@ -287,14 +316,35 @@
                     (when (and (basic-combination-p use)
                                (eq (basic-combination-kind use) :local))
                       (merges use))))
+                (substitute-lvar-uses lvar value
+                                      (and lvar (eq (lvar-uses lvar) node)))
                 (%delete-lvar-use node)
-                (substitute-lvar-uses lvar value)
                 (prog1
                     (unlink-node node)
                   (dolist (merge (merges))
                     (merge-tail-sets merge)))))
         (t (flush-dest value)
            (unlink-node node))))
+
+;;; Make a CAST and insert it into IR1 before node NEXT.
+(defun insert-cast-before (next lvar type policy)
+  (declare (type node next) (type lvar lvar) (type ctype type))
+  (with-ir1-environment-from-node next
+    (let* ((ctran (node-prev next))
+           (cast (make-cast lvar type policy))
+           (internal-ctran (make-ctran)))
+      (setf (ctran-next ctran) cast
+            (node-prev cast) ctran)
+      (use-ctran cast internal-ctran)
+      (link-node-to-previous-ctran next internal-ctran)
+      (setf (lvar-dest lvar) cast)
+      (reoptimize-lvar lvar)
+      (when (return-p next)
+        (node-ends-block cast))
+      (setf (block-attributep (block-flags (node-block cast))
+                              type-check type-asserted)
+            t)
+      cast)))
 
 ;;;; miscellaneous shorthand functions
 
@@ -306,7 +356,7 @@
   (declare (type node node))
   (do ((fun (lexenv-lambda (node-lexenv node))
 	    (lexenv-lambda (lambda-call-lexenv fun))))
-      ((not (eq (functional-kind fun) :deleted))
+      ((not (memq (functional-kind fun) '(:deleted :zombie)))
        (lambda-home fun))
     (when (eq (lambda-home fun) fun)
       (return fun))))
@@ -324,12 +374,20 @@
 (defun node-dest (node)
   (awhen (node-lvar node) (lvar-dest it)))
 
+#!-sb-fluid (declaim (inline node-stack-allocate-p))
+(defun node-stack-allocate-p (node)
+  (awhen (node-lvar node)
+    (lvar-dynamic-extent it)))
+
+(declaim (inline block-to-be-deleted-p))
+(defun block-to-be-deleted-p (block)
+  (or (block-delete-p block)
+      (eq (functional-kind (block-home-lambda block)) :deleted)))
+
 ;;; Checks whether NODE is in a block to be deleted
 (declaim (inline node-to-be-deleted-p))
 (defun node-to-be-deleted-p (node)
-  (let ((block (node-block node)))
-    (or (block-delete-p block)
-        (eq (functional-kind (block-home-lambda block)) :deleted))))
+  (block-to-be-deleted-p (node-block node)))
 
 (declaim (ftype (sfunction (clambda) cblock) lambda-block))
 (defun lambda-block (clambda)
@@ -473,6 +531,10 @@
 (defun ctran-home-lambda (ctran)
   (ctran-home-lambda-or-null ctran))
 
+(declaim (inline cast-single-value-p))
+(defun cast-single-value-p (cast)
+  (not (values-type-p (cast-asserted-type cast))))
+
 #!-sb-fluid (declaim (inline lvar-single-value-p))
 (defun lvar-single-value-p (lvar)
   (or (not lvar)
@@ -485,7 +547,7 @@
           (cast
            (locally
                (declare (notinline lvar-single-value-p))
-             (and (not (values-type-p (cast-asserted-type dest)))
+             (and (cast-single-value-p dest)
                   (lvar-single-value-p (node-lvar dest)))))
           (t
            t)))))
@@ -513,6 +575,9 @@
                          type-restrictions
 			 (lambda (lexenv-lambda default))
 			 (cleanup (lexenv-cleanup default))
+		         (handled-conditions (lexenv-handled-conditions default))
+		         (disabled-package-locks 
+			  (lexenv-disabled-package-locks default))
 			 (policy (lexenv-policy default)))
   (macrolet ((frob (var slot)
 	       `(let ((old (,slot default)))
@@ -525,7 +590,8 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup policy)))
+     lambda cleanup handled-conditions 
+     disabled-package-locks policy)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
 ;;; macroexpander
@@ -554,6 +620,8 @@
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil
+     (lexenv-handled-conditions lexenv)
+     (lexenv-disabled-package-locks lexenv)
      (lexenv-policy lexenv))))
 
 ;;;; flow/DFO/component hackery
@@ -624,7 +692,7 @@
 	   (frob if-alternative)
            (when (eq (if-consequent last)
                      (if-alternative last))
-             (setf (component-reoptimize (block-component block)) t)))))
+             (reoptimize-component (block-component block) :maybe)))))
       (t
        (unless (memq new (block-succ block))
 	 (link-blocks block new)))))
@@ -656,6 +724,33 @@
     (setf (block-prev next) block))
   (values))
 
+;;; List all NLX-INFOs which BLOCK can exit to.
+;;;
+;;; We hope that no cleanup actions are performed in the middle of
+;;; BLOCK, so it is enough to look only at cleanups in the block
+;;; end. The tricky thing is a special cleanup block; all its nodes
+;;; have the same cleanup info, corresponding to the start, so the
+;;; same approach returns safe result.
+(defun map-block-nlxes (fun block &optional dx-cleanup-fun)
+  (loop for cleanup = (block-end-cleanup block)
+        then (node-enclosing-cleanup (cleanup-mess-up cleanup))
+        while cleanup
+        do (let ((mess-up (cleanup-mess-up cleanup)))
+             (case (cleanup-kind cleanup)
+               ((:block :tagbody)
+                (aver (entry-p mess-up))
+                (loop for exit in (entry-exits mess-up)
+                      for nlx-info = (find-nlx-info exit)
+                      do (funcall fun nlx-info)))
+               ((:catch :unwind-protect)
+                (aver (combination-p mess-up))
+                (let* ((arg-lvar (first (basic-combination-args mess-up)))
+                       (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
+                (funcall fun nlx-info)))
+               ((:dynamic-extent)
+                (when dx-cleanup-fun
+                  (funcall dx-cleanup-fun cleanup)))))))
+
 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
 ;;; the head and tail which are set to T.
 (declaim (ftype (sfunction (component) (values)) clear-flags))
@@ -779,74 +874,80 @@
     (clambda (delete-lambda fun)))
   (values))
 
-;;; Deal with deleting the last reference to a CLAMBDA. It is called
-;;; in two situations: when the lambda is unreachable (so that its
-;;; body may be deleted), and when it is an effectless LET (in this
-;;; case its body is reachable and is not completely "its"). We set
-;;; FUNCTIONAL-KIND to :DELETED and rely on IR1-OPTIMIZE to delete its
-;;; blocks.
+;;; Deal with deleting the last reference to a CLAMBDA, which means
+;;; that the lambda is unreachable, so that its body may be
+;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
+;;; IR1-OPTIMIZE to delete its blocks.
 (defun delete-lambda (clambda)
   (declare (type clambda clambda))
   (let ((original-kind (functional-kind clambda))
 	(bind (lambda-bind clambda)))
     (aver (not (member original-kind '(:deleted :toplevel))))
     (aver (not (functional-has-external-references-p clambda)))
+    (aver (or (eq original-kind :zombie) bind))
     (setf (functional-kind clambda) :deleted)
     (setf (lambda-bind clambda) nil)
 
-    (when bind              ; CLAMBDA is deleted due to unreachability
-      (labels ((delete-children (lambda)
-                 (dolist (child (lambda-children lambda))
-                   (cond ((eq (functional-kind child) :deleted)
-                          (delete-children child))
-                         (t
-                          (delete-lambda child))))
-                 (setf (lambda-children lambda) nil)
-                 (setf (lambda-parent lambda) nil)))
-        (delete-children clambda)))
-    (dolist (let (lambda-lets clambda))
-      (setf (lambda-bind let) nil)
-      (setf (functional-kind let) :deleted))
-
-    ;; LET may be deleted if its BIND is unreachable. Autonomous
-    ;; function may be deleted if it has no reachable references.
-    (unless (member original-kind '(:let :mv-let :assignment))
-      (dolist (ref (lambda-refs clambda))
-        (mark-for-deletion (node-block ref))))
+    (labels ((delete-children (lambda)
+               (dolist (child (lambda-children lambda))
+                 (cond ((eq (functional-kind child) :deleted)
+                        (delete-children child))
+                       (t
+                        (delete-lambda child))))
+               (setf (lambda-children lambda) nil)
+               (setf (lambda-parent lambda) nil)))
+      (delete-children clambda))
 
     ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
     ;; that we're using the old value of the KIND slot, not the
     ;; current slot value, which has now been set to :DELETED.)
-    (if (member original-kind '(:let :mv-let :assignment))
-	(let ((home (lambda-home clambda)))
-	  (setf (lambda-lets home) (delete clambda (lambda-lets home))))
-	;; If the function isn't a LET, we unlink the function head
-	;; and tail from the component head and tail to indicate that
-	;; the code is unreachable. We also delete the function from
-	;; COMPONENT-LAMBDAS (it won't be there before local call
-	;; analysis, but no matter.) If the lambda was never
-	;; referenced, we give a note.
-	(let* ((bind-block (node-block bind))
-	       (component (block-component bind-block))
-	       (return (lambda-return clambda))
-               (return-block (and return (node-block return))))
-	  (unless (leaf-ever-used clambda)
-	    (let ((*compiler-error-context* bind))
-	      (compiler-notify 'code-deletion-note
-			       :format-control "deleting unused function~:[.~;~:*~%  ~S~]"
-			       :format-arguments (list (leaf-debug-name clambda)))))
-          (unless (block-delete-p bind-block)
-            (unlink-blocks (component-head component) bind-block))
-	  (when (and return-block (not (block-delete-p return-block)))
-            (mark-for-deletion return-block)
-	    (unlink-blocks return-block (component-tail component)))
-	  (setf (component-reanalyze component) t)
-	  (let ((tails (lambda-tail-set clambda)))
-	    (setf (tail-set-funs tails)
-		  (delete clambda (tail-set-funs tails)))
-	    (setf (lambda-tail-set clambda) nil))
-	  (setf (component-lambdas component)
-		(delq clambda (component-lambdas component)))))
+    (case original-kind
+      (:zombie)
+      ((:let :mv-let :assignment)
+       (let ((bind-block (node-block bind)))
+         (mark-for-deletion bind-block))
+       (let ((home (lambda-home clambda)))
+         (setf (lambda-lets home) (delete clambda (lambda-lets home))))
+       ;; KLUDGE: In presence of NLEs we cannot always understand that
+       ;; LET's BIND dominates its body [for a LET "its" body is not
+       ;; quite its]; let's delete too dangerous for IR2 stuff. --
+       ;; APD, 2004-01-01
+       (dolist (var (lambda-vars clambda))
+         (flet ((delete-node (node)
+                  (mark-for-deletion (node-block node))))
+         (mapc #'delete-node (leaf-refs var))
+         (mapc #'delete-node (lambda-var-sets var)))))
+      (t
+       ;; Function has no reachable references.
+       (dolist (ref (lambda-refs clambda))
+         (mark-for-deletion (node-block ref)))
+       ;; If the function isn't a LET, we unlink the function head
+       ;; and tail from the component head and tail to indicate that
+       ;; the code is unreachable. We also delete the function from
+       ;; COMPONENT-LAMBDAS (it won't be there before local call
+       ;; analysis, but no matter.) If the lambda was never
+       ;; referenced, we give a note.
+       (let* ((bind-block (node-block bind))
+              (component (block-component bind-block))
+              (return (lambda-return clambda))
+              (return-block (and return (node-block return))))
+         (unless (leaf-ever-used clambda)
+           (let ((*compiler-error-context* bind))
+             (compiler-notify 'code-deletion-note
+                              :format-control "deleting unused function~:[.~;~:*~%  ~S~]"
+                              :format-arguments (list (leaf-debug-name clambda)))))
+         (unless (block-delete-p bind-block)
+           (unlink-blocks (component-head component) bind-block))
+         (when (and return-block (not (block-delete-p return-block)))
+           (mark-for-deletion return-block)
+           (unlink-blocks return-block (component-tail component)))
+         (setf (component-reanalyze component) t)
+         (let ((tails (lambda-tail-set clambda)))
+           (setf (tail-set-funs tails)
+                 (delete clambda (tail-set-funs tails)))
+           (setf (lambda-tail-set clambda) nil))
+         (setf (component-lambdas component)
+               (delq clambda (component-lambdas component))))))
 
     ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
     ;; ENTRY-FUN so that people will know that it is not an entry
@@ -903,6 +1004,9 @@
 	(when (optional-dispatch-more-entry leaf)
 	  (frob (optional-dispatch-more-entry leaf)))
 	(let ((main (optional-dispatch-main-entry leaf)))
+          (when entry
+            (setf (functional-entry-fun entry) main)
+            (setf (functional-entry-fun main) entry))
 	  (when (eq (functional-kind main) :optional)
 	    (frob main))))))
 
@@ -928,7 +1032,7 @@
 		 (delete-lambda leaf))
 		(:external
 		 (delete-lambda leaf))
-		((:deleted :optional))))
+		((:deleted :zombie :optional))))
 	     (optional-dispatch
 	      (unless (eq (functional-kind leaf) :deleted)
 		(delete-optional-dispatch leaf)))))
@@ -955,7 +1059,7 @@
     (do-uses (use lvar)
       (let ((prev (node-prev use)))
 	(let ((block (ctran-block prev)))
-          (setf (component-reoptimize (block-component block)) t)
+          (reoptimize-component (block-component block) t)
           (setf (block-attributep (block-flags block)
                                   flush-p type-asserted type-check)
                 t)))
@@ -971,6 +1075,13 @@
         (unless (block-delete-p block)
           (mark-for-deletion block))))))
 
+;;; Queue the block for deletion
+(defun delete-block-lazily (block)
+  (declare (type cblock block))
+  (unless (block-delete-p block)
+    (setf (block-delete-p block) t)
+    (push block (component-delete-blocks (block-component block)))))
+
 ;;; Do a graph walk backward from BLOCK, marking all predecessor
 ;;; blocks with the DELETE-P flag.
 (defun mark-for-deletion (block)
@@ -978,7 +1089,7 @@
   (let* ((component (block-component block))
          (head (component-head component)))
     (labels ((helper (block)
-               (setf (block-delete-p block) t)
+               (delete-block-lazily block)
                (dolist (pred (block-pred block))
                  (unless (or (block-delete-p pred)
                              (eq pred head))
@@ -991,10 +1102,12 @@
 ;;; This function does what is necessary to eliminate the code in it
 ;;; from the IR1 representation. This involves unlinking it from its
 ;;; predecessors and successors and deleting various node-specific
-;;; semantic information.
+;;; semantic information. BLOCK must be already removed from
+;;; COMPONENT-DELETE-BLOCKS.
 (defun delete-block (block &optional silent)
   (declare (type cblock block))
   (aver (block-component block))      ; else block is already deleted!
+  #!+high-security (aver (not (memq block (component-delete-blocks (block-component block)))))
   (unless silent
     (note-block-deletion block))
   (setf (block-delete-p block) t)
@@ -1089,8 +1202,14 @@
 	(unless (policy *compiler-error-context* (= inhibit-warnings 3))
 	  ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
 	  ;; requires this to be no more than a STYLE-WARNING.
+	  #-sb-xc-host
 	  (compiler-style-warn "The variable ~S is defined but never used."
-			       (leaf-debug-name var)))
+			       (leaf-debug-name var))
+	  ;; There's no reason to accept this kind of equivocation
+	  ;; when compiling our own code, though.
+	  #+sb-xc-host
+	  (warn "The variable ~S is defined but never used."
+		(leaf-debug-name var)))
 	(setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
   (values))
 
@@ -1225,20 +1344,30 @@
 	       (unlink-blocks block next)
 	       (dolist (pred (block-pred block))
 		 (change-block-successor pred block next))
-	       (remove-from-dfo block)
+	       (when (block-delete-p block)
+                 (let ((component (block-component block)))
+                   (setf (component-delete-blocks component)
+                         (delq block (component-delete-blocks component)))))
+               (remove-from-dfo block)
                (setf (block-delete-p block) t)
 	       (setf (node-prev node) nil)
 	       t)))))))
 
+;;; Return true if CTRAN has been deleted, false if it is still a valid
+;;; part of IR1.
+(defun ctran-deleted-p (ctran)
+  (declare (type ctran ctran))
+  (let ((block (ctran-block ctran)))
+    (or (not (block-component block))
+        (block-delete-p block))))
+
 ;;; Return true if NODE has been deleted, false if it is still a valid
 ;;; part of IR1.
 (defun node-deleted (node)
   (declare (type node node))
   (let ((prev (node-prev node)))
-    (not (and prev
-	      (let ((block (ctran-block prev)))
-		(and (block-component block)
-		     (not (block-delete-p block))))))))
+    (or (not prev)
+        (ctran-deleted-p prev))))
 
 ;;; Delete all the blocks and functions in COMPONENT. We scan first
 ;;; marking the blocks as DELETE-P to prevent weird stuff from being
@@ -1248,17 +1377,27 @@
   (aver (null (component-new-functionals component)))
   (setf (component-kind component) :deleted)
   (do-blocks (block component)
-    (setf (block-delete-p block) t))
+    (delete-block-lazily block))
   (dolist (fun (component-lambdas component))
     (unless (eq (functional-kind fun) :deleted)
       (setf (functional-kind fun) nil)
       (setf (functional-entry-fun fun) nil)
       (setf (leaf-refs fun) nil)
       (delete-functional fun)))
-  (do-blocks (block component)
-    (delete-block block))
+  (clean-component component)
   (values))
 
+;;; Remove all pending blocks to be deleted. Return the nearest live
+;;; block after or equal to BLOCK.
+(defun clean-component (component &optional block)
+  (loop while (component-delete-blocks component)
+        ;; actual deletion of a block may queue new blocks
+        do (let ((current (pop (component-delete-blocks component))))
+             (when (eq block current)
+               (setq block (block-next block)))
+             (delete-block current)))
+  block)
+
 ;;; Convert code of the form
 ;;;   (FOO ... (FUN ...) ...)
 ;;; to
@@ -1300,8 +1439,8 @@
 		(append before-args inside-args after-args))
 	  (change-ref-leaf (lvar-uses inside-fun)
 			   (find-free-fun 'list "???"))
-	  (setf (combination-kind inside)
-                (info :function :info 'list))
+	  (setf (combination-fun-info inside) (info :function :info 'list)
+		(combination-kind inside) :known)
 	  (setf (node-derived-type inside) *wild-type*)
 	  (flush-dest lvar)
 	  (values))))))
@@ -1384,7 +1523,7 @@
                (flet ((frob (l)
                         (find home l
                               :key #'node-home-lambda
-                              :test-not #'eq)))
+                              :test #'neq)))
                  (or (frob (leaf-refs var))
                      (frob (basic-var-sets var)))))))))
 
@@ -1392,8 +1531,7 @@
 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
 (defun find-nlx-info (exit)
   (declare (type exit exit))
-  (let* ((entry (exit-entry exit))
-         (entry-cleanup (entry-cleanup entry)))
+  (let ((entry (exit-entry exit)))
     (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
       (when (eq (nlx-info-exit nlx) exit)
 	(return nlx)))))
@@ -1503,8 +1641,8 @@
 	   ;; arbitrarily huge blocks of code. -- WHN)
 	   (let ((*compiler-error-context* node))
 	     (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
-			       probably trying to~%  ~
-			       inline a recursive function."
+                               probably trying to~%  ~
+                               inline a recursive function."
 			      *inline-expansion-limit*))
 	   nil)
 	  (t t))))
@@ -1520,20 +1658,22 @@
               ;; analysis, it is LET-converted: LET-converted functionals
               ;; are too badly trashed to expand them inline, and deleted
               ;; LET-converted functionals are even worse.
-              (eql (functional-kind functional) :deleted)))
+              (memq (functional-kind functional) '(:deleted :zombie))))
     (throw 'locall-already-let-converted functional)))
 
 (defun call-full-like-p (call)
   (declare (type combination call))
   (let ((kind (basic-combination-kind call)))
     (or (eq kind :full)
-        (and (fun-info-p kind)
-             (not (fun-info-ir2-convert kind))
-             (dolist (template (fun-info-templates kind) t)
-               (when (eq (template-ltn-policy template) :fast-safe)
-                 (multiple-value-bind (val win)
-                     (valid-fun-use call (template-type template))
-                   (when (or val (not win)) (return nil)))))))))
+        (and (eq kind :known)
+	     (let ((info (basic-combination-fun-info call)))
+	       (and
+		(not (fun-info-ir2-convert info))
+		(dolist (template (fun-info-templates info) t)
+		  (when (eq (template-ltn-policy template) :fast-safe)
+		    (multiple-value-bind (val win)
+		       (valid-fun-use call (template-type template))
+		      (when (or val (not win)) (return nil)))))))))))
 
 ;;;; careful call
 
@@ -1662,4 +1802,4 @@
              (do-uses (node lvar)
                (setf (node-reoptimize node) t)
                (setf (block-reoptimize (node-block node)) t)
-               (setf (component-reoptimize (node-component node)) t)))))))
+               (reoptimize-component (node-component node) :maybe)))))))