Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler array-tran.lisp, 1.98, 1.99 fndb.lisp, 1.172, 1.173
|
From: Nikodemus S. <de...@us...> - 2010-09-30 07:03:34
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv32557/src/compiler Modified Files: array-tran.lisp fndb.lisp Log Message: 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. Index: array-tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v retrieving revision 1.98 retrieving revision 1.99 diff -u -d -r1.98 -r1.99 --- array-tran.lisp 1 Sep 2010 11:53:17 -0000 1.98 +++ array-tran.lisp 30 Sep 2010 07:03:25 -0000 1.99 @@ -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 Index: fndb.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v retrieving revision 1.172 retrieving revision 1.173 diff -u -d -r1.172 -r1.173 --- fndb.lisp 1 Sep 2010 15:27:07 -0000 1.172 +++ fndb.lisp 30 Sep 2010 07:03:25 -0000 1.173 @@ -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 |