From cf0cb637e62b756bd7bb75230756607dd760451d Mon Sep 17 00:00:00 2001
From: cshapiro <cshapiro>
Date: Wed, 16 Apr 2008 09:06:41 +0000
Subject: [PATCH] Add a partial reffer macro for the x86 and use it to
 implement the various loads from 8-bit and 16-bit specialized arrays.

---
 compiler/x86/array.lisp  | 140 ++++++---------------------------------
 compiler/x86/macros.lisp |  34 +++++++++-
 2 files changed, 55 insertions(+), 119 deletions(-)

diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp
index 8ca738ffb..6004a4f24 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.20 2008/04/15 03:24:21 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.21 2008/04/16 09:06:37 cshapiro Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -128,11 +128,32 @@
        vector-data-offset other-pointer-type ,scs ,element-type
        data-vector-set)))
 
+(defmacro def-partial-data-vector-frobs
+	  (type element-type size signed &rest scs)
+  `(progn
+     (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+       ,size ,signed vector-data-offset other-pointer-type ,scs
+       ,element-type data-vector-ref)))
+
 ); eval-when (compile eval)
 
 (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
+  :byte nil unsigned-reg signed-reg)
+
+(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+  :word nil unsigned-reg signed-reg)
+
 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
   unsigned-reg)
+
+(def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
+  :byte t signed-reg)
+
+(def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
+  :word t signed-reg)
+
 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg)
 
@@ -1062,36 +1083,6 @@
 
 ;;; unsigned-byte-8
 
-(define-vop (data-vector-ref/simple-array-unsigned-byte-8)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (unsigned-reg)))
-  (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
-  (:results (value :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 5
-    (inst movzx value
-	  (make-ea :byte :base object :index index :scale 1
-		   :disp (- (* vector-data-offset word-bytes)
-			    other-pointer-type)))))
-
-
-(define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg)))
-  (:info index)
-  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
-  (:results (value :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 4
-    (inst movzx value
-	  (make-ea :byte :base object
-		   :disp (- (+ (* vector-data-offset word-bytes) index)
-			    other-pointer-type)))))
-
-
 (define-vop (data-vector-set/simple-array-unsigned-byte-8)
   (:translate data-vector-set)
   (:policy :fast-safe)
@@ -1137,36 +1128,6 @@
 
 ;;; unsigned-byte-16
 
-(define-vop (data-vector-ref/simple-array-unsigned-byte-16)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (unsigned-reg)))
-  (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
-  (:results (value :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 5
-    (inst movzx value
-	  (make-ea :word :base object :index index :scale 2
-		   :disp (- (* vector-data-offset word-bytes)
-			    other-pointer-type)))))
-
-
-(define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg)))
-  (:info index)
-  (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
-  (:results (value :scs (unsigned-reg signed-reg)))
-  (:result-types positive-fixnum)
-  (:generator 4
-    (inst movzx value
-	  (make-ea :word :base object
-		   :disp (- (+ (* vector-data-offset word-bytes) (* 2 index))
-			    other-pointer-type)))))
-
-
 (define-vop (data-vector-set/simple-array-unsigned-byte-16)
   (:translate data-vector-set)
   (:policy :fast-safe)
@@ -1290,34 +1251,6 @@
 
 ;;; signed-byte-8
 
-(define-vop (data-vector-ref/simple-array-signed-byte-8)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (unsigned-reg)))
-  (:arg-types simple-array-signed-byte-8 positive-fixnum)
-  (:results (value :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 5
-    (inst movsx value
-	  (make-ea :byte :base object :index index :scale 1
-		   :disp (- (* vector-data-offset word-bytes)
-			    other-pointer-type)))))
-
-(define-vop (data-vector-ref-c/simple-array-signed-byte-8)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg)))
-  (:info index)
-  (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
-  (:results (value :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 4
-    (inst movsx value
-	  (make-ea :byte :base object
-		   :disp (- (+ (* vector-data-offset word-bytes) index)
-			    other-pointer-type)))))
-
 (define-vop (data-vector-set/simple-array-signed-byte-8)
   (:translate data-vector-set)
   (:policy :fast-safe)
@@ -1361,35 +1294,6 @@
 
 ;;; signed-byte-16
 
-(define-vop (data-vector-ref/simple-array-signed-byte-16)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (unsigned-reg)))
-  (:arg-types simple-array-signed-byte-16 positive-fixnum)
-  (:results (value :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 5
-    (inst movsx value
-	  (make-ea :word :base object :index index :scale 2
-		   :disp (- (* vector-data-offset word-bytes)
-			    other-pointer-type)))))
-
-(define-vop (data-vector-ref-c/simple-array-signed-byte-16)
-  (:translate data-vector-ref)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg)))
-  (:info index)
-  (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
-  (:results (value :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 4
-    (inst movsx value
-	  (make-ea :word :base object
-		   :disp (- (+ (* vector-data-offset word-bytes)
-			       (* 2 index))
-			    other-pointer-type)))))
-
 (define-vop (data-vector-set/simple-array-signed-byte-16)
   (:translate data-vector-set)
   (:policy :fast-safe)
diff --git a/compiler/x86/macros.lisp b/compiler/x86/macros.lisp
index a66cf61e8..8bc3571fb 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.21 2003/08/25 20:50:58 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.22 2008/04/16 09:06:41 cshapiro Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -453,6 +453,38 @@
 	       value)
 	 (move result value)))))
 
+(defmacro define-partial-reffer (name type size signed 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))
+		(index :scs (unsigned-reg)))
+	 (:arg-types ,type positive-fixnum)
+	 (:results (value :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   (inst ,(if signed 'movsx 'movzx) value
+		 (make-ea ,size :base object :index index :scale ,scale
+			  :disp (- (* ,offset word-bytes) ,lowtag)))))
+       (define-vop (,(symbolicate name "-C"))
+	 ,@(when translate
+	     `((:translate ,translate)))
+	 (:policy :fast-safe)
+	 (:args (object :scs (descriptor-reg)))
+	 (:info index)
+	 (:arg-types ,type (:constant (signed-byte 30)))
+	 (:results (value :scs ,scs))
+	 (:result-types ,el-type)
+	 (:generator 5
+	   (inst ,(if signed 'movsx 'movzx) value
+		 (make-ea ,size :base object
+			  :disp (- (+ (* ,offset word-bytes) (* ,scale index))
+				   ,lowtag))))))))
+
 (defmacro define-full-conditional-setter (name type offset lowtag scs el-type
 					  &optional translate)
   `(progn
-- 
GitLab