1.0.28.21: further array typechecking optimization

 (really, this time. contents accidentally left out from 1.0.28.20)

 * Eliminate extra lowtag checking from the array element type check:
   since we know we are dealing with an array, we can use the same
   fast widetag extraction code that array type dispatching used --
   factoring it out into %OTHER-POINTER-WIDETAG.

 * If we know after checking the dimensions that the array must have
   a header, and we know that the array is simple, we can deduce that
   there is exactly one level of indirection.

 * Similarly, if we know that the array has a header, we can
   immediately pull out the data vector to check if it too has a
   header instead of doing an extra test.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 39cac6f..dcfd780 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1268,7 +1268,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%MEMBER-KEY-TEST-NOT"
                "%MEMBER-TEST"
                "%MEMBER-TEST-NOT"
-               "%NEGATE" "%POW" "%PUTHASH"
+               "%NEGATE" "%POW"
+               "%OTHER-POINTER-WIDETAG"
+               "%PUTHASH"
                "%RASSOC"
                "%RASSOC-EQ"
                "%RASSOC-IF"

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 9dc3dfc..7df13d9 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -331,21 +331,9 @@ of specialized arrays is supported."
                 (defvar ,table-name)
                 (defmacro ,name (array-var)
                  `(the function
-                    (let ((tag 0)
-                          (offset
-                           #.(ecase sb!c:*backend-byte-order*
-                               (:little-endian
-                                (- sb!vm:other-pointer-lowtag))
-                               (:big-endian
-                                (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
-                      ;; WIDETAG-OF needs extra code to handle LIST and
-                      ;; FUNCTION lowtags. We're only dispatching on
-                      ;; other pointers, so let's do the lowtag
-                      ;; extraction manually.
+                    (let ((tag 0))
                       (when (sb!vm::%other-pointer-p ,array-var)
-                        (setf tag
-                              (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address ,array-var))
-                                                offset)))
+                        (setf tag (%other-pointer-widetag ,array-var)))
                       ;; SYMBOL-GLOBAL-VALUE is a performance hack
                       ;; for threaded builds.
                       (svref (sb!vm::symbol-global-value ',',table-name) tag)))))))

diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp
index a1f20ff..70ca1b7 100644 (file)
--- a/src/code/kernel.lisp
+++ b/src/code/kernel.lisp
@@ -32,6 +32,18 @@
 (defun widetag-of (x)
   (widetag-of x))
 
+;;; WIDETAG-OF needs extra code to handle LIST and FUNCTION lowtags. When
+;;; we're only dealing with other pointers (eg. when dispatching on array
+;;; element type), this is going to be faster.
+(declaim (inline %other-pointer-widetag))
+(defun %other-pointer-widetag (x)
+  (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address x))
+                    #.(ecase sb!c:*backend-byte-order*
+                        (:little-endian
+                         (- sb!vm:other-pointer-lowtag))
+                        (:big-endian
+                         (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
+
 ;;; Return a System-Area-Pointer pointing to the data for the vector
 ;;; X, which must be simple.
 ;;;

diff --git a/src/compiler/generic/vm-array.lisp b/src/compiler/generic/vm-array.lisp
index e0925e5..394fbd5 100644 (file)
--- a/src/compiler/generic/vm-array.lisp
+++ b/src/compiler/generic/vm-array.lisp
@@ -185,3 +185,7 @@ corresponding primitive types.")
 (defun find-saetp (element-type)
   (find element-type sb!vm:*specialized-array-element-type-properties*
         :key #'sb!vm:saetp-specifier :test #'equal))
+
+(defun find-saetp-by-ctype (ctype)
+  (find ctype sb!vm:*specialized-array-element-type-properties*
+        :key #'sb!vm:saetp-ctype :test #'csubtypep))

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 3513498..2f10b1e 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -334,6 +334,9 @@
 ;;; 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))
@@ -341,44 +344,50 @@
     (unless (or (eq dims '*)
                 (equal dims (array-type-dimensions stype)))
       (cond ((cdr dims)
-             `((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))))
-            ((and dims (csubtypep stype (specifier-type 'simple-array)))
-             `((not (array-header-p ,obj))
-               ,@(unless (eq '* (car dims))
-                         `((= (vector-length ,obj) ,@dims)))))
-            ((and dims (csubtypep stype (specifier-type '(and array (not simple-array)))))
-             `((array-header-p ,obj)
-               ,@(unless (eq '* (car dims))
-                         `((= (%array-dimension ,obj 0) ,@dims)))))
-            (dims
-             (unless (eq '* (car dims))
-               `((if (array-header-p ,obj)
-                     (= (%array-dimension ,obj 0) ,@dims)
-                     (= (vector-length ,obj) ,@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.
@@ -391,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

diff --git a/version.lisp-expr b/version.lisp-expr
index c3d8b07..b4722a2 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.28.20"
+"1.0.28.21"