X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=2f10b1e98ee33b5cac10ad5d32441642a14cbb70;hb=c6fd5a650d63d358b182777ace8c42c8684f6f9b;hp=53f3c64412bede6e520499d7fd88e668f25c4da4;hpb=4f7161165647d655392713a0d95c951e4e1749ea;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 53f3c64..2f10b1e 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -334,40 +334,60 @@
 ;;; Return forms to test that OBJ has the rank and dimensions
 ;;; specified by TYPE, where STYPE is the type we have checked against
 ;;; (which is the same but for dimensions and element type).
+;;;
+;;; Secondary return value is true if generated tests passing imply
+;;; that the array has a header.
 (defun test-array-dimensions (obj type stype)
   (declare (type array-type type stype))
   (let ((obj `(truly-the ,(type-specifier stype) ,obj))
         (dims (array-type-dimensions type)))
     (unless (or (eq dims '*)
                 (equal dims (array-type-dimensions stype)))
-      (collect ((res))
-        (when (eq (array-type-dimensions stype) '*)
-          (res `(= (array-rank ,obj) ,(length dims))))
-        (do ((i 0 (1+ i))
-             (dim dims (cdr dim)))
-            ((null dim))
-          (let ((dim (car dim)))
-            (unless (eq dim '*)
-              (res `(= (array-dimension ,obj ,i) ,dim)))))
-        (res)))))
+      (cond ((cdr dims)
+             (values `((array-header-p ,obj)
+                       ,@(when (eq (array-type-dimensions stype) '*)
+                               `((= (%array-rank ,obj) ,(length dims))))
+                       ,@(loop for d in dims
+                               for i from 0
+                               unless (eq '* d)
+                               collect `(= (%array-dimension ,obj ,i) ,d)))
+                     t))
+            ((not dims)
+             (values `((array-header-p ,obj)
+                       (= (%array-rank ,obj) 0))
+                     t))
+            ((not (array-type-complexp type))
+             (values (unless (eq '* (car dims))
+                       `((= (vector-length ,obj) ,@dims)))
+                     nil))
+            (t
+             (values (unless (eq '* (car dims))
+                       `((if (array-header-p ,obj)
+                             (= (%array-dimension ,obj 0) ,@dims)
+                             (= (vector-length ,obj) ,@dims))))
+                     nil))))))
 
-;;; Return forms to test that OBJ has the element-type specified by
-;;; type specified by TYPE, where STYPE is the type we have checked
-;;; against (which is the same but for dimensions and element type).
-(defun test-array-element-type (obj type stype)
+;;; Return forms to test that OBJ has the element-type specified by type
+;;; specified by TYPE, where STYPE is the type we have checked against (which
+;;; is the same but for dimensions and element type). If HEADERP is true, OBJ
+;;; is guaranteed to be an array-header.
+(defun test-array-element-type (obj type stype headerp)
   (declare (type array-type type stype))
   (let ((obj `(truly-the ,(type-specifier stype) ,obj))
         (eltype (array-type-specialized-element-type type)))
-    (unless (type= eltype (array-type-specialized-element-type stype))
-      (with-unique-names (data)
-        `((do ((,data ,obj (%array-data-vector ,data)))
-              ((not (array-header-p ,data))
-               ;; KLUDGE: this isn't in fact maximally efficient,
-               ;; because though we know that DATA is a (SIMPLE-ARRAY *
-               ;; (*)), we will still check to see if the lowtag is
-               ;; appropriate.
-               (typep ,data
-                      '(simple-array ,(type-specifier eltype) (*))))))))))
+    (unless (or (type= eltype (array-type-specialized-element-type stype))
+                (eq eltype *wild-type*))
+      (let ((typecode (sb!vm:saetp-typecode (find-saetp-by-ctype eltype))))
+        (with-unique-names (data)
+         (if (and headerp (not (array-type-complexp stype)))
+             ;; If we know OBJ is an array header, and that the array is
+             ;; simple, we also know there is exactly one indirection to
+             ;; follow.
+             `((eq (%other-pointer-widetag (%array-data-vector ,obj)) ,typecode))
+             `((do ((,data ,(if headerp `(%array-data-vector ,obj) obj)
+                           (%array-data-vector ,data)))
+                   ((not (array-header-p ,data))
+                    (eq (%other-pointer-widetag ,data) ,typecode))))))))))
 
 ;;; If we can find a type predicate that tests for the type without
 ;;; dimensions, then use that predicate and test for dimensions.
@@ -380,11 +400,13 @@
              ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
              (not (unknown-type-p (array-type-element-type type)))
              (eq (array-type-complexp stype) (array-type-complexp type)))
-        (once-only ((n-obj obj))
-          `(and (,pred ,n-obj)
-                ,@(test-array-dimensions n-obj type stype)
-                ,@(test-array-element-type n-obj type stype)))
-        `(%typep ,obj ',(type-specifier type)))))
+          (once-only ((n-obj obj))
+            (multiple-value-bind (tests headerp)
+                (test-array-dimensions n-obj type stype)
+              `(and (,pred ,n-obj)
+                    ,@tests
+                    ,@(test-array-element-type n-obj type stype headerp))))
+          `(%typep ,obj ',(type-specifier type)))))
 
 ;;; Transform a type test against some instance type. The type test is
 ;;; flushed if the result is known at compile time. If not properly