From cfb04dbf1fb23a405c23de99ca998cdd2ff0d31f Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Tue, 3 Dec 2013 22:31:09 +0400 Subject: [PATCH] Optimize make-array for unknown dimensions. (make-array x :element-type '(unsigned-byte 8)) went through a costly procedure of determining what type should be used for (unsigned-byte 8), but this can be done at compile-time. That form is now 25 times faster, and only 4 times slower than (make-array (the integer x) :element-type '(unsigned-byte 8)) --- NEWS | 2 + package-data-list.lisp-expr | 1 + src/code/array.lisp | 258 ++++++++++++++++++++++-------------------- src/compiler/array-tran.lisp | 77 ++++++++----- src/compiler/fndb.lisp | 15 ++- 5 files changed, 206 insertions(+), 147 deletions(-) diff --git a/NEWS b/NEWS index 79be5ec..303ebc0 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,8 @@ changes relative to sbcl-1.1.14: execution. The previous behaviour can be obtained by instead setting that variable to :greedy. Thanks again to Google for their support, and, more crucially, to Alexandra Barchunova for her hard work. + * optimization: make-array with known element-type and unkown dimensions is + much faster. * enhancement: sb-ext:save-lisp-and-die on Windows now accepts :application-type argument, which can be :console or :gui. :gui allows having GUI applications without an automatically appearing console window. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c9204fb..72bf994 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1369,6 +1369,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%LASTN/BIGNUM" "%LOG1P" #!+long-float "%LONG-FLOAT" + "%MAKE-ARRAY" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-FUNCALLABLE-STRUCTURE-INSTANCE-ALLOCATOR" "%MAKE-RATIO" "%MAKE-LISP-OBJ" diff --git a/src/code/array.lisp b/src/code/array.lisp index 02425d1..e367539 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -106,32 +106,16 @@ ,(sb!vm:saetp-n-bits saetp)))) sb!vm:*specialized-array-element-type-properties*))))) -(defun %complex-vector-widetag (type) - (case type - ;; Pick off some easy common cases. - ((t) - #.sb!vm:complex-vector-widetag) - ((base-char #!-sb-unicode character) - #.sb!vm:complex-base-string-widetag) - #!+sb-unicode - ((character) - #.sb!vm:complex-character-string-widetag) - ((nil) - #.sb!vm:complex-vector-nil-widetag) - ((bit) - #.sb!vm:complex-bit-vector-widetag) - ;; OK, we have to wade into SUBTYPEPing after all. - (t - (pick-vector-type type - (nil #.sb!vm:complex-vector-nil-widetag) - #!-sb-unicode - (character #.sb!vm:complex-base-string-widetag) - #!+sb-unicode - (base-char #.sb!vm:complex-base-string-widetag) - #!+sb-unicode - (character #.sb!vm:complex-character-string-widetag) - (bit #.sb!vm:complex-bit-vector-widetag) - (t #.sb!vm:complex-vector-widetag))))) +(defun %complex-vector-widetag (widetag) + (macrolet ((make-case () + `(case widetag + ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties* + for complex = (sb!vm:saetp-complex-typecode saetp) + when complex + collect (list (sb!vm:saetp-typecode saetp) complex)) + (t + #.sb!vm:complex-vector-widetag)))) + (make-case))) (defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask))) #.(loop for info across sb!vm:*specialized-array-element-type-properties* @@ -155,101 +139,131 @@ n-bits) sb!vm:n-word-bits)))) -(defun make-array (dimensions &key - (element-type t) - (initial-element nil initial-element-p) - (initial-contents nil initial-contents-p) - adjustable fill-pointer - displaced-to displaced-index-offset) +(defun array-underlying-widetag (array) + (macrolet ((make-case () + `(case widetag + ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties* + for complex = (sb!vm:saetp-complex-typecode saetp) + when complex + collect (list complex (sb!vm:saetp-typecode saetp))) + ((,sb!vm:simple-array-widetag + ,sb!vm:complex-vector-widetag + ,sb!vm:complex-array-widetag) + (with-array-data ((array array) (start) (end)) + (declare (ignore start end)) + (widetag-of array))) + (t + widetag)))) + (let ((widetag (widetag-of array))) + (make-case)))) + +;;; Widetag is the widetag of the underlying vector, +;;; it'll be the same as the resulting array widetag only for simple vectors +(defun %make-array (dimensions widetag n-bits + &key + element-type + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p) + adjustable fill-pointer + displaced-to displaced-index-offset) + (declare (ignore element-type)) (let* ((dimensions (if (listp dimensions) dimensions (list dimensions))) (array-rank (length (the list dimensions))) (simple (and (null fill-pointer) (not adjustable) (null displaced-to)))) (declare (fixnum array-rank)) - (when (and displaced-index-offset (null displaced-to)) - (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) - (when (and displaced-to - (arrayp displaced-to) - (not (equal (array-element-type displaced-to) - (upgraded-array-element-type element-type)))) - (error "Array element type of :DISPLACED-TO array does not match specified element type")) - (if (and simple (= array-rank 1)) - ;; it's a (SIMPLE-ARRAY * (*)) - (multiple-value-bind (type n-bits) - (%vector-widetag-and-n-bits element-type) - (declare (type (unsigned-byte 8) type) - (type (integer 0 256) n-bits)) - (let* ((length (car dimensions)) - (array (allocate-vector-with-widetag type length n-bits))) - (declare (type index length)) - (when initial-element-p - (fill array initial-element)) - (when initial-contents-p - (when initial-element-p - (error "can't specify both :INITIAL-ELEMENT and ~ + (cond ((and displaced-index-offset (null displaced-to)) + (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) + ((and simple (= array-rank 1)) + ;; it's a (SIMPLE-ARRAY * (*)) + (let* ((length (car dimensions)) + (array (allocate-vector-with-widetag widetag length n-bits))) + (declare (type index length)) + (when initial-element-p + (fill array initial-element)) + (when initial-contents-p + (when initial-element-p + (error "can't specify both :INITIAL-ELEMENT and ~ :INITIAL-CONTENTS")) - (unless (= length (length initial-contents)) - (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ + (unless (= length (length initial-contents)) + (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ the vector length is ~W." - (length initial-contents) - length)) - (replace array initial-contents)) - array)) - ;; it's either a complex array or a multidimensional array. - (let* ((total-size (reduce #'* dimensions)) - (data (or displaced-to - (data-vector-from-inits - dimensions total-size element-type nil - initial-contents initial-contents-p - initial-element initial-element-p))) - (array (make-array-header - (cond ((= array-rank 1) - (%complex-vector-widetag element-type)) - (simple sb!vm:simple-array-widetag) - (t sb!vm:complex-array-widetag)) - array-rank))) - (cond (fill-pointer - (unless (= array-rank 1) - (error "Only vectors can have fill pointers.")) - (let ((length (car dimensions))) - (declare (fixnum length)) - (setf (%array-fill-pointer array) - (cond ((eq fill-pointer t) - length) - (t - (unless (and (fixnump fill-pointer) - (>= fill-pointer 0) - (<= fill-pointer length)) - ;; FIXME: should be TYPE-ERROR? - (error "invalid fill-pointer ~W" - fill-pointer)) - fill-pointer)))) - (setf (%array-fill-pointer-p array) t)) - (t - (setf (%array-fill-pointer array) total-size) - (setf (%array-fill-pointer-p array) nil))) - (setf (%array-available-elements array) total-size) - (setf (%array-data-vector array) data) - (setf (%array-displaced-from array) nil) - (cond (displaced-to - (when (or initial-element-p initial-contents-p) - (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ + (length initial-contents) + length)) + (replace array initial-contents)) + array)) + ((and (arrayp displaced-to) + (/= (array-underlying-widetag displaced-to) widetag)) + (error "Array element type of :DISPLACED-TO array does not match specified element type")) + (t + ;; it's either a complex array or a multidimensional array. + (let* ((total-size (reduce #'* dimensions)) + (data (or displaced-to + (data-vector-from-inits + dimensions total-size nil widetag n-bits + initial-contents initial-contents-p + initial-element initial-element-p))) + (array (make-array-header + (cond ((= array-rank 1) + (%complex-vector-widetag widetag)) + (simple sb!vm:simple-array-widetag) + (t sb!vm:complex-array-widetag)) + array-rank))) + (cond (fill-pointer + (unless (= array-rank 1) + (error "Only vectors can have fill pointers.")) + (let ((length (car dimensions))) + (declare (fixnum length)) + (setf (%array-fill-pointer array) + (cond ((eq fill-pointer t) + length) + (t + (unless (and (fixnump fill-pointer) + (>= fill-pointer 0) + (<= fill-pointer length)) + ;; FIXME: should be TYPE-ERROR? + (error "invalid fill-pointer ~W" + fill-pointer)) + fill-pointer)))) + (setf (%array-fill-pointer-p array) t)) + (t + (setf (%array-fill-pointer array) total-size) + (setf (%array-fill-pointer-p array) nil))) + (setf (%array-available-elements array) total-size) + (setf (%array-data-vector array) data) + (setf (%array-displaced-from array) nil) + (cond (displaced-to + (when (or initial-element-p initial-contents-p) + (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ can be specified along with :DISPLACED-TO")) - (let ((offset (or displaced-index-offset 0))) - (when (> (+ offset total-size) - (array-total-size displaced-to)) - (error "~S doesn't have enough elements." displaced-to)) - (setf (%array-displacement array) offset) - (setf (%array-displaced-p array) t) - (%save-displaced-array-backpointer array data))) - (t - (setf (%array-displaced-p array) nil))) - (let ((axis 0)) - (dolist (dim dimensions) - (setf (%array-dimension array axis) dim) - (incf axis))) - array)))) + (let ((offset (or displaced-index-offset 0))) + (when (> (+ offset total-size) + (array-total-size displaced-to)) + (error "~S doesn't have enough elements." displaced-to)) + (setf (%array-displacement array) offset) + (setf (%array-displaced-p array) t) + (%save-displaced-array-backpointer array data))) + (t + (setf (%array-displaced-p array) nil))) + (let ((axis 0)) + (dolist (dim dimensions) + (setf (%array-dimension array axis) dim) + (incf axis))) + array))))) + +(defun make-array (dimensions &rest args + &key (element-type t) + initial-element initial-contents + adjustable + fill-pointer + displaced-to + displaced-index-offset) + (declare (ignore initial-element + initial-contents adjustable + fill-pointer displaced-to displaced-index-offset)) + (multiple-value-bind (widetag n-bits) (%vector-widetag-and-n-bits element-type) + (apply #'%make-array dimensions widetag n-bits args))) (defun make-static-vector (length &key (element-type '(unsigned-byte 8)) @@ -301,18 +315,21 @@ of specialized arrays is supported." ;;; to FILL-DATA-VECTOR for error checking on the structure of ;;; initial-contents. (defun data-vector-from-inits (dimensions total-size - element-type widetag + element-type widetag n-bits initial-contents initial-contents-p initial-element initial-element-p) (when initial-element-p (when initial-contents-p (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to either MAKE-ARRAY or ADJUST-ARRAY.")) - (unless (typep initial-element element-type) - (error "~S cannot be used to initialize an array of type ~S." - initial-element element-type))) + ;; FIXME: element-type can be NIL when widetag is non-nil, + ;; and FILL will check the type, although the error will be not as nice. + ;; (cond (typep initial-element element-type) + ;; (error "~S cannot be used to initialize an array of type ~S." + ;; initial-element element-type)) + ) (let ((data (if widetag - (allocate-vector-with-widetag widetag total-size) + (allocate-vector-with-widetag widetag total-size n-bits) (make-array total-size :element-type element-type)))) (cond (initial-element-p (fill (the vector data) initial-element)) @@ -869,7 +886,7 @@ of specialized arrays is supported." the :INITIAL-ELEMENT or :DISPLACED-TO option.")) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits - dimensions array-size element-type nil + dimensions array-size element-type nil nil initial-contents initial-contents-p initial-element initial-element-p))) (if (adjustable-array-p array) @@ -923,7 +940,7 @@ of specialized arrays is supported." (setf new-data (data-vector-from-inits dimensions new-length element-type - (widetag-of old-data) + (widetag-of old-data) nil initial-contents initial-contents-p initial-element initial-element-p)) ;; Provide :END1 to avoid full call to LENGTH @@ -952,7 +969,8 @@ of specialized arrays is supported." (data-vector-from-inits dimensions new-length element-type - (widetag-of old-data) () nil + (widetag-of old-data) nil + () nil initial-element initial-element-p) old-data))) (if (or (zerop old-length) (zerop new-length)) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 14b2fa5..c44afb4 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -280,15 +280,16 @@ (defoptimizer (%set-row-major-aref derive-type) ((array index new-value)) (assert-new-value-type new-value array)) -(defoptimizer (make-array derive-type) - ((dims &key initial-element element-type initial-contents - adjustable fill-pointer displaced-index-offset displaced-to)) +(defun derive-make-array-type (dims element-type adjustable + fill-pointer displaced-to) (let* ((simple (and (unsupplied-or-nil adjustable) (unsupplied-or-nil displaced-to) (unsupplied-or-nil fill-pointer))) (spec - (or `(,(if simple 'simple-array 'array) + (or `(,(if simple 'simple-array 'array) ,(cond ((not element-type) t) + ((ctype-p element-type) + (type-specifier element-type)) ((constant-lvar-p element-type) (let ((ctype (careful-specifier-type (lvar-value element-type)))) @@ -309,13 +310,31 @@ '(*)) (t '*))) - 'array))) + 'array))) (if (and (not simple) (or (supplied-and-true adjustable) (supplied-and-true displaced-to) (supplied-and-true fill-pointer))) (careful-specifier-type `(and ,spec (not simple-array))) (careful-specifier-type spec)))) + +(defoptimizer (make-array derive-type) + ((dims &key element-type adjustable fill-pointer displaced-to)) + (derive-make-array-type dims element-type adjustable + fill-pointer displaced-to)) + +(defoptimizer (%make-array derive-type) + ((dims widetag n-bits &key adjustable fill-pointer displaced-to)) + (declare (ignore n-bits)) + (let ((saetp (and (constant-lvar-p widetag) + (find (lvar-value widetag) + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-typecode)))) + (derive-make-array-type dims (if saetp + (sb!vm:saetp-ctype saetp) + *wild-type*) + adjustable fill-pointer displaced-to))) + ;;;; constructors @@ -524,9 +543,9 @@ (deftransform make-array ((dims &key initial-element element-type adjustable fill-pointer) - (t &rest *)) - (when (null initial-element) - (give-up-ir1-transform)) + (t &rest *) * + :node node) + (delay-ir1-transform node :constraint) (let* ((eltype (cond ((not element-type) t) ((not (constant-lvar-p element-type)) (give-up-ir1-transform @@ -534,22 +553,28 @@ (t (lvar-value element-type)))) (eltype-type (ir1-transform-specifier-type eltype)) - (saetp (find-if (lambda (saetp) - (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) - sb!vm:*specialized-array-element-type-properties*)) - (creation-form `(make-array dims - :element-type ',(type-specifier (sb!vm:saetp-ctype saetp)) + (saetp (if (unknown-type-p eltype-type) + (give-up-ir1-transform + "ELEMENT-TYPE ~s is not a known type" + eltype-type) + (find eltype-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-ctype + :test #'csubtypep))) + (creation-form `(%make-array + dims + ,(if saetp + (sb!vm:saetp-typecode saetp) + (give-up-ir1-transform)) + ,(sb!vm:saetp-n-bits saetp) ,@(when fill-pointer - '(:fill-pointer fill-pointer)) + '(:fill-pointer fill-pointer)) ,@(when adjustable - '(:adjustable adjustable))))) - - (unless saetp - (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype)) - - (cond ((and (constant-lvar-p initial-element) - (eql (lvar-value initial-element) - (sb!vm:saetp-initial-element-default saetp))) + '(:adjustable adjustable))))) + (cond ((or (not initial-element) + (and (constant-lvar-p initial-element) + (eql (lvar-value initial-element) + (sb!vm:saetp-initial-element-default saetp)))) creation-form) (t ;; error checking for target, disabled on the host because @@ -576,10 +601,10 @@ (compiler-style-warn "~S is not a ~S." value eltype))))) `(let ((array ,creation-form)) - (multiple-value-bind (vector) - (%data-vector-and-index array 0) - (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element))) - array))))) + (multiple-value-bind (vector) + (%data-vector-and-index array 0) + (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element))) + array))))) ;;; The list type restriction does not ensure that the result will be a ;;; multi-dimensional array. But the lack of adjustable, fill-pointer, diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 9fadaf9..f3a08f0 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -875,7 +875,20 @@ (:fill-pointer t) (:displaced-to (or array null)) (:displaced-index-offset index)) - array (flushable)) + array (flushable explicit-check)) + +(defknown %make-array ((or index list) + (unsigned-byte #.sb!vm:n-widetag-bits) + (unsigned-byte 16) + &key + (:element-type type-specifier) + (:initial-element t) + (:initial-contents t) + (:adjustable t) + (:fill-pointer t) + (:displaced-to (or array null)) + (:displaced-index-offset index)) + array (flushable)) (defknown vector (&rest t) simple-vector (flushable)) -- 1.7.10.4