[Bug-openmcl] displaced array patch
bryan o'connor
bryan-openmcl at lunch.org
Thu Feb 19 03:25:22 MST 2004
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
More information about the Bug-openmcl
mailing list