From 091f0c20d4661994be7be4cc707c2aba4ef86418 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 5 Jun 2009 14:25:29 +0000 Subject: [PATCH] 1.0.29.4: still more MAKE-ARRAY work * Re-order the three MAKE-ARRAY deftransform, so that the more specific ones are tried before the general one -- which allows stack allocation in more the remaining cases that used to fail (I don't know why I blamed VECTOR-FILL* for that before.) * When constant splicing for initial-element in TRANSFORM-MAKE-ARRAY-VECTOR didn't quote it, leading to lossiness with symbols or lists as constant initial-elements. (Bug masked earlier by the mis-ordering of the deftransforms.) * In the final leg of TRANSFORM-MAKE-ARRAY-VECTOR also eliminate the possible :INITIAL-ELEMENT keyword. * When eliminating keywords from a MAKE-ARRAY call, don't flush the lvars before checking that all of them can be eliminated. (Also masked by the earlier mis-ordering.) --- src/compiler/array-tran.lisp | 150 +++++++++++++++++++------------------- src/compiler/ir1util.lisp | 7 +- tests/compiler.impure.lisp | 20 +++-- tests/dynamic-extent.impure.lisp | 4 - version.lisp-expr | 2 +- 5 files changed, 96 insertions(+), 87 deletions(-) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 4c4ec20..4c0688d 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -351,7 +351,7 @@ call 1 '((:element-type element-type) (:initial-element initial-element)))) (init (if (constant-lvar-p initial-element) - (lvar-value initial-element) + (list 'quote (lvar-value initial-element)) 'initial-element))) `(lambda (length ,@parameters) (declare (ignorable ,@parameters)) @@ -380,24 +380,74 @@ default-initial-element elt-spec))) (let ((parameters (eliminate-keyword-args - call 1 '((:element-type element-type))))) + call 1 '((:element-type element-type) + (:initial-element initial-element))))) `(lambda (length ,@parameters) (declare (ignorable ,@parameters)) ,alloc-form)))))) -(deftransform make-array ((dims &key - element-type initial-element initial-contents) - (integer &key - (:element-type (constant-arg *)) - (:initial-element *) - (:initial-contents *)) - * - :node call) - (transform-make-array-vector dims - element-type - initial-element - initial-contents - call)) +;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least +;;; specific must come first, otherwise suboptimal transforms will result for +;;; some forms. + +(deftransform make-array ((dims &key initial-element element-type + adjustable fill-pointer) + (t &rest *)) + (when (null initial-element) + (give-up-ir1-transform)) + (let* ((eltype (cond ((not element-type) t) + ((not (constant-lvar-p element-type)) + (give-up-ir1-transform + "ELEMENT-TYPE is not constant.")) + (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)) + ,@(when 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))) + creation-form) + (t + ;; error checking for target, disabled on the host because + ;; (CTYPE-OF #\Null) is not possible. + #-sb-xc-host + (when (constant-lvar-p initial-element) + (let ((value (lvar-value initial-element))) + (cond + ((not (ctypep value (sb!vm:saetp-ctype saetp))) + ;; this case will cause an error at runtime, so we'd + ;; better WARN about it now. + (warn 'array-initial-element-mismatch + :format-control "~@<~S is not a ~S (which is the ~ + ~S of ~S).~@:>" + :format-arguments + (list + value + (type-specifier (sb!vm:saetp-ctype saetp)) + 'upgraded-array-element-type + eltype))) + ((not (ctypep value eltype-type)) + ;; this case will not cause an error at runtime, but + ;; it's still worth STYLE-WARNing about. + (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))))) ;;; The list type restriction does not ensure that the result will be a ;;; multi-dimensional array. But the lack of adjustable, fill-pointer, @@ -474,64 +524,18 @@ dims)) (truly-the ,spec header))))))) -(deftransform make-array ((dims &key initial-element element-type - adjustable fill-pointer) - (t &rest *)) - (when (null initial-element) - (give-up-ir1-transform)) - (let* ((eltype (cond ((not element-type) t) - ((not (constant-lvar-p element-type)) - (give-up-ir1-transform - "ELEMENT-TYPE is not constant.")) - (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)) - ,@(when 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))) - creation-form) - (t - ;; error checking for target, disabled on the host because - ;; (CTYPE-OF #\Null) is not possible. - #-sb-xc-host - (when (constant-lvar-p initial-element) - (let ((value (lvar-value initial-element))) - (cond - ((not (ctypep value (sb!vm:saetp-ctype saetp))) - ;; this case will cause an error at runtime, so we'd - ;; better WARN about it now. - (warn 'array-initial-element-mismatch - :format-control "~@<~S is not a ~S (which is the ~ - ~S of ~S).~@:>" - :format-arguments - (list - value - (type-specifier (sb!vm:saetp-ctype saetp)) - 'upgraded-array-element-type - eltype))) - ((not (ctypep value eltype-type)) - ;; this case will not cause an error at runtime, but - ;; it's still worth STYLE-WARNing about. - (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))))) +(deftransform make-array ((dims &key element-type initial-element initial-contents) + (integer &key + (:element-type (constant-arg *)) + (:initial-element *) + (:initial-contents *)) + * + :node call) + (transform-make-array-vector dims + element-type + initial-element + initial-contents + call)) ;;;; miscellaneous properties of arrays diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index d79da6b..19e0adb 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1637,7 +1637,8 @@ is :ANY, the function name is not checked." (all (combination-args call)) (new-args (reverse (subseq all 0 n-positional))) (key-args (subseq all n-positional)) - (parameters nil)) + (parameters nil) + (flushed-keys nil)) (loop while key-args do (let* ((key (pop key-args)) (val (pop key-args)) @@ -1647,10 +1648,12 @@ is :ANY, the function name is not checked." (spec (or (assoc keyword specs :test #'eq) (give-up-ir1-transform)))) (push val new-args) - (flush-dest key) + (push key flushed-keys) (push (second spec) parameters) ;; In case of duplicate keys. (setf (second spec) (gensym)))) + (dolist (key flushed-keys) + (flush-dest key)) (setf (combination-args call) (reverse new-args)) (reverse parameters))) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index d5ec1ca..bda6fb3 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1086,13 +1086,19 @@ *hairy-progv-var*)))) (with-test (:name :fill-complex-single-float) - (assert (eql #c(-1.0 2.0) - (aref (funcall - (lambda () - (make-array 2 - :element-type '(complex single-float) - :initial-element #c(-1.0 2.0)))) - 0)))) + (assert (every (lambda (x) (eql x #c(-1.0 -2.0))) + (funcall + (lambda () + (make-array 2 + :element-type '(complex single-float) + :initial-element #c(-1.0 -2.0))))))) + +(with-test (:name :make-array-symbol-as-initial-element) + (assert (every (lambda (x) (eq x 'a)) + (funcall + (compile nil + `(lambda () + (make-array 12 :initial-element 'a))))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 3620c6d..9e77321 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -181,9 +181,6 @@ (true v) nil)) -;;; Unfortunately VECTOR-FILL* conses right now, so this one -;;; doesn't pass yet. -#+nil (defun-with-dx make-array-on-stack-5 () (let ((v (make-array 3 :initial-element 12 :element-type t))) (declare (sb-int:truly-dynamic-extent v)) @@ -535,7 +532,6 @@ (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5))) (assert-no-consing (make-array-on-stack-3 9 8 7)) (assert-no-consing (make-array-on-stack-4)) - #+nil (assert-no-consing (make-array-on-stack-5)) (assert-no-consing (vector-on-stack :x :y))) (#+raw-instance-init-vops assert-no-consing diff --git a/version.lisp-expr b/version.lisp-expr index 4c4695b..326fa46 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.29.3" +"1.0.29.4" -- 1.7.10.4