From 71d65624cecf880eba5c9a715b1b011ee005051c Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Mon, 9 Feb 2015 14:24:27 -0500
Subject: [PATCH] Fix TYPEP transform

---
 NEWS                       |  7 +++++++
 src/compiler/typetran.lisp | 12 ++----------
 tests/compiler.pure.lisp   |  6 ++++++
 3 files changed, 15 insertions(+), 10 deletions(-)

diff --git a/NEWS b/NEWS
index a0a339f2d..c123dec66 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,13 @@ changes relative to sbcl-1.2.8:
     SB-INTROSPECT:FUNCTION-TYPE might notice that (MEMBER T NIL)
     and (MEMBER NIL T) are both internally collapsed to the former,
     so that the latter can never be obtained as part of an FTYPE.
+  * optimization: a TYPEP call in which the second argument is not a
+    QUOTE form but nevertheless recognized as a compile-time constant
+    might open-code the test. One scenario for this involves backquote,
+    such as (TYPEP x `(my-type ,some-arg)). Code which relied upon
+    deferring until runtime should declare (NOTINLINE TYPEP).
+    [Due to the sematic constraints of DEFTYPE etc in in CLHS 3.2.2.3,
+    code requiring delayed evaluation could be unportable though.]
   * bug fix: DEFCLASS handles cyclic {super,meta}class relations better
     (lp#1418883)
   * bug fix: compiler no longer signals an error when compiling certain nested
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 39659ef9e..85a75ccbb 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -60,7 +60,8 @@
 (deftransform typep ((object type &optional env) * * :node node)
   (unless (constant-lvar-p type)
     (give-up-ir1-transform "can't open-code test of non-constant type"))
-  (unless (and (constant-lvar-p env) (null (lvar-value env)))
+  (unless (or (null env)
+              (and (constant-lvar-p env) (null (lvar-value env))))
     (give-up-ir1-transform "environment argument present and not null"))
   (multiple-value-bind (expansion fail-p)
       (source-transform-typep 'object (lvar-value type))
@@ -771,15 +772,6 @@
   ;; lvar, transforms it into a quoted form, and gives this
   ;; source transform another chance, so it all works out OK, in a
   ;; weird roundabout way. -- WHN 2001-03-18
-  ;; FIXME: it doesn't work as intended. Quick example:
-  ;;  * (defun h (x) (typep x `(unsigned-byte ,(1- sb-vm:n-word-bits))))
-  ;;  * (disassemble 'h)
-  ;;      ...
-  ;;      MOV RDI, [RIP-107] ; '(UNSIGNED-BYTE 63)
-  ;;      MOV RAX, [RIP-106] ; #<FDEFINITION for TYPEP>
-  ;;      ...
-  ;; So IR1 has figured out that the backquoted expression is constant,
-  ;; but the magic as described above doesn't happen.
   (if (and (not env)
            (consp spec)
            (eq (car spec) 'quote))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index c71aade59..635cd78b1 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -5474,3 +5474,9 @@
                   (declare (optimize debug))
                   (throw 'x *)))))
     *)))
+
+(with-test (:name :typep-quasiquoted-constant)
+  (assert (null (ctu:find-named-callees
+                 (compile nil
+                          '(lambda (x)
+                             (typep x `(signed-byte ,sb-vm:n-word-bits))))))))
-- 
2.11.4.GIT