[Bug-openmcl] displaced array patch
Gary Byers
gb at clozure.com
Thu Feb 19 12:03:05 MST 2004
Thanks; this looks right ...
(The TEMP-P flag hasn't been used since 68K MCL ...)
On Thu, 19 Feb 2004, bryan o'connor wrote:
> this patch does the following:
>
> 1. adds $arh_exp_disp_bit to arrayH/vectorH flags to indicate
> whether the array was explicitly or implicitly displaced. (i
> moved $arh_simple_bit so that the two displaced bits would be
> next to each other.)
>
> 2. adds an optional explicitp arg to %make-displaced-array and
> %displace-array to properly set (or clear) the bit in flags.
> (adjust-array of a displaced-array has to clear the bit if
> explicit displacement isn't again requested.)
>
> 3. changes #'array-displacement to check the bit.
>
> 4. properly sets fill-pointer for adjust-array. (this is the
> same patch from an earlier mail.)
>
> %make-displaced-array had an ignored optional arg called temp-p.
> since no one seemed to use it, i replaced it with explicitp. it
> could just as easily be left in.
>
> the adjust-array tests had pushed my build tree back into triple
> digits.. with this, it's back to good ol' 66.
>
>
> ...bryan
>
>
> Index: compiler/optimizers.lisp
> ===================================================================
> RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/compiler/optimizers.lisp,v
> retrieving revision 1.6
> diff -u -r1.6 optimizers.lisp
> --- compiler/optimizers.lisp 25 Jan 2004 21:59:15 -0000 1.6
> +++ compiler/optimizers.lisp 19 Feb 2004 09:57:24 -0000
> @@ -627,7 +627,7 @@
> `((,dims-var ,dims)))))
>
> `(let ,let-list
> - (%make-displaced-array ,dims-var , at call-list))))
> + (%make-displaced-array ,dims-var , at call-list t))))
>
> (defun comp-make-uarray (dims keys subtype)
> (let* ((call-list (make-list 6))
>
> Index: level-0/l0-array.lisp
> ===================================================================
> RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-0/l0-array.lisp,v
> retrieving revision 1.8
> diff -u -r1.8 l0-array.lisp
> --- level-0/l0-array.lisp 29 Jan 2004 17:45:21 -0000 1.8
> +++ level-0/l0-array.lisp 19 Feb 2004 09:57:25 -0000
> @@ -96,10 +96,12 @@
> (declare (fixnum typecode))
> (if (< typecode ppc32::min-array-subtag)
> (report-bad-arg array 'array)
> - (if (<= typecode ppc32::subtag-vectorH)
> - (values (%svref array ppc32::arrayH.data-vector-cell)
> - (%svref array ppc32::arrayH.displacement-cell))
> - (values nil 0)))))
> + (if (and (<= typecode ppc32::subtag-vectorH)
> + (logbitp $arh_exp_disp_bit
> + (the fixnum (%svref array
> ppc32::vectorH.flags-cell))))
> + (values (%svref array ppc32::arrayH.data-vector-cell)
> + (%svref array ppc32::arrayH.displacement-cell))
> + (values nil 0)))))
>
> (defun array-data-and-offset (array)
> (let* ((typecode (typecode array)))
>
> Index: level-1/l1-aprims.lisp
> ===================================================================
> RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-1/l1-aprims.lisp,v
> retrieving revision 1.7
> diff -u -r1.7 l1-aprims.lisp
> --- level-1/l1-aprims.lisp 25 Jan 2004 22:08:29 -0000 1.7
> +++ level-1/l1-aprims.lisp 19 Feb 2004 09:57:26 -0000
> @@ -542,8 +542,8 @@
>
>
> (defun %make-displaced-array (dimensions displaced-to
> - &optional fill adjustable
> offset temp-p)
> - (declare (ignore temp-p))
> + &optional fill adjustable
> + offset explicitp)
> (if offset
> (unless (and (fixnump offset) (>= (the fixnum offset) 0))
> (setq offset (require-type offset '(and fixnum (integer 0 *)))))
> @@ -563,6 +563,8 @@
> (real-offset offset)
> (flags 0))
> (declare (fixnum disp-size rank flags vect-subtype real-offset))
> + (when explicitp
> + (setq flags (bitset $arh_exp_disp_bit flags)))
> (if (not (fixnump new-size))(error "Bad array dimensions ~s."
> dimensions))
> (locally (declare (fixnum new-size))
> ; (when (> (+ offset new-size) disp-size) ...), but don't cons
> bignums
>
> Index: level-1/l1-utils.lisp
> ===================================================================
> RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/level-1/l1-utils.lisp,v
> retrieving revision 1.12
> diff -u -r1.12 l1-utils.lisp
> --- level-1/l1-utils.lisp 7 Feb 2004 21:58:13 -0000 1.12
> +++ level-1/l1-utils.lisp 19 Feb 2004 09:57:27 -0000
> @@ -1419,7 +1419,7 @@
> (error "The ~S array ~S is not of ~S ~S"
> :displaced-to displaced-to :element-type element-type))
> (%make-displaced-array dims displaced-to
> - fill-pointer adjustable
> displaced-index-offset))
> + fill-pointer adjustable
> displaced-index-offset t))
> (t
> (when displaced-index-offset
> (error "Cannot specify ~S for non-displaced-array"
> :displaced-index-offset))
>
> Index: lib/arrays-fry.lisp
> ===================================================================
> RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/lib/arrays-fry.lisp,v
> retrieving revision 1.5
> diff -u -r1.5 arrays-fry.lisp
> --- lib/arrays-fry.lisp 18 Jan 2004 03:53:09 -0000 1.5
> +++ lib/arrays-fry.lisp 19 Feb 2004 09:57:28 -0000
> @@ -232,7 +232,8 @@
> (when (integerp dims)(setq dims (list dims))) ; because
> %displace-array wants the list
> (if (neq (list-length dims)(array-rank array))
> (error "~S has wrong rank for adjusting to dimensions ~S" array
> dims))
> - (let ((size 1))
> + (let ((size 1)
> + (explicitp nil))
> (dolist (dim dims)
> (when (< dim 0)(report-bad-arg dims '(integer 0 *)))
> (setq size (* size dim)))
> @@ -254,7 +255,9 @@
> displaced-to
> displaced-index-offset
> nil
> - fill-pointer
> + (or fill-pointer
> + (and
> (array-has-fill-pointer-p array)
> + (fill-pointer array)))
> initial-element
> initial-element-p
> initial-contents
> initial-contents-p
> size)))
> @@ -283,9 +286,10 @@
> (do* ((vec displaced-to (displaced-array-p vec)))
> ((null vec) ())
> (when (eq vec array)
> - (error "Array cannot be displaced to itself."))))
> + (error "Array cannot be displaced to itself.")))
> + (setq explicitp t))
> (T
> - (setq displaced-to ( %alloc-misc size subtype))
> + (setq displaced-to (%alloc-misc size subtype))
> (cond (initial-element-p
> (dotimes (i (the fixnum size)) (uvset displaced-to i
> initial-element)))
> (initial-contents-p
> @@ -296,7 +300,7 @@
> ((not initial-contents-p)
> (multiple-value-bind (vec offs)
> (array-data-and-offset array)
> (init-array-data vec offs (array-dimensions array)
> displaced-to 0 dims))))))
> - (%displace-array array dims size displaced-to (or
> displaced-index-offset 0))))
> + (%displace-array array dims size displaced-to (or
> displaced-index-offset 0) explicitp)))
> (when fill-pointer-p
> (cond
> ((eq fill-pointer t)
> @@ -335,7 +339,7 @@
>
> ; only caller is adjust-array
>
> -(defun %displace-array (array dims size data offset)
> +(defun %displace-array (array dims size data offset explicitp)
> (let* ((typecode (typecode array))
> (array-p (eql typecode ppc32::subtag-arrayH))
> (vector-p (eql typecode ppc32::subtag-vectorH)))
> @@ -353,6 +357,10 @@
> (if (> (the fixnum (typecode data)) ppc32::subtag-vectorH)
> (bitclr $arh_disp_bit flags)
> (bitset $arh_disp_bit flags)))
> + (setf (%svref array ppc32::vectorH.flags-cell)
> + (if explicitp
> + (bitset $arh_exp_disp_bit flags)
> + (bitclr $arh_exp_disp_bit flags)))
> (setf (%svref array ppc32::arrayH.data-vector-cell) data)
> (if array-p
> (progn
>
> Index: library/lispequ.lisp
> ===================================================================
> RCS file: /usr/local/tmpcvs/ccl-0.14-dev/ccl/library/lispequ.lisp,v
> retrieving revision 1.9
> diff -u -r1.9 lispequ.lisp
> --- library/lispequ.lisp 1 Feb 2004 02:54:12 -0000 1.9
> +++ library/lispequ.lisp 19 Feb 2004 09:57:29 -0000
> @@ -169,7 +169,8 @@
> (defconstant $arh_adjp_bit 7) ;adjustable-p
> (defconstant $arh_fill_bit 6) ;fill-pointer-p
> (defconstant $arh_disp_bit 5) ;displaced to another array header -p
> -(defconstant $arh_simple_bit 4) ;not adjustable, no fill-pointer and
> +(defconstant $arh_exp_disp_bit 4) ;explicitly displaced -p
> +(defconstant $arh_simple_bit 3) ;not adjustable, no fill-pointer and
> ; not user-visibly displaced -p
>
> (def-accessors (lexical-environment) %svref
>
> _______________________________________________
> Bug-openmcl mailing list
> Bug-openmcl at clozure.com
> http://clozure.com/mailman/listinfo/bug-openmcl
>
>
More information about the Bug-openmcl
mailing list