CMUCL commit: amd64-dd-branch src/compiler/amd64 (x87-array.lisp)

Raymond Toy rtoy at common-lisp.net
Mon Nov 2 16:51:06 CET 2009


    Date: Monday, November 2, 2009 @ 10:51:06
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/compiler/amd64
     Tag: amd64-dd-branch

   Added: x87-array.lisp

Add x87 array vops.  (Mostly for double-double support.)


----------------+
 x87-array.lisp | 1198 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 1198 insertions(+)


Index: src/compiler/amd64/x87-array.lisp
diff -u /dev/null src/compiler/amd64/x87-array.lisp:1.1.2.1
--- /dev/null	Mon Nov  2 10:51:06 2009
+++ src/compiler/amd64/x87-array.lisp	Mon Nov  2 10:51:05 2009
@@ -0,0 +1,1198 @@
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group at cs.cmu.edu.
+;;;
+(ext:file-comment
+ "$Header: /project/cmucl/cvsroot/src/compiler/amd64/Attic/x87-array.lisp,v 1.1.2.1 2009-11-02 15:51:05 rtoy Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;;    This file contains the x86 definitions for array operations.
+;;;
+;;; And the float variants.
+;;; 
+
+(in-package :amd64)
+
+(define-vop (data-vector-ref/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-single-float positive-fixnum)
+  (:results (value :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+   (with-empty-tn at fp-top(value)
+     (inst fld (make-ea	:dword :base object :index index :scale 1
+			:disp (- (* vm:vector-data-offset vm:word-bytes)
+				 vm:other-pointer-type))))))
+
+(define-vop (data-vector-ref-c/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-single-float (:constant (signed-byte 30)))
+  (:results (value :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+   (with-empty-tn at fp-top(value)
+     (inst fld (make-ea	:dword :base object
+			:disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				    (* 4 index))
+				 vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (single-reg) :target result))
+  (:arg-types simple-array-single-float positive-fixnum single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 5
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :dword :base object :index index :scale 1
+			      :disp (- (* vm:vector-data-offset vm:word-bytes)
+				       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :dword :base object :index index :scale 1
+			      :disp (- (* vm:vector-data-offset vm:word-bytes)
+				       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
+
+(define-vop (data-vector-set-c/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (single-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-single-float (:constant (signed-byte 30))
+	      single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :dword :base object
+			      :disp (- (+ (* vm:vector-data-offset
+					     vm:word-bytes)
+					  (* 4 index))
+				       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :dword :base object
+			      :disp (- (+ (* vm:vector-data-offset
+					     vm:word-bytes)
+					  (* 4 index))
+				       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-float positive-fixnum)
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 7
+   (with-empty-tn at fp-top(value)
+     (inst fldd (make-ea :dword :base object :index index :scale 2
+			 :disp (- (* vm:vector-data-offset vm:word-bytes)
+				  vm:other-pointer-type))))))
+
+(define-vop (data-vector-ref-c/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-double-float (:constant (signed-byte 30)))
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 6
+   (with-empty-tn at fp-top(value)
+     (inst fldd (make-ea :dword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 8 index))
+				  vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (double-reg) :target result))
+  (:arg-types simple-array-double-float positive-fixnum double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 20
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :dword :base object :index index :scale 2
+			       :disp (- (* vm:vector-data-offset vm:word-bytes)
+					vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :dword :base object :index index :scale 2
+			       :disp (- (* vm:vector-data-offset vm:word-bytes)
+					vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
+
+(define-vop (data-vector-set-c/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (double-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-double-float (:constant (signed-byte 30))
+	      double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 19
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :dword :base object
+			       :disp (- (+ (* vm:vector-data-offset
+					      vm:word-bytes)
+					   (* 8 index))
+					vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :dword :base object
+			       :disp (- (+ (* vm:vector-data-offset
+					      vm:word-bytes)
+					   (* 8 index))
+					vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
+
+#+long-float
+(define-vop (data-vector-ref/simple-array-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-long-float positive-fixnum)
+  (:temporary (:sc any-reg :from :eval :to :result) temp)
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 7
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (with-empty-tn at fp-top(value)
+      (inst fldl (make-ea :dword :base object :index temp :scale 1
+			  :disp (- (* vm:vector-data-offset vm:word-bytes)
+				   vm:other-pointer-type))))))
+
+#+long-float
+(define-vop (data-vector-ref-c/simple-array-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-long-float (:constant (signed-byte 30)))
+  (:results (value :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 6
+   (with-empty-tn at fp-top(value)
+     (inst fldl (make-ea :dword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 12 index))
+				  vm:other-pointer-type))))))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (long-reg) :target result))
+  (:arg-types simple-array-long-float positive-fixnum long-float)
+  (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 20
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float
+	    (make-ea :dword :base object :index temp :scale 1
+		     :disp (- (* vm:vector-data-offset vm:word-bytes)
+			      vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float
+	    (make-ea :dword :base object :index temp :scale 1
+		     :disp (- (* vm:vector-data-offset vm:word-bytes)
+			      vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
+#+long-float
+(define-vop (data-vector-set-c/simple-array-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (long-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
+  (:results (result :scs (long-reg)))
+  (:result-types long-float)
+  (:generator 19
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (store-long-float (make-ea :dword :base object
+				      :disp (- (+ (* vm:vector-data-offset
+						     vm:word-bytes)
+						  (* 12 index))
+					       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+	     ;; Value is in ST0 but not result.
+	     (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (store-long-float (make-ea :dword :base object
+				      :disp (- (+ (* vm:vector-data-offset
+						     vm:word-bytes)
+						  (* 12 index))
+					       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+		    (inst fstd result))
+		  (inst fxch value)))))))
+
+;;; Complex float variants.
+(define-vop (data-vector-ref/simple-array-complex-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-single-float positive-fixnum)
+  (:results (value :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 5
+    (let ((real-tn (complex-single-reg-real-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fld (make-ea :dword :base object :index index :scale 2
+			   :disp (- (* vm:vector-data-offset vm:word-bytes)
+				    vm:other-pointer-type)))))
+    (let ((imag-tn (complex-single-reg-imag-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fld (make-ea :dword :base object :index index :scale 2
+			   :disp (- (* (1+ vm:vector-data-offset)
+				       vm:word-bytes)
+				    vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
+  (:results (value :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 4
+    (let ((real-tn (complex-single-reg-real-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fld (make-ea :dword :base object
+			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				       (* 8 index))
+				    vm:other-pointer-type)))))
+    (let ((imag-tn (complex-single-reg-imag-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fld (make-ea :dword :base object
+			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				       (* 8 index) 4)
+				    vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-complex-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (complex-single-reg) :target result))
+  (:arg-types simple-array-complex-single-float positive-fixnum
+	      complex-single-float)
+  (:results (result :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 5
+    (let ((value-real (complex-single-reg-real-tn value))
+	  (result-real (complex-single-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fst (make-ea :dword :base object :index index :scale 2
+				:disp (- (* vm:vector-data-offset
+					    vm:word-bytes)
+					 vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fst result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fst (make-ea :dword :base object :index index :scale 2
+				:disp (- (* vm:vector-data-offset
+					    vm:word-bytes)
+					 vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fst value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fst result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-single-reg-imag-tn value))
+	  (result-imag (complex-single-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fst (make-ea :dword :base object :index index :scale 2
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     4)
+				  vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fst result-imag))
+      (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-complex-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (complex-single-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
+	      complex-single-float)
+  (:results (result :scs (complex-single-reg)))
+  (:result-types complex-single-float)
+  (:generator 4
+    (let ((value-real (complex-single-reg-real-tn value))
+	  (result-real (complex-single-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fst (make-ea :dword :base object
+				:disp (- (+ (* vm:vector-data-offset
+					       vm:word-bytes)
+					    (* 8 index))
+					 vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fst result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fst (make-ea :dword :base object
+				:disp (- (+ (* vm:vector-data-offset
+					       vm:word-bytes)
+					    (* 8 index))
+					 vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fst value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fst result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-single-reg-imag-tn value))
+	  (result-imag (complex-single-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fst (make-ea :dword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 8 index) 4)
+				  vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fst result-imag))
+      (inst fxch value-imag))))
+
+
+(define-vop (data-vector-ref/simple-array-complex-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-float positive-fixnum)
+  (:results (value :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 7
+    (let ((real-tn (complex-double-reg-real-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 4
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-reg-imag-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 4
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					8)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
+  (:results (value :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 6
+    (let ((real-tn (complex-double-reg-real-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 16 index))
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-reg-imag-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 16 index) 8)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-reg) :target result))
+  (:arg-types simple-array-complex-double-float positive-fixnum
+	      complex-double-float)
+  (:results (result :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 20
+    (let ((value-real (complex-double-reg-real-tn value))
+	  (result-real (complex-double-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-double-reg-imag-tn value))
+	  (result-imag (complex-double-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object :index index :scale 4
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      8)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-complex-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (complex-double-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
+	      complex-double-float)
+  (:results (result :scs (complex-double-reg)))
+  (:result-types complex-double-float)
+  (:generator 19
+    (let ((value-real (complex-double-reg-real-tn value))
+	  (result-real (complex-double-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 16 index))
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 16 index))
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-double-reg-imag-tn value))
+	  (result-imag (complex-double-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      (* 16 index) 8)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+
+#+long-float
+(define-vop (data-vector-ref/simple-array-complex-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-long-float positive-fixnum)
+  (:temporary (:sc any-reg :from :eval :to :result) temp)
+  (:results (value :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 7
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (let ((real-tn (complex-long-reg-real-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldl (make-ea :dword :base object :index temp :scale 2
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-long-reg-imag-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldl (make-ea :dword :base object :index temp :scale 2
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					12)
+				     vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (data-vector-ref-c/simple-array-complex-long-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
+  (:results (value :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 6
+    (let ((real-tn (complex-long-reg-real-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldl (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 24 index))
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-long-reg-imag-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldl (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 24 index) 12)
+				     vm:other-pointer-type)))))))
+
+#+long-float
+(define-vop (data-vector-set/simple-array-complex-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-long-reg) :target result))
+  (:arg-types simple-array-complex-long-float positive-fixnum
+	      complex-long-float)
+  (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+  (:results (result :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 20
+    ;; temp = 3 * index
+    (inst lea temp (make-ea :dword :base index :index index :scale 2))
+    (let ((value-real (complex-long-reg-real-tn value))
+	  (result-real (complex-long-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (store-long-float
+	      (make-ea :dword :base object :index temp :scale 2
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (store-long-float
+	      (make-ea :dword :base object :index temp :scale 2
+		       :disp (- (* vm:vector-data-offset vm:word-bytes)
+				vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-long-reg-imag-tn value))
+	  (result-imag (complex-long-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (store-long-float
+       (make-ea :dword :base object :index temp :scale 2
+		:disp (- (+ (* vm:vector-data-offset vm:word-bytes) 12)
+			 vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+#+long-float
+(define-vop (data-vector-set-c/simple-array-complex-long-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (complex-long-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
+	      complex-long-float)
+  (:results (result :scs (complex-long-reg)))
+  (:result-types complex-long-float)
+  (:generator 19
+    (let ((value-real (complex-long-reg-real-tn value))
+	  (result-real (complex-long-reg-real-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (store-long-float
+	      (make-ea :dword :base object
+		       :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				   (* 24 index))
+				vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (store-long-float
+	      (make-ea :dword :base object
+		       :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				   (* 24 index))
+				vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-long-reg-imag-tn value))
+	  (result-imag (complex-long-reg-imag-tn result)))
+      (inst fxch value-imag)
+      (store-long-float
+       (make-ea :dword :base object
+		:disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+			    (* 24 index) 12)
+			 vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+#+double-double
+(progn
+(define-vop (data-vector-ref/simple-array-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-double-double-float positive-fixnum)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:generator 7
+    (let ((hi-tn (double-double-reg-hi-tn value)))
+      (with-empty-tn at fp-top (hi-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 4
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((lo-tn (double-double-reg-lo-tn value)))
+      (with-empty-tn at fp-top (lo-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 4
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					8)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:generator 5
+    (let ((hi-tn (double-double-reg-hi-tn value)))
+      (with-empty-tn at fp-top (hi-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 16 index))
+				     vm:other-pointer-type)))))
+    (let ((lo-tn (double-double-reg-lo-tn value)))
+      (with-empty-tn at fp-top (lo-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 16 index)
+					8)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float positive-fixnum
+	      double-double-float)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:generator 20
+    (let ((value-real (double-double-reg-hi-tn value))
+	  (result-real (double-double-reg-hi-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object :index index :scale 4
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (double-double-reg-lo-tn value))
+	  (result-imag (double-double-reg-lo-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object :index index :scale 4
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      8)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (double-double-reg) :target result))
+  (:arg-types simple-array-double-double-float
+	      (:constant index)
+	      double-double-float)
+  (:info index)
+  (:results (result :scs (double-double-reg)))
+  (:result-types double-double-float)
+  (:generator 20
+    (let ((value-real (double-double-reg-hi-tn value))
+	  (result-real (double-double-reg-hi-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 16 index))
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 16 index))
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (double-double-reg-lo-tn value))
+	  (result-imag (double-double-reg-lo-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      (* 16 index)
+				      8)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg)))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:generator 7
+    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (* vm:vector-data-offset vm:word-bytes)
+				     vm:other-pointer-type)))))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					8)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					16)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object :index index :scale 8
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					24)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-double-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result))
+  (:arg-types simple-array-complex-double-double-float (:constant index))
+  (:info index)
+  (:results (value :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:generator 5
+    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 32 index))
+				     vm:other-pointer-type)))))
+    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
+      (with-empty-tn at fp-top (real-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 32 index)
+					8)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 32 index)
+					16)
+				     vm:other-pointer-type)))))
+    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
+      (with-empty-tn at fp-top (imag-tn)
+	(inst fldd (make-ea :dword :base object
+			    :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+					(* 32 index)
+					24)
+				     vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (index :scs (any-reg))
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float positive-fixnum
+	      complex-double-double-float)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:generator 20
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (* vm:vector-data-offset
+					     vm:word-bytes)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     8)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object :index index :scale 8
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     8)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object :index index :scale 8
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      16)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))
+    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object :index index :scale 8
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      24)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-complex-double-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg) :to :result)
+	 (value :scs (complex-double-double-reg) :target result))
+  (:arg-types simple-array-complex-double-double-float
+	      (:constant index)
+	      complex-double-double-float)
+  (:info index)
+  (:results (result :scs (complex-double-double-reg)))
+  (:result-types complex-double-double-float)
+  (:generator 20
+    (let ((value-real (complex-double-double-reg-real-hi-tn value))
+	  (result-real (complex-double-double-reg-real-hi-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 32 index))
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 32 index))
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-real (complex-double-double-reg-real-lo-tn value))
+	  (result-real (complex-double-double-reg-real-lo-tn result)))
+      (cond ((zerop (tn-offset value-real))
+	     ;; Value is in ST0
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 32 index)
+					     8)
+					  vm:other-pointer-type)))
+	     (unless (zerop (tn-offset result-real))
+	       ;; Value is in ST0 but not result.
+	       (inst fstd result-real)))
+	    (t
+	     ;; Value is not in ST0.
+	     (inst fxch value-real)
+	     (inst fstd (make-ea :dword :base object
+				 :disp (- (+ (* vm:vector-data-offset
+						vm:word-bytes)
+					     (* 32 index)
+					     8)
+					  vm:other-pointer-type)))
+	     (cond ((zerop (tn-offset result-real))
+		    ;; The result is in ST0.
+		    (inst fstd value-real))
+		   (t
+		    ;; Neither value or result are in ST0
+		    (unless (location= value-real result-real)
+		      (inst fstd result-real))
+		    (inst fxch value-real))))))
+    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
+	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      (* 32 index)
+				      16)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))
+    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
+	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
+      (inst fxch value-imag)
+      (inst fstd (make-ea :dword :base object
+			  :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				      (* 32 index)
+				      24)
+				   vm:other-pointer-type)))
+      (unless (location= value-imag result-imag)
+	(inst fstd result-imag))
+      (inst fxch value-imag))))
+
+)



More information about the cmucl-commit mailing list