Optimize testing of sealed structures.

[sbcl.git] / src / compiler / typetran.lisp

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index aeb9a7b..b6c1a8f 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)
 ;;;;
@@ -232,8 +261,14 @@
     (once-only ((n-object object))
       (ecase (numeric-type-complexp type)
         (:real
-         `(and (typep ,n-object ',base)
-               ,(transform-numeric-bound-test n-object type base)))
+         (if (and #!-(or x86 x86-64) ;; Not implemented elsewhere yet
+                  nil
+                  (eql (numeric-type-class type) 'integer)
+                  (eql (numeric-type-low type) 0)
+                  (fixnump (numeric-type-high type)))
+             `(fixnum-mod-p ,n-object ,(numeric-type-high type))
+             `(and (typep ,n-object ',base)
+                   ,(transform-numeric-bound-test n-object type base))))
         (:complex
          `(and (complexp ,n-object)
                ,(once-only ((n-real `(realpart (truly-the complex ,n-object)))
@@ -340,6 +375,20 @@
                             collect
                             `(<= ,(car pair) ,n-code ,(cdr pair)))))))))))
 
+#!+sb-simd-pack
+(defun source-transform-simd-pack-typep (object type)
+  (if (type= type (specifier-type 'simd-pack))
+      `(simd-pack-p ,object)
+      (once-only ((n-obj object))
+        (let ((n-tag (gensym "TAG")))
+          `(and
+            (simd-pack-p ,n-obj)
+            (let ((,n-tag (%simd-pack-tag ,n-obj)))
+              (or ,@(loop
+                      for type in (simd-pack-type-element-type type)
+                      for index = (position type *simd-pack-element-types*)
+                      collect `(eql ,n-tag ,index)))))))))
+
 ;;; Return the predicate and type from the most specific entry in
 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
 (defun find-supertype-predicate (type)
@@ -494,13 +543,8 @@
            ((and (eq (classoid-state class) :sealed) layout
                  (not (classoid-subclasses class)))
             ;; Sealed and has no subclasses.
-            (let ((n-layout (gensym)))
-              `(and (,pred object)
-                    (let ((,n-layout (,get-layout object)))
-                      ,@(when (policy *lexenv* (>= safety speed))
-                              `((when (layout-invalid ,n-layout)
-                                  (%layout-invalid-error object ',layout))))
-                      (eq ,n-layout ',layout)))))
+            `(and (,pred object)
+                  (eq (,get-layout object) ',layout)))
            ((and (typep class 'structure-classoid) layout)
             ;; structure type tests; hierarchical layout depths
             (let ((depthoid (layout-depthoid layout))
@@ -570,11 +614,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)))
@@ -594,7 +638,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
@@ -607,9 +651,21 @@
            (source-transform-cons-typep object ctype))
           (character-set-type
            (source-transform-character-set-typep object ctype))
+          #!+sb-simd-pack
+          (simd-pack-type
+           (source-transform-simd-pack-typep object ctype))
           (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