1.0.16.13: use TRANSFORM-LIST-ITEM-SEEK for ADJOIN as well

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

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index e5091d1..53f3c64 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -24,8 +24,8 @@
 ;;;; predicates so complex that the only reasonable implentation is
 ;;;; via function call.
 ;;;;
-;;;; Some standard types (such as SEQUENCE) are best tested by letting
-;;;; the TYPEP source transform do its thing with the expansion. These
+;;;; Some standard types (such as ATOM) are best tested by letting the
+;;;; TYPEP source transform do its thing with the expansion. These
 ;;;; types (and corresponding predicates) are not maintained in this
 ;;;; association. In this case, there need not be any predicate
 ;;;; function unless it is required by the Common Lisp specification.
@@ -101,11 +101,11 @@
     (aver ctype)
     (ir1-transform-type-predicate object ctype)))
 
-;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
-;;; at load time.
+;;; If FIND-CLASSOID is called on a constant class, locate the
+;;; CLASSOID-CELL at load time.
 (deftransform find-classoid ((name) ((constant-arg symbol)) *)
   (let* ((name (lvar-value name))
-         (cell (find-classoid-cell name)))
+         (cell (find-classoid-cell name :create t)))
     `(or (classoid-cell-classoid ',cell)
          (error "class not yet defined: ~S" name))))
 \f
@@ -136,6 +136,8 @@
   (define-type-predicate numberp number)
   (define-type-predicate rationalp rational)
   (define-type-predicate realp real)
+  (define-type-predicate sequencep sequence)
+  (define-type-predicate extended-sequence-p extended-sequence)
   (define-type-predicate simple-bit-vector-p simple-bit-vector)
   (define-type-predicate simple-string-p simple-string)
   (define-type-predicate simple-vector-p simple-vector)
@@ -414,8 +416,8 @@
                         class:~%  ~S"
                        class))
       (t
-        ;; Delay the type transform to give type propagation a chance.
-        (delay-ir1-transform node :constraint)
+       ;; Delay the type transform to give type propagation a chance.
+       (delay-ir1-transform node :constraint)
 
        ;; Otherwise transform the type test.
        (multiple-value-bind (pred get-layout)
@@ -455,8 +457,17 @@
                           (and (> (layout-depthoid ,n-layout)
                                   ,depthoid)
                                (locally (declare (optimize (safety 0)))
-                                 (eq (svref (layout-inherits ,n-layout)
-                                            ,depthoid)
+                                 ;; Use DATA-VECTOR-REF directly,
+                                 ;; since that's what SVREF in a
+                                 ;; SAFETY 0 lexenv will eventually be
+                                 ;; transformed to. This can give a
+                                 ;; large compilation speedup, since
+                                 ;; %INSTANCE-TYPEPs are frequently
+                                 ;; created during GENERATE-TYPE-CHECKS,
+                                 ;; and the normal aref transformation path
+                                 ;; is pretty heavy.
+                                 (eq (data-vector-ref (layout-inherits ,n-layout)
+                                                      ,depthoid)
                                      ',layout))))))))
            ((and layout (>= (layout-depthoid layout) 0))
             ;; hierarchical layout depths for other things (e.g.
@@ -474,13 +485,14 @@
                           (let ((,n-inherits (layout-inherits ,n-layout)))
                             (declare (optimize (safety 0)))
                             (and (> (length ,n-inherits) ,depthoid)
-                                 (eq (svref ,n-inherits ,depthoid)
+                                 ;; See above.
+                                 (eq (data-vector-ref ,n-inherits ,depthoid)
                                      ',layout))))))))
            (t
             (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
             `(and (,pred object)
                   (classoid-cell-typep (,get-layout object)
-                                       ',(find-classoid-cell name)
+                                       ',(find-classoid-cell name :create t)
                                        object)))))))))
 
 ;;; If the specifier argument is a quoted constant, then we consider
@@ -540,7 +552,10 @@
   ;; 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) (eq (car spec) 'quote))
+  (if (and (consp spec)
+           (eq (car spec) 'quote)
+           (or (not *allow-instrumenting*)
+               (policy *lexenv* (= store-coverage-data 0))))
       (source-transform-typep object (cadr spec))
       (values nil t)))
 \f