From c86570c9c2a97521de0af297937573bac37f57f5 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Tue, 10 Mar 1998 18:22:34 +0000
Subject: [PATCH] Fix a bug in the movement of complex float arguments with a
 destination on the stack.

---
 compiler/x86/float.lisp | 148 +++++++++++++++++++++-------------------
 1 file changed, 77 insertions(+), 71 deletions(-)

diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index 5c44549ca..ba1774868 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.23 1998/02/24 18:10:17 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.24 1998/03/10 18:22:34 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -16,64 +16,68 @@
 ;;; Written by William Lott.
 ;;;
 ;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
-;;; Re-written and enhanced by Douglas Crosher, 1996, 1997, 1998.
+;;;
+;;; Rewrite, enhancements, complex-float support by
+;;; Douglas Crosher, 1996, 1997, 1998.
 ;;;
 
 (in-package :x86)
 
 
-(defmacro ea-for-xf-desc(tn slot)
-  `(make-ea
-    :dword :base ,tn :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type)))
-
-(defun ea-for-sf-desc(tn)
-  (ea-for-xf-desc tn vm:single-float-value-slot))
-
-(defun ea-for-df-desc(tn)
-  (ea-for-xf-desc tn vm:double-float-value-slot))
-
-(defmacro ea-for-xf-stack(tn kind)
-  `(make-ea
-    :dword :base ebp-tn
-    :disp (- (* (+ (tn-offset ,tn) (case ,kind (:single 1) (:double 2)))
-	      vm:word-bytes))))
-
-(defun ea-for-sf-stack(tn)
-  (ea-for-xf-stack tn :single))
-
-(defun ea-for-df-stack(tn)
-  (ea-for-xf-stack tn :double))
-
-;;; Complex float EAs
+(macrolet ((ea-for-xf-desc (tn slot)
+	     `(make-ea
+	       :dword :base ,tn
+	       :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type))))
+  (defun ea-for-sf-desc (tn)
+    (ea-for-xf-desc tn vm:single-float-value-slot))
+  (defun ea-for-df-desc (tn)
+    (ea-for-xf-desc tn vm:double-float-value-slot))
+  ;; Complex floats
+  #+complex-float
+  (defun ea-for-csf-real-desc (tn)
+    (ea-for-xf-desc tn vm:complex-single-float-real-slot))
+  #+complex-float
+  (defun ea-for-csf-imag-desc (tn)
+    (ea-for-xf-desc tn vm:complex-single-float-imag-slot))
+  #+complex-float
+  (defun ea-for-cdf-real-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-float-real-slot))
+  #+complex-float
+  (defun ea-for-cdf-imag-desc (tn)
+    (ea-for-xf-desc tn vm:complex-double-float-imag-slot)))
+
+(macrolet ((ea-for-xf-stack (tn kind)
+	     `(make-ea
+	       :dword :base ebp-tn
+	       :disp (- (* (+ (tn-offset ,tn)
+			      (ecase ,kind (:single 1) (:double 2) (:long 3)))
+			 vm:word-bytes)))))
+  (defun ea-for-sf-stack (tn)
+    (ea-for-xf-stack tn :single))
+  (defun ea-for-df-stack (tn)
+    (ea-for-xf-stack tn :double)))
+
+;;; Complex float stack EAs
 #+complex-float
-(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))
-
-(defun ea-for-cdf-real-desc(tn)
-  (ea-for-xf-desc tn vm:complex-double-float-real-slot))
-(defun ea-for-cdf-imag-desc(tn)
-  (ea-for-xf-desc tn vm:complex-double-float-imag-slot))
-
-(defmacro ea-for-cxf-stack(tn kind slot)
-  `(make-ea
-    :dword :base ebp-tn
-    :disp (- (* (+ (tn-offset ,tn) (* (case ,kind (:single 1) (:double 2))
-				      (case ,slot (:real 1) (:imag 2))))
-	      vm:word-bytes))))
-
-(defun ea-for-csf-real-stack(tn)
-  (ea-for-cxf-stack tn :single :real))
-(defun ea-for-csf-imag-stack(tn)
-  (ea-for-cxf-stack tn :single :imag))
-
-(defun ea-for-cdf-real-stack(tn)
-  (ea-for-cxf-stack tn :double :real))
-(defun ea-for-cdf-imag-stack(tn)
-  (ea-for-cxf-stack tn :double :imag))
-) ; complex-float
+(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
+	     `(make-ea
+	       :dword :base ,base
+	       :disp (- (* (+ (tn-offset ,tn)
+			      (* (ecase ,kind
+				   (:single 1)
+				   (:double 2)
+				   (:long 3))
+				 (ecase ,slot (:real 1) (:imag 2))))
+			 vm:word-bytes)))))
+  (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :single :real base))
+  (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :single :imag base))
+  ;;
+  (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :double :real base))
+  (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
+    (ea-for-cxf-stack tn :double :imag base)))
 
 ;;; Abstract out the copying of a FP register to the FP stack top, and
 ;;; provide two alternatives for its implementation. Note: it's not
@@ -81,21 +85,19 @@
 ;;; here.
 ;;;
 ;;; Using a Pop then load.
-(defmacro copy-fp-reg-to-fr0 (reg)
-  `(progn 
-     (assert (not (zerop (tn-offset ,reg))))
-     (inst fstp fr0-tn)
-     (inst fld (make-random-tn :kind :normal
-			       :sc (sc-or-lose 'double-reg *backend*)
-			       :offset (1- (tn-offset ,reg))))))
+(defun copy-fp-reg-to-fr0 (reg)
+  (assert (not (zerop (tn-offset ,reg))))
+  (inst fstp fr0-tn)
+  (inst fld (make-random-tn :kind :normal
+			    :sc (sc-or-lose 'double-reg *backend*)
+			    :offset (1- (tn-offset reg)))))
 ;;;
 ;;; Using Fxch then Fst to restore the original reg contents.
 #+nil
-(defmacro copy-fp-reg-to-fr0 (reg)
-  `(progn
-     (assert (not (zerop (tn-offset ,reg))))
-     (inst fxch ,reg)
-     (inst fst  ,reg)))
+(defun copy-fp-reg-to-fr0 (reg)
+  (assert (not (zerop (tn-offset reg))))
+  (inst fxch reg)
+  (inst fst  reg))
 
 
 ;;;; Move functions:
@@ -503,24 +505,28 @@
 			 (cond ((zerop (tn-offset real-tn))
 				,@(ecase format
 				    (:single
-				     '((inst fst (ea-for-csf-real-stack y))))
+				     '((inst fst
+					(ea-for-csf-real-stack y fp))))
 				    (:double
-				     '((inst fstd (ea-for-cdf-real-stack y))))))
+				     '((inst fstd
+					(ea-for-cdf-real-stack y fp))))))
 			       (t
 				(inst fxch real-tn)
 				,@(ecase format
 				    (:single
-				     '((inst fst (ea-for-csf-real-stack y))))
+				     '((inst fst
+					(ea-for-csf-real-stack y fp))))
 				    (:double
-				     '((inst fstd (ea-for-cdf-real-stack y)))))
+				     '((inst fstd
+					(ea-for-cdf-real-stack y fp)))))
 				(inst fxch real-tn))))
 		       (let ((imag-tn (complex-double-reg-imag-tn x)))
 			 (inst fxch imag-tn)
 			 ,@(ecase format
 			     (:single
-			      '((inst fst (ea-for-csf-imag-stack y))))
+			      '((inst fst (ea-for-csf-imag-stack y fp))))
 			     (:double
-			      '((inst fstd (ea-for-cdf-imag-stack y)))))
+			      '((inst fstd (ea-for-cdf-imag-stack y fp)))))
 			 (inst fxch imag-tn))))))
 		(define-move-vop ,name :move-argument
 		  (,sc descriptor-reg) (,sc)))))
-- 
GitLab