[Git][cmucl/cmucl][master] 2 commits: Fix data-vector-set-c for unsigned-byte 1, 2, and 4

[Raymond Toy]

Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
3c373507 by Raymond Toy at 2015-10-16T21:33:50Z
Fix data-vector-set-c for unsigned-byte 1, 2, and 4

For simple-arrays of 1, 2, or 4-bit elements, data-vector-set-c was
incorrectly merging the new value into the array when the index is a
multiple of the number of elements per (32-bit) word.  Thus, for 4-bit
elements, the new value was not merged in when the index is a multiple
of 8.  In these cases, there's no need to shift the array value or the
new value to move them into the correct place.  When the shift is
zero, the code accidentally removed the part that merges in the new
value.

Fix #10.

- - - - -
b239ce3f by Raymond Toy at 2015-10-16T21:35:16Z
Add tests for issue #10.

Covers 1, 2, and 4-bit arrays.

Manually verified that the cmucl 21a fails these tests, as expected,
when the index is a multiple of the number of elements per 32-bit
word.

- - - - -


2 changed files:

- src/compiler/x86/array.lisp
- tests/issues.lisp


Changes:

=====================================
src/compiler/x86/array.lisp
=====================================
--- a/src/compiler/x86/array.lisp
+++ b/src/compiler/x86/array.lisp
@@ -288,9 +288,10 @@
 	       (unsigned-reg
 		(let ((shift (* extra ,bits)))
 		  (unless (zerop shift)
-		    (inst ror old shift)
-		    (inst and old (lognot ,(1- (ash 1 bits))))
-		    (inst or old value)
+		    (inst ror old shift))
+		  (inst and old (lognot ,(1- (ash 1 bits))))
+		  (inst or old value)
+		  (unless (zerop shift)
 		    (inst rol old shift)))))
 	     (inst mov (make-ea :dword :base object
 				:disp (- (* (+ word vector-data-offset) word-bytes)


=====================================
tests/issues.lisp
=====================================
--- a/tests/issues.lisp
+++ b/tests/issues.lisp
@@ -119,3 +119,84 @@
 		(let ((z (list 1 2)))
 		  (flet ((frob (x) (cdr x)))
 		    (xpop (frob z))))))
+
+(define-test issue.10-unsigned-byte-4
+    (:tag :issues)
+  (macrolet
+      ((compiled-test-function (constant-index)
+	 ;; Compile the test function from the issue.
+	 (compile nil `(lambda (v x)
+			 (declare (type (integer 0 5) v)
+				  (optimize (safety 0)))
+			 (setf (aref (the (simple-array (integer 0 5) (1)) x)
+				     ,constant-index)
+			       (the (integer 0 5) v))
+			 x)))
+       (make-tests ()
+	 ;; Create a set of tests for a set of fixed constant indices,
+	 ;; one test for each constant index from 0 to 15.
+	 (let (tests)
+	   (dotimes (k 16)
+	     (push 
+	      `(assert-equal 1
+			     (aref (funcall (compiled-test-function ,k)
+					    1
+					    (make-array 16 :element-type '(integer 0 5) :initial-element 0))
+				   ,k))
+	      tests))
+	   `(progn ,@(nreverse tests)))))
+    (make-tests)))
+
+(define-test issue.10-unsigned-byte-2
+    (:tag :issues)
+  (macrolet
+      ((compiled-test-function (constant-index)
+	 ;; Compile the test function from the issue.
+	 (compile nil `(lambda (v x)
+			 (declare (type (integer 0 2) v)
+				  (optimize (safety 0)))
+			 (setf (aref (the (simple-array (integer 0 2) (1)) x)
+				     ,constant-index)
+			       (the (integer 0 2) v))
+			 x)))
+       (make-tests ()
+	 ;; Create a set of tests for a set of fixed constant indices,
+	 ;; one test for each constant index from 0 to 31.
+	 (let (tests)
+	   (dotimes (k 32)
+	     (push 
+	      `(assert-equal 1
+			     (aref (funcall (compiled-test-function ,k)
+					    1
+					    (make-array 32 :element-type '(integer 0 2) :initial-element 0))
+				   ,k))
+	      tests))
+	   `(progn ,@(nreverse tests)))))
+    (make-tests)))
+
+(define-test issue.10-unsigned-byte-1
+    (:tag :issues)
+  (macrolet
+      ((compiled-test-function (constant-index)
+	 ;; Compile the test function from the issue.
+	 (compile nil `(lambda (v x)
+			 (declare (type (integer 0 1) v)
+				  (optimize (safety 0)))
+			 (setf (aref (the (simple-array (integer 0 1) (1)) x)
+				     ,constant-index)
+			       (the (integer 0 1) v))
+			 x)))
+       (make-tests ()
+	 ;; Create a set of tests for a set of fixed constant indices,
+	 ;; one test for each constant index from 0 to 31.
+	 (let (tests)
+	   (dotimes (k 64)
+	     (push 
+	      `(assert-equal 1
+			     (aref (funcall (compiled-test-function ,k)
+					    1
+					    (make-array 64 :element-type '(integer 0 1) :initial-element 0))
+				   ,k))
+	      tests))
+	   `(progn ,@(nreverse tests)))))
+    (make-tests)))



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/704b1ae0c0a023bf315a9652410a59d2bd8f375b...b239ce3f44b62821701e3447437705d3d914a5b4
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20151017/fd84422b/attachment.html>