From 2e455fe88e8584c371b86de36b0e94f53bc00e92 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 4 Dec 2016 04:07:14 +0300
Subject: [PATCH] Add ir2-hook fun optimizer.

Used instead of IR2-CONVERT for issuing warnings (or something
similar). Having IR2-CONVERT and just doing IR2-CONVERT-FULL-CALL
interferes with things like CALL-FULL-LIKE-P.
---
 src/compiler/fun-info.lisp |  4 ++++
 src/compiler/ir2tran.lisp  | 19 ++++++++++---------
 2 files changed, 14 insertions(+), 9 deletions(-)

diff --git a/src/compiler/fun-info.lisp b/src/compiler/fun-info.lisp
index b0d16cbdd..7326cecdb 100644
--- a/src/compiler/fun-info.lisp
+++ b/src/compiler/fun-info.lisp
@@ -122,6 +122,10 @@
   ;; can't be handled using the template mechanism. The COMBINATION
   ;; node and the IR2-BLOCK are passed as arguments.
   (ir2-convert nil :type (or function null))
+  ;; Called before IR2 conversion, just like IR2-CONVERT above
+  ;; Currently used for issuing warnings so that it doesn't intefere
+  ;; with things like CALL-FULL-LIKE-P due to IR2-CONVERT.
+  (ir2-hook nil :type (or function null))
   ;; If true, the function can stack-allocate the result. The
   ;; COMBINATION node is passed as an argument.
   (stack-allocate-result nil :type (or function null))
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 310d5d7b1..ce0c01b6a 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -585,8 +585,8 @@
                              (ir2-lvar-locs 2value)
                              (ir2-lvar-locs 2lvar))))))
 
-(defoptimizer (%check-bound ir2-convert)
-    ((array bound index) node block)
+(defoptimizer (%check-bound ir2-hook) ((array bound index) node block)
+  (declare (ignore block))
   (when (constant-lvar-p bound)
     (let* ((bound-type (specifier-type `(integer 0 (,(lvar-value bound)))))
            (index-type (lvar-type index)))
@@ -595,8 +595,7 @@
         (let ((*compiler-error-context* node))
           (compiler-warn "Derived type ~s is not a suitable index for ~s."
                          (type-specifier index-type)
-                         (type-specifier (lvar-type array)))))))
-  (ir2-convert-template node block))
+                         (type-specifier (lvar-type array))))))))
 
 ;;;; template conversion
 
@@ -1997,8 +1996,8 @@ not stack-allocated LVAR ~S." source-lvar)))))
     (move-lvar-result node block results lvar)))
 
 #-sb-xc-host ;; package-lock-violation-p is not present yet
-(defoptimizer (set ir2-convert) ((symbol value) node block)
-  (declare (ignore value))
+(defoptimizer (set ir2-hook) ((symbol value) node block)
+  (declare (ignore value block))
   (when (constant-lvar-p symbol)
     (let* ((symbol (lvar-value symbol))
            (kind (info :variable :kind symbol)))
@@ -2006,8 +2005,7 @@ not stack-allocated LVAR ~S." source-lvar)))))
                  (sb!impl::package-lock-violation-p (symbol-package symbol) symbol))
         (let ((*compiler-error-context* node))
           (compiler-warn "violating package lock on ~/sb-impl:print-symbol-with-prefix/"
-                         symbol)))))
-  (ir2-convert-full-call node block))
+                         symbol))))))
 
 ;;; Convert the code in a component into VOPs.
 (defun ir2-convert (component)
@@ -2139,7 +2137,10 @@ not stack-allocated LVAR ~S." source-lvar)))))
               (ir2-convert-full-call node 2block))
              (:known
               (let* ((info (basic-combination-fun-info node))
-                     (fun (fun-info-ir2-convert info)))
+                     (fun (fun-info-ir2-convert info))
+                     (hook (fun-info-ir2-hook info)))
+                (when hook
+                  (funcall hook node 2block))
                 (cond (fun
                        (funcall fun node 2block))
                       ((eq (basic-combination-info node) :full)
-- 
2.11.4.GIT