From 8be78b41ac1695e1c9b5d7f6c8bd41e3c7e6e6fc Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Wed, 23 Oct 2013 22:36:17 -0400 Subject: [PATCH] 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. --- NEWS | 2 ++ src/compiler/fndb.lisp | 3 +++ src/compiler/ir2tran.lisp | 7 +++++++ src/compiler/typetran.lisp | 44 +++++++++++++++++++++++++++++++++++++++++--- tests/compiler.pure.lisp | 38 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 91 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 3cb5e54..9b52268 100644 --- 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 --- 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 --- 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))) ;;; 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 --- 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)))) +(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))))) + ;;;; 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 --- 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))))) -- 1.7.10.4