From 321fff35923fc7621307f3d8d6105cbef8511341 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 6 May 2009 18:39:49 +0000 Subject: [PATCH] 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. --- package-data-list.lisp-expr | 4 +- src/code/array.lisp | 16 +------ src/code/kernel.lisp | 12 +++++ src/compiler/generic/vm-array.lisp | 4 ++ src/compiler/typetran.lisp | 89 ++++++++++++++++++++---------------- version.lisp-expr | 2 +- 6 files changed, 72 insertions(+), 55 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 39cac6f..dcfd780 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4