More complicated TYPEP tests are marginally transparent to type propagation

Expansions for TYPEP are wrapped in %typep-wrapper, a fancy identity. The
additional arguments track what value is being tested for what type, which
helps inform constraint propagation, as well as detecting redundant type
tests.

Such a wrapper is a hindrance to lower level control flow rewriting that are
essential for decent code generation. After a single pass of constraint
propagation, the wrapper evaporates and the TYPEP expansion becomes as opaque
as it is now.

diff --git a/NEWS b/NEWS
index 3cb5e54..9b52268 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.1.13:
+  * optimization: complicated TYPEP tests are less opaque to the type
+    propagation pass. (lp#1229340)
   * enhancement: Top-level defmethod without defgeneric no longer causes
     undefined-function warnings in subsequent forms. (lp#503095)
   * bug fix: EQUALP now compares correctly structures with raw slots larger

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 86fe96d..4eacdfc 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1478,6 +1478,9 @@
   (movable flushable explicit-check))
 (defknown %instance-typep (t (or type-specifier ctype)) boolean
   (movable flushable explicit-check always-translatable))
+;;; We should never emit a call to %typep-wrapper
+(defknown %typep-wrapper (t t (or type-specifier ctype)) t
+  (movable flushable always-translatable))
 
 (defknown %cleanup-point () t)
 (defknown %special-bind (t t) t)

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 026dd5f..f4b8a79 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1833,6 +1833,13 @@
     (if (template-p (basic-combination-info node))
         (ir2-convert-template node block)
         (ir2-convert-full-call node block))))
+
+;; just a fancy identity
+(defoptimizer (%typep-wrapper ir2-convert) ((value variable type) node block)
+  (let* ((lvar (node-lvar node))
+         (results (lvar-result-tns lvar (list (primitive-type-or-lose t)))))
+    (emit-move node block (lvar-tn node block value) (first results))
+    (move-lvar-result node block results lvar)))
 \f
 ;;; Convert the code in a component into VOPs.
 (defun ir2-convert (component)

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 8733eb4..9090380 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -132,6 +132,35 @@
     `(or (classoid-cell-classoid ',cell)
          (error "class not yet defined: ~S" name))))
 \f
+(defoptimizer (%typep-wrapper constraint-propagate-if)
+    ((test-value variable type) node gen)
+  (aver (constant-lvar-p type))
+  (let ((type (lvar-value type)))
+    (values variable (if (ctype-p type)
+                         type
+                         (handler-case (careful-specifier-type type)
+                           (t () nil))))))
+
+(deftransform %typep-wrapper ((test-value variable type) * * :node node)
+  (aver (constant-lvar-p type))
+  (if (constant-lvar-p test-value)
+      `',(lvar-value test-value)
+      (let* ((type (lvar-value type))
+             (type (if (ctype-p type)
+                       type
+                       (handler-case (careful-specifier-type type)
+                         (t () nil))))
+             (value-type (lvar-type variable)))
+        (cond ((not type)
+               'test-value)
+              ((csubtypep value-type type)
+               t)
+              ((not (types-equal-or-intersect value-type type))
+               nil)
+              (t
+               (delay-ir1-transform node :constraint)
+               'test-value)))))
+\f
 ;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
 ;;;; plus at least one oddball (%INSTANCEP)
 ;;;;
@@ -590,11 +619,11 @@
 ;;; to that predicate. Otherwise, we dispatch off of the type's type.
 ;;; These transformations can increase space, but it is hard to tell
 ;;; when, so we ignore policy and always do them.
-(defun source-transform-typep (object type)
+(defun %source-transform-typep (object type)
   (let ((ctype (careful-specifier-type type)))
     (or (when (not ctype)
           (compiler-warn "illegal type specifier for TYPEP: ~S" type)
-          (return-from source-transform-typep (values nil t)))
+          (return-from %source-transform-typep (values nil t)))
         (multiple-value-bind (constantp value) (type-singleton-p ctype)
           (and constantp
                `(eql ,object ',value)))
@@ -614,7 +643,7 @@
            `(if (member ,object ',(member-type-members ctype)) t))
           (args-type
            (compiler-warn "illegal type specifier for TYPEP: ~S" type)
-           (return-from source-transform-typep (values nil t)))
+           (return-from %source-transform-typep (values nil t)))
           (t nil))
         (typecase ctype
           (numeric-type
@@ -633,6 +662,15 @@
           (t nil))
         `(%typep ,object ',type))))
 
+(defun source-transform-typep (object type)
+  (let ((name (gensym "OBJECT")))
+    (multiple-value-bind (transform error)
+        (%source-transform-typep name type)
+      (if error
+          (values nil t)
+          (values `(let ((,name ,object))
+                     (%typep-wrapper ,transform ,name ',type)))))))
+
 (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

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 21adaf5..7002c7c 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1,4 +1,5 @@
 
+
 ;;;; various compiler tests without side effects
 
 ;;;; This software is part of the SBCL system. See the README file for
@@ -4897,3 +4898,40 @@
       (test every)
       (test notany)
       (test notevery))))
+
+(with-test (:name :propagate-complex-type-tests)
+  (flet ((test (type value)
+           (let ((ftype (sb-kernel:%simple-fun-type
+                         (compile nil `(lambda (x)
+                                         (if (typep x ',type)
+                                             x
+                                             ',value))))))
+             (assert (typep ftype `(cons (eql function))))
+             (assert (= 3 (length ftype)))
+             (let* ((return (third ftype))
+                    (rtype (second return)))
+               (assert (typep return `(cons (eql values)
+                                            (cons t
+                                                  (cons (eql &optional)
+                                                        null)))))
+               (assert (and (subtypep rtype type)
+                            (subtypep type rtype)))))))
+    (mapc (lambda (params)
+            (apply #'test params))
+          `(((unsigned-byte 17) 0)
+            ((member 1 3 5 7) 5)
+            ((or symbol (eql 42)) t)))))
+
+(with-test (:name :constant-fold-complex-type-tests)
+  (assert (equal (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (x)
+                                  (if (typep x '(member 1 3))
+                                      (typep x '(member 1 3 15))
+                                      t))))
+                 `(function (t) (values (member t) &optional))))
+  (assert (equal (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (x)
+                                  (declare (type (member 1 3) x))
+                                  (typep x '(member 1 3 15)))))
+                 `(function ((or (integer 1 1) (integer 3 3)))
+                            (values (member t) &optional)))))