From 0c0d8909984b5b33bb6b59b350b2d5cee6dc1715 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 30 Sep 2010 07:03:25 +0000 Subject: [PATCH] 1.0.43.1: better handling of complex array types in fill-pointer ops Derive the fact that the result of MAKE-ARRAY is (NOT SIMPLE-ARRAY) when possible. Instead of DEFOPTIMIZERs asserting that various functions need a complex array, put the right type in the DEFKNOWNs instead. Also remove a few of redundant typechecks: FILL-POINTER -> ARRAY-HAS-FILL-POINTER call path does all the checks any of the other operations need. Fixes lp#309130. --- NEWS | 6 ++- package-data-list.lisp-expr | 4 +- src/code/array.lisp | 8 ++-- src/compiler/array-tran.lisp | 92 ++++++++++++++++--------------------- src/compiler/fndb.lisp | 16 ++++--- src/compiler/generic/vm-type.lisp | 3 ++ tests/compiler.pure.lisp | 27 +++++++++++ version.lisp-expr | 2 +- 8 files changed, 92 insertions(+), 66 deletions(-) diff --git a/NEWS b/NEWS index 33b7441..16b575e 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- -changes in sbcl-1.0.43 relative to sbcl-1.0.42 +changes relative to sbcl-1.0.43: + * bug fix: compiler failed to derive the result-type of MAKE-ARRAY as + (AND VECTOR (NOT SIMPLE-ARRAY)) when appropriate. (lp#309130) + +changes in sbcl-1.0.43 relative to sbcl-1.0.42: * incompatible change: FD-STREAMS no longer participate in the serve-event event-loop by default. (lp#316072) ** In addition to streams created by explicit calls to MAKE-FD-STREAM this diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 07adf1c..2e60e4a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1461,7 +1461,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "ANSI-STREAM-INPUT-STREAM-P" "ANSI-STREAM-MISC" "ANSI-STREAM-N-BIN" "ANSI-STREAM-OPEN-STREAM-P" "ANSI-STREAM-OUT" "ANSI-STREAM-SOUT" - "ANSI-STREAM-OUTPUT-STREAM-P" "LIST-TO-VECTOR*" + "ANSI-STREAM-OUTPUT-STREAM-P" + "COMPLEX-VECTOR" + "LIST-TO-VECTOR*" "LOGICAL-HOST" "LOGICAL-HOST-DESIGNATOR" #!+long-float "LONG-FLOAT-EXPONENT" #!+long-float "LONG-FLOAT-EXP-BITS" diff --git a/src/code/array.lisp b/src/code/array.lisp index 8f3f133..565c086 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -12,7 +12,7 @@ (in-package "SB!IMPL") #!-sb-fluid -(declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p +(declaim (inline adjustable-array-p array-displacement)) ;;;; miscellaneous accessor functions @@ -755,6 +755,7 @@ of specialized arrays is supported." ;;;; fill pointer frobbing stuff +(declaim (inline array-has-fill-pointer-p)) (defun array-has-fill-pointer-p (array) #!+sb-doc "Return T if the given ARRAY has a fill pointer, or NIL otherwise." @@ -777,6 +778,7 @@ of specialized arrays is supported." :format-control "~S is not an array with a fill pointer." :format-arguments (list vector))))) +(declaim (inline fill-pointer)) (defun fill-pointer (vector) #!+sb-doc "Return the FILL-POINTER of the given VECTOR." @@ -804,7 +806,6 @@ of specialized arrays is supported." to NEW-EL, and increment the fill pointer by one. If the fill pointer is too large, NIL is returned, otherwise the index of the pushed element is returned." - (declare (vector array)) (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (cond ((= fill-pointer (%array-available-elements array)) @@ -822,7 +823,7 @@ of specialized arrays is supported." (let ((length (length vector))) (min (1+ length) (- array-dimension-limit length))))) - (declare (vector vector) (fixnum min-extension)) + (declare (fixnum min-extension)) (let ((fill-pointer (fill-pointer vector))) (declare (fixnum fill-pointer)) (when (= fill-pointer (%array-available-elements vector)) @@ -837,7 +838,6 @@ of specialized arrays is supported." #!+sb-doc "Decrease the fill pointer by 1 and return the element pointed to by the new fill pointer." - (declare (vector array)) (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (if (zerop fill-pointer) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index a3cea57..efa768b 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -122,14 +122,6 @@ (lexenv-policy (node-lexenv (lvar-dest new-value)))))) (lvar-type new-value)) -(defun assert-array-complex (array) - (assert-lvar-type - array - (make-array-type :complexp t - :element-type *wild-type*) - (lexenv-policy (node-lexenv (lvar-dest array)))) - nil) - ;;; Return true if ARG is NIL, or is a constant-lvar whose ;;; value is NIL, false otherwise. (defun unsupplied-or-nil (arg) @@ -137,6 +129,12 @@ (or (not arg) (and (constant-lvar-p arg) (not (lvar-value arg))))) + +(defun supplied-and-true (arg) + (and arg + (constant-lvar-p arg) + (lvar-value arg) + t)) ;;;; DERIVE-TYPE optimizers @@ -271,51 +269,39 @@ (defoptimizer (make-array derive-type) ((dims &key initial-element element-type initial-contents adjustable fill-pointer displaced-index-offset displaced-to)) - (let ((simple (and (unsupplied-or-nil adjustable) - (unsupplied-or-nil displaced-to) - (unsupplied-or-nil fill-pointer)))) - (or (careful-specifier-type - `(,(if simple 'simple-array 'array) - ,(cond ((not element-type) t) - ((constant-lvar-p element-type) - (let ((ctype (careful-specifier-type - (lvar-value element-type)))) - (cond - ((or (null ctype) (unknown-type-p ctype)) '*) - (t (sb!xc:upgraded-array-element-type - (lvar-value element-type)))))) - (t - '*)) - ,(cond ((constant-lvar-p dims) - (let* ((val (lvar-value dims)) - (cdims (if (listp val) val (list val)))) - (if simple - cdims - (length cdims)))) - ((csubtypep (lvar-type dims) - (specifier-type 'integer)) - '(*)) - (t - '*)))) - (specifier-type 'array)))) - -;;; Complex array operations should assert that their array argument -;;; is complex. In SBCL, vectors with fill-pointers are complex. -(defoptimizer (fill-pointer derive-type) ((vector)) - (assert-array-complex vector)) -(defoptimizer (%set-fill-pointer derive-type) ((vector index)) - (declare (ignorable index)) - (assert-array-complex vector)) - -(defoptimizer (vector-push derive-type) ((object vector)) - (declare (ignorable object)) - (assert-array-complex vector)) -(defoptimizer (vector-push-extend derive-type) - ((object vector &optional index)) - (declare (ignorable object index)) - (assert-array-complex vector)) -(defoptimizer (vector-pop derive-type) ((vector)) - (assert-array-complex vector)) + (let* ((simple (and (unsupplied-or-nil adjustable) + (unsupplied-or-nil displaced-to) + (unsupplied-or-nil fill-pointer))) + (spec + (or `(,(if simple 'simple-array 'array) + ,(cond ((not element-type) t) + ((constant-lvar-p element-type) + (let ((ctype (careful-specifier-type + (lvar-value element-type)))) + (cond + ((or (null ctype) (unknown-type-p ctype)) '*) + (t (sb!xc:upgraded-array-element-type + (lvar-value element-type)))))) + (t + '*)) + ,(cond ((constant-lvar-p dims) + (let* ((val (lvar-value dims)) + (cdims (if (listp val) val (list val)))) + (if simple + cdims + (length cdims)))) + ((csubtypep (lvar-type dims) + (specifier-type 'integer)) + '(*)) + (t + '*))) + '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)))) ;;;; constructors diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 9f43517..0c80ebf 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -875,13 +875,16 @@ (defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable)) -(defknown fill-pointer (vector) index (foldable unsafely-flushable)) -(defknown vector-push (t vector) (or index null) () +(defknown fill-pointer (complex-vector) index + (unsafely-flushable explicit-check)) +(defknown vector-push (t complex-vector) (or index null) + (explicit-check) :destroyed-constant-args (nth-constant-args 2)) -(defknown vector-push-extend (t vector &optional (and index (integer 1))) - index () +(defknown vector-push-extend (t complex-vector &optional (and index (integer 1))) index + (explicit-check) :destroyed-constant-args (nth-constant-args 2)) -(defknown vector-pop (vector) t () +(defknown vector-pop (complex-vector) t + (explicit-check) :destroyed-constant-args (nth-constant-args 1)) ;;; FIXME: complicated :DESTROYED-CONSTANT-ARGS @@ -1540,7 +1543,8 @@ (defknown %set-symbol-plist (symbol list) list (unsafe)) (defknown %setnth (unsigned-byte list t) t (unsafe) :destroyed-constant-args (nth-constant-args 2)) -(defknown %set-fill-pointer (vector index) index (unsafe) +(defknown %set-fill-pointer (complex-vector index) index + (unsafe explicit-check) :destroyed-constant-args (nth-constant-args 1)) ;;;; ALIEN and call-out-to-C stuff diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 4f7c4a7..997aa8e 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -96,6 +96,9 @@ (types `(simple-array ,type ,dims)))) (types))) +(sb!xc:deftype complex-vector (&optional element-type length) + `(and (vector ,element-type ,length) (not simple-array))) + ;;; Return the symbol that describes the format of FLOAT. (declaim (ftype (function (float) symbol) float-format-name)) (defun float-format-name (x) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index ff5d41b..531acc1 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3531,3 +3531,30 @@ (* b (z b c)))) (loop for i below 10 do (setf a (z a a))))))) + +(with-test (:name :bug-309130) + (assert (eq :warning + (handler-case + (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (declare (optimize (debug 0))) + (declare (type vector x)) + (list (fill-pointer x) (svref x 1)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push-extend (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning))))) diff --git a/version.lisp-expr b/version.lisp-expr index 5288db4..0c20028 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.43" +"1.0.43.1" -- 1.7.10.4