From 744ca6f4e37f7108a98ff8043a7c85d478fc272e Mon Sep 17 00:00:00 2001
From: cshapiro <cshapiro>
Date: Thu, 17 Apr 2008 09:05:02 +0000
Subject: [PATCH] Add a partial setter macro for the x86 and use it to
 implement the various stores to 8-bit and 16-bit specialized arrays.

---
 compiler/x86/array.lisp  | 186 ++-------------------------------------
 compiler/x86/macros.lisp |  46 +++++++++-
 2 files changed, 50 insertions(+), 182 deletions(-)

diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp
index 6004a4f24..7b2068cad 100644
--- a/compiler/x86/array.lisp
+++ b/compiler/x86/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.21 2008/04/16 09:06:37 cshapiro Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.22 2008/04/17 09:05:02 cshapiro Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -133,7 +133,10 @@
   `(progn
      (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
        ,size ,signed vector-data-offset other-pointer-type ,scs
-       ,element-type data-vector-ref)))
+       ,element-type data-vector-ref)
+     (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+       ,size vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-set)))
 
 ); eval-when (compile eval)
 
@@ -1081,97 +1084,6 @@
 
 
 
-;;; unsigned-byte-8
-
-(define-vop (data-vector-set/simple-array-unsigned-byte-8)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (index :scs (unsigned-reg) :to (:eval 0))
-	 (value :scs (unsigned-reg signed-reg) :target eax))
-  (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
-  (:temporary (:sc unsigned-reg :offset eax-offset :target result
-		   :from (:argument 2) :to (:result 0))
-	      eax)
-  (:results (result :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 5
-    (move eax value)
-    (inst mov (make-ea :byte :base object :index index :scale 1
-		       :disp (- (* vector-data-offset word-bytes)
-				other-pointer-type))
-	  al-tn)
-    (move result eax)))
-
-
-(define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (value :scs (unsigned-reg signed-reg) :target eax))
-  (:info index)
-  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
-	      positive-fixnum)
-  (:temporary (:sc unsigned-reg :offset eax-offset :target result
-		   :from (:argument 1) :to (:result 0))
-	      eax)
-  (:results (result :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 4
-    (move eax value)
-    (inst mov (make-ea :byte :base object
-		       :disp (- (+ (* vector-data-offset word-bytes) index)
-				other-pointer-type))
-	  al-tn)
-    (move result eax)))
-
-
-;;; unsigned-byte-16
-
-(define-vop (data-vector-set/simple-array-unsigned-byte-16)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (index :scs (unsigned-reg) :to (:eval 0))
-	 (value :scs (unsigned-reg signed-reg) :target eax))
-  (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
-  (:temporary (:sc unsigned-reg :offset eax-offset :target result
-		   :from (:argument 2) :to (:result 0))
-	      eax)
-  (:results (result :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 5
-    (move eax value)
-    (inst mov (make-ea :word :base object :index index :scale 2
-		       :disp (- (* vector-data-offset word-bytes)
-				other-pointer-type))
-	  ax-tn)
-    (move result eax)))
-
-
-(define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (value :scs (unsigned-reg signed-reg) :target eax))
-  (:info index)
-  (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))
-	      positive-fixnum)
-  (:temporary (:sc unsigned-reg :offset eax-offset :target result
-		   :from (:argument 1) :to (:result 0))
-	      eax)
-  (:results (result :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 4
-    (move eax value)
-    (inst mov (make-ea :word :base object
-		       :disp (- (+ (* vector-data-offset word-bytes)
-				   (* 2 index))
-				other-pointer-type))
-	  ax-tn)
-    (move result eax)))
-
-
 ;;; simple-string
 
 (define-vop (data-vector-ref/simple-string)
@@ -1249,94 +1161,6 @@
    (move result value)))
 
 
-;;; signed-byte-8
-
-(define-vop (data-vector-set/simple-array-signed-byte-8)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (index :scs (unsigned-reg) :to (:eval 0))
-	 (value :scs (signed-reg) :target eax))
-  (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
-  (:temporary (:sc unsigned-reg :offset eax-offset :target result
-		   :from (:argument 2) :to (:result 0))
-	      eax)
-  (:results (result :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 5
-    (move eax value)
-    (inst mov (make-ea :byte :base object :index index :scale 1
-		       :disp (- (* vector-data-offset word-bytes)
-				other-pointer-type))
-	  al-tn)
-    (move result eax)))
-
-(define-vop (data-vector-set-c/simple-array-signed-byte-8)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (value :scs (signed-reg) :target eax))
-  (:info index)
-  (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
-	      tagged-num)
-  (:temporary (:sc unsigned-reg :offset eax-offset :target result
-		   :from (:argument 1) :to (:result 0))
-	      eax)
-  (:results (result :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 4
-    (move eax value)
-    (inst mov (make-ea :byte :base object
-		       :disp (- (+ (* vector-data-offset word-bytes) index)
-				other-pointer-type))
-	  al-tn)
-    (move result eax)))
-
-;;; signed-byte-16
-
-(define-vop (data-vector-set/simple-array-signed-byte-16)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (index :scs (unsigned-reg) :to (:eval 0))
-	 (value :scs (signed-reg) :target eax))
-  (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
-  (:temporary (:sc signed-reg :offset eax-offset :target result
-		   :from (:argument 2) :to (:result 0))
-	      eax)
-  (:results (result :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 5
-    (move eax value)
-    (inst mov (make-ea :word :base object :index index :scale 2
-		       :disp (- (* vector-data-offset word-bytes)
-				other-pointer-type))
-	  ax-tn)
-    (move result eax)))
-
-(define-vop (data-vector-set-c/simple-array-signed-byte-16)
-  (:translate data-vector-set)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg) :to (:eval 0))
-	 (value :scs (signed-reg) :target eax))
-  (:info index)
-  (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
-  (:temporary (:sc signed-reg :offset eax-offset :target result
-		   :from (:argument 1) :to (:result 0))
-	      eax)
-  (:results (result :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 4
-    (move eax value)
-    (inst mov
-	  (make-ea :word :base object
-		   :disp (- (+ (* vector-data-offset word-bytes)
-			       (* 2 index))
-			    other-pointer-type))
-	  ax-tn)
-    (move result eax)))
-
-
 
 ;;; These VOPs are used for implementing float slots in structures (whose raw
 ;;; data is an unsigned-32 vector.
diff --git a/compiler/x86/macros.lisp b/compiler/x86/macros.lisp
index 31cf5038c..b8da8606d 100644
--- a/compiler/x86/macros.lisp
+++ b/compiler/x86/macros.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.23 2008/04/17 08:59:49 cshapiro Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.24 2008/04/17 09:05:02 cshapiro Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -485,6 +485,50 @@
 			  :disp (- (+ (* ,offset word-bytes) (* ,scale index))
 				   ,lowtag))))))))
 
+(defmacro define-partial-setter (name type size offset lowtag scs el-type
+				      &optional translate)
+  (let ((scale (ecase size (:byte 1) (:word 2))))
+    `(progn
+       (define-vop (,name)
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg) :to (:eval 0))
+		(index :scs (unsigned-reg) :to (:eval 0))
+		(value :scs ,scs :target eax))
+	 (:arg-types ,type positive-fixnum ,el-type)
+	 (:temporary (:sc unsigned-reg :offset eax-offset :target result
+			  :from (:argument 2) :to (:result 0))
+		     eax)
+	 (:results (result :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   (move eax value)
+	   (inst mov (make-ea ,size :base object :index index :scale ,scale
+			      :disp (- (* ,offset word-bytes) ,lowtag))
+		 ,(ecase size (:byte 'al-tn) (:word 'ax-tn)))
+	   (move result eax)))
+       (define-vop (,(symbolicate name "-C"))
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg) :to (:eval 0))
+		(value :scs ,scs :target eax))
+	 (:info index)
+	 (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
+	 (:temporary (:sc unsigned-reg :offset eax-offset :target result
+			  :from (:argument 1) :to (:result 0))
+		     eax)
+	 (:results (result :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 4
+	   (move eax value)
+	   (inst mov (make-ea ,size :base object
+			      :disp (- (+ (* ,offset word-bytes) (* ,scale index))
+				       ,lowtag))
+		 ,(ecase size (:byte 'al-tn) (:word 'ax-tn)))
+	   (move result eax))))))
+
 (defmacro define-full-conditional-setter (name type offset lowtag scs el-type
 					  &optional translate)
   `(progn
-- 
GitLab