1.1.13: will be tagged as "sbcl-1.1.13"

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

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 3c000d5..8733eb4 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -71,32 +71,46 @@
 ;;; If the lvar OBJECT definitely is or isn't of the specified
 ;;; type, then return T or NIL as appropriate. Otherwise quietly
 ;;; GIVE-UP-IR1-TRANSFORM.
-(defun ir1-transform-type-predicate (object type)
+(defun ir1-transform-type-predicate (object type node)
   (declare (type lvar object) (type ctype type))
   (let ((otype (lvar-type object)))
-    (cond ((not (types-equal-or-intersect otype type))
-           nil)
-          ((csubtypep otype type)
-           t)
-          ((eq type *empty-type*)
-           nil)
-          (t
-           (let ((intersect (type-intersection2 type otype)))
-             (unless intersect
-               (give-up-ir1-transform))
-             (multiple-value-bind (constantp value)
-                 (type-singleton-p intersect)
-               (if constantp
-                   `(eql object ',value)
-                   (give-up-ir1-transform))))))))
+    (flet ((tricky ()
+             (cond ((typep type 'alien-type-type)
+                    ;; We don't transform alien type tests until here, because
+                    ;; once we do that the rest of the type system can no longer
+                    ;; reason about them properly -- so we'd miss out on type
+                    ;; derivation, etc.
+                    (delay-ir1-transform node :optimize)
+                    (let ((alien-type (alien-type-type-alien-type type)))
+                      ;; If it's a lisp-rep-type, the CTYPE should be one already.
+                      (aver (not (compute-lisp-rep-type alien-type)))
+                      `(sb!alien::alien-value-typep object ',alien-type)))
+                   (t
+                    (give-up-ir1-transform)))))
+      (cond ((not (types-equal-or-intersect otype type))
+            nil)
+           ((csubtypep otype type)
+            t)
+           ((eq type *empty-type*)
+            nil)
+           (t
+            (let ((intersect (type-intersection2 type otype)))
+              (unless intersect
+                (tricky))
+              (multiple-value-bind (constantp value)
+                  (type-singleton-p intersect)
+                (if constantp
+                    `(eql object ',value)
+                    (tricky)))))))))
 
 ;;; Flush %TYPEP tests whose result is known at compile time.
-(deftransform %typep ((object type))
+(deftransform %typep ((object type) * * :node node)
   (unless (constant-lvar-p type)
     (give-up-ir1-transform))
   (ir1-transform-type-predicate
    object
-   (ir1-transform-specifier-type (lvar-value type))))
+   (ir1-transform-specifier-type (lvar-value type))
+   node))
 
 ;;; This is the IR1 transform for simple type predicates. It checks
 ;;; whether the single argument is known to (not) be of the
@@ -108,7 +122,7 @@
                            (basic-combination-fun node))))
                         *backend-predicate-types*)))
     (aver ctype)
-    (ir1-transform-type-predicate object ctype)))
+    (ir1-transform-type-predicate object ctype node)))
 
 ;;; If FIND-CLASSOID is called on a constant class, locate the
 ;;; CLASSOID-CELL at load time.
@@ -218,8 +232,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)))
@@ -326,6 +346,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)
@@ -593,6 +627,9 @@
            (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))))