From 2ed45450e8d692b927c124de24c9b7c6d5776f0a Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Fri, 7 Nov 1997 17:05:53 +0000
Subject: [PATCH] Extend the complex-float real and imag part accessors to
 accept stack and descriptor-reg SCs which can be handled efficiently.

---
 compiler/x86/float.lisp | 64 ++++++++++++++++++++++++++++++-----------
 1 file changed, 47 insertions(+), 17 deletions(-)

diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index 4c7388b15..7e39eb96f 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.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/float.lisp,v 1.12 1997/11/05 14:59:55 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.13 1997/11/07 17:05:53 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -49,7 +49,6 @@
 (progn
 (defun ea-for-csf-real-desc(tn)
   (ea-for-xf-desc tn vm:complex-single-float-real-slot))
-
 (defun ea-for-csf-imag-desc(tn)
   (ea-for-xf-desc tn vm:complex-single-float-imag-slot))
 
@@ -2621,21 +2620,49 @@
   (:variant-vars offset)
   (:policy :fast-safe)
   (:generator 3
-    (let ((value-tn (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
-				    :offset (+ offset (tn-offset x)))))
-      (unless (location= value-tn r)
-	(cond ((zerop (tn-offset r))
-	       (copy-fp-reg-to-fr0 value-tn))
-	      ((zerop (tn-offset value-tn))
-	       (inst fstd r))
-	      (t
-	       (inst fxch value-tn)
-	       (inst fstd r)
-	       (inst fxch value-tn)))))))
+    (cond ((sc-is x complex-single-reg complex-double-reg)
+	   (let ((value-tn
+		  (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
+				  :offset (+ offset (tn-offset x)))))
+	     (unless (location= value-tn r)
+	       (cond ((zerop (tn-offset r))
+		      (copy-fp-reg-to-fr0 value-tn))
+		     ((zerop (tn-offset value-tn))
+		      (inst fstd r))
+		     (t
+		      (inst fxch value-tn)
+		      (inst fstd r)
+		      (inst fxch value-tn))))))
+	  ((sc-is r single-reg)
+	   (let ((ea (sc-case x
+		       (complex-single-stack
+			(ecase offset
+			  (0 (ea-for-csf-real-stack x))
+			  (1 (ea-for-csf-imag-stack x))))
+		       (descriptor-reg
+			(ecase offset
+			  (0 (ea-for-csf-real-desc x))
+			  (1 (ea-for-csf-imag-desc x)))))))
+	     (with-empty-tn@fp-top(r)
+	       (inst fld ea))))
+	  ((sc-is r double-reg)
+	   (let ((ea (sc-case x
+		       (complex-double-stack
+			(ecase offset
+			  (0 (ea-for-cdf-real-stack x))
+			  (1 (ea-for-cdf-imag-stack x))))
+		       (descriptor-reg
+			(ecase offset
+			  (0 (ea-for-cdf-real-desc x))
+			  (1 (ea-for-cdf-imag-desc x)))))))
+	     (with-empty-tn@fp-top(r)
+	       (inst fldd ea))))
+	  (t (error "Complex-float-value VOP failure")))))
 
 (define-vop (complex-single-float-real complex-float-value)
   (:translate complex-single-float-real)
-  (:args (x :scs (complex-single-reg) :target r))
+  (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
+	    :target r))
   (:arg-types complex-single-float)
   (:results (r :scs (single-reg)))
   (:result-types single-float)
@@ -2643,7 +2670,8 @@
 
 (define-vop (complex-double-float-real complex-float-value)
   (:translate complex-double-float-real)
-  (:args (x :scs (complex-double-reg) :target r))
+  (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
+	    :target r))
   (:arg-types complex-double-float)
   (:results (r :scs (double-reg)))
   (:result-types double-float)
@@ -2651,7 +2679,8 @@
 
 (define-vop (complex-single-float-imag complex-float-value)
   (:translate complex-single-float-imag)
-  (:args (x :scs (complex-single-reg) :target r))
+  (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
+	    :target r))
   (:arg-types complex-single-float)
   (:results (r :scs (single-reg)))
   (:result-types single-float)
@@ -2659,7 +2688,8 @@
 
 (define-vop (complex-double-float-imag complex-float-value)
   (:translate complex-double-float-imag)
-  (:args (x :scs (complex-double-reg) :target r))
+  (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
+	    :target r))
   (:arg-types complex-double-float)
   (:results (r :scs (double-reg)))
   (:result-types double-float)
-- 
GitLab