From 88fd8640e118ace44185a90baac095025acec3c5 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Tue, 27 Dec 2016 18:56:34 +0300
Subject: [PATCH] Avoid notes for transforms that would not be applied due to
 policy.

The policy is checked in the transform body, but if the transform is
not applied due to mismatching types a note would be issued.
Changing types would not apply the transform anyway, moreover there
may be another transform that would pick up the types if the policy is
suitable.
---
 src/compiler/ir1opt.lisp   | 11 +++++++----
 src/compiler/knownfun.lisp | 18 +++++++++++-------
 src/compiler/macros.lisp   | 19 ++++++++++++-------
 tests/compiler.pure.lisp   |  9 +++++++++
 4 files changed, 39 insertions(+), 18 deletions(-)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index ab27dd848..bbd613594 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1311,8 +1311,11 @@
          (flame (case (transform-important transform)
                   ((t) (policy node (>= speed inhibit-warnings)))
                   (:slightly (policy node (> speed inhibit-warnings)))))
-         (*compiler-error-context* node))
-    (cond ((or (not constrained)
+         (*compiler-error-context* node)
+         (policy-test (transform-policy transform)))
+    (cond ((and policy-test
+                (not (funcall policy-test node))))
+          ((or (not constrained)
                (valid-fun-use node type))
            (multiple-value-bind (severity args)
                (catch 'give-up-ir1-transform
@@ -1338,8 +1341,8 @@
                           (remove transform (gethash node table) :key #'car)))
                 t)
                (:delayed
-                 (remhash node table)
-                 nil))))
+                (remhash node table)
+                nil))))
           ((and flame
                 (valid-fun-use node
                                type
diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp
index 4d7b2e0cc..cdfe05fef 100644
--- a/src/compiler/knownfun.lisp
+++ b/src/compiler/knownfun.lisp
@@ -34,17 +34,20 @@
   ;; string used in efficiency notes
   (note (missing-arg) :type string)
   ;; T if we should emit a failure note even if SPEED=INHIBIT-WARNINGS.
-  (important nil :type (member nil :slightly t)))
+  (important nil :type (member nil :slightly t))
+  ;; A function with NODE as an argument that checks wheteher the
+  ;; transform applies in its policy.
+  ;; It used to be checked in the FUNCTION body but it would produce
+  ;; notes about failed transformation due to types even though it
+  ;; wouldn't have been applied with the right types anyway,
+  ;; or if another transform could be applied with the right policy.
+  (policy nil :type (or null function)))
 
 (defprinter (transform) type note important)
 
 ;;; Grab the FUN-INFO and enter the function, replacing any old
 ;;; one with the same type and note.
-(declaim (ftype (function (t list function &optional (or string null)
-                             (member nil :slightly t))
-                          *)
-                %deftransform))
-(defun %deftransform (name type fun &optional note important)
+(defun %deftransform (name type fun &optional note important policy)
   (let* ((ctype (specifier-type type))
          (note (or note "optimize"))
          (info (fun-info-or-lose name))
@@ -60,7 +63,8 @@
                  (transform-note old) note))
           (t
            (push (make-transform :type ctype :function fun :note note
-                                 :important important)
+                                 :important important
+                                 :policy policy)
                  (fun-info-transforms info))))
     name))
 
diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 0e9f0458a..46253c79a 100644
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -294,9 +294,6 @@
                   ,@(and defun-only
                          doc
                          `(,doc))
-                  ,@(if policy
-                        `((unless (policy ,n-node ,policy)
-                            (give-up-ir1-transform))))
                   ;; What purpose does it serve to allow the transform's body
                   ;; to return decls as a second value? They would go in the
                   ;; right place if simply returned as part of the expression.
@@ -318,7 +315,10 @@
                 (named-lambda ,(if eval-name "xform" `(deftransform ,name))
                   ,@stuff)
                 ,doc
-                ,important)))))))
+                ,important
+                ,(and policy
+                      `(lambda (,n-node)
+                         (policy ,n-node ,policy))))))))))
 
 (defmacro deftransforms (names (lambda-list &optional (arg-types '*)
                                                       (result-type '*)
@@ -336,9 +336,14 @@
          ,@body-decls-doc)
        ,@(loop for name in names
                collect
-               `(%deftransform ',name ',type #',transform-name
-                               ,doc
-                               ,important)))))
+               `(let ((policy ,(and policy
+                                    (let ((node-sym (gensym "NODE")))
+                                      `(lambda (,node-sym)
+                                         (policy ,node-sym ,policy))))))
+                  (%deftransform ',name ',type #',transform-name
+                                 ,doc
+                                 ,important
+                                 policy))))))
 
 ;;;; DEFKNOWN and DEFOPTIMIZER
 
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index ae0160c2c..9c4149cf8 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -6091,3 +6091,12 @@
                           (find-if #'oddp x :key '-)))
                       #(1))
              1)))
+
+(with-test (:name :transforms-check-policy-first)
+  (assert (eql (funcall (checked-compile
+                         `(lambda (x)
+                            (declare (optimize speed space))
+                            (find x "a b c" :test #'char-equal))
+                         :allow-notes nil)
+                        #\B)
+               #\b)))
-- 
2.11.4.GIT