1.0.36.8: deal with environment argument in TYPEP transforms

 Thanks to Karol Swietlicki.

 Launchpad bug #309788

diff --git a/NEWS b/NEWS
index ea92d44..5484d8b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes relative to sbcl-1.0.36:
   * optimization: the compiler is now more aware of the type of the underlying
     storage vector for multidimensional simple arrays resulting in better code
     for accessing such arrays.
+  * optimization: passing NIL as the environment argument to TYPEP no longer
+    inhibits optimizing it. (lp#309788)
   * bug fix: Fix compiler error involving MAKE-ARRAY and IF forms
     in :INITIAL-CONTENTS. (lp#523612)
   * bug fix: FUNCTION-LAMBDA-EXPRESSION lost declarations from interpreted

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 6abf25c..c1f818d 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -57,9 +57,11 @@
 ;;; constant. At worst, it will convert to %TYPEP, which will prevent
 ;;; spurious attempts at transformation (and possible repeated
 ;;; warnings.)
-(deftransform typep ((object type) * * :node node)
+(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)))
+    (give-up-ir1-transform "environment argument present and not null"))
   (multiple-value-bind (expansion fail-p)
       (source-transform-typep 'object (lvar-value type))
     (if fail-p
@@ -584,14 +586,15 @@
           (t nil))
         `(%typep ,object ',type))))
 
-(define-source-transform typep (object spec)
+(define-source-transform typep (object spec &optional env)
   ;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
   ;; since that would overlook other kinds of constants. But it turns
   ;; out that the DEFTRANSFORM for TYPEP detects any constant
   ;; 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
-  (if (and (consp spec)
+  (if (and (not env)
+           (consp spec)
            (eq (car spec) 'quote)
            (or (not *allow-instrumenting*)
                (policy *lexenv* (= store-coverage-data 0))))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 422da06..28d6191 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3446,3 +3446,12 @@
                                  (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
     (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
     (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
+
+(with-test (:name :bug-309788)
+  (let ((fun
+         (compile nil
+                  `(lambda (x)
+                     (declare (optimize speed))
+                     (let ((env nil))
+                       (typep x 'fixnum env))))))
+    (assert (not (ctu:find-named-callees fun)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 2389d11..a8629a1 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.36.7"
+"1.0.36.8"