From d1f88027d55a2d4e570c925ef56306798eca31c0 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Tue, 17 Apr 1990 13:30:09 +0000
Subject: [PATCH] Added code to any emit coercion VOPs before the move-argument
 VOPs in a call

---
 compiler/represent.lisp | 89 +++++++++++++++++++++++++----------------
 1 file changed, 55 insertions(+), 34 deletions(-)

diff --git a/compiler/represent.lisp b/compiler/represent.lisp
index 1c44f2c9c..e87eda6f7 100644
--- a/compiler/represent.lisp
+++ b/compiler/represent.lisp
@@ -254,10 +254,10 @@
 
 ;;; EMIT-COERCE-VOP  --  Internal
 ;;;
-;;;    Emit a coercion VOP for Op or die trying.  SCS is the operand's LOAD-SCS
-;;; vector, which we use to determine what SCs the VOP will accept.  We pick
-;;; any acceptable coerce VOP, since it practice it seems uninteresting to have
-;;; more than one applicable.
+;;;    Emit a coercion VOP for Op Before the specifed VOP or die trying.  SCS
+;;; is the operand's LOAD-SCS vector, which we use to determine what SCs the
+;;; VOP will accept.  We pick any acceptable coerce VOP, since it practice it
+;;; seems uninteresting to have more than one applicable.
 ;;;
 ;;;    What we do is look at each SC allowed by the operand restriction, and
 ;;; see if there is a move VOP which moves between the operand's SC and load
@@ -267,8 +267,8 @@
 ;;;    If the TN is an unused result TN, then we don't actually emit the move;
 ;;; we just change to the right kind of TN.
 ;;;
-(defun emit-coerce-vop (op scs)
-  (declare (type tn-ref op) (type sc-vector scs))
+(defun emit-coerce-vop (op scs before)
+  (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before))
   (let* ((op-tn (tn-ref-tn op))
 	 (op-sc (tn-sc op-tn))
 	 (op-scn (sc-number op-sc))
@@ -287,34 +287,49 @@
 	      (change-tn-ref-tn op temp)
 	      (cond
 	       ((not write-p)
-		(emit-move-template node block res op-tn temp vop))
+		(emit-move-template node block res op-tn temp before))
 	       ((null (tn-reads op-tn)))
 	       (t
-		(emit-move-template node block res temp op-tn (vop-next vop)))))
+		(emit-move-template node block res temp op-tn before))))
 	    (return)))))))
 
 
+;;; COERCE-SOME-OPERANDS  --  Internal
+;;;
+;;;    Scan some operands and call EMIT-COERCE-VOP on any for which we can't
+;;; load the operand.  The coerce VOP is inserted Before the specified VOP.
+;;;
+(proclaim '(inline coerce-some-operands))
+(defun coerce-some-operands (ops load-scs before)
+  (declare (type (or tn-ref null) ops) (list load-scs)
+	   (type (or vop null) before))
+  (do ((op ops (tn-ref-across op))
+       (scs load-scs (cdr scs)))
+      ((null scs))
+    (unless (svref (car scs)
+		   (sc-number (tn-sc (tn-ref-tn op))))
+      (emit-coerce-vop op (car scs) before)))
+  (undefined-value))
+
+
 ;;; COERCE-VOP-OPERANDS  --  Internal
 ;;;
-;;;    Scan the operands to VOP and call EMIT-COERCE-VOP on any for which we
-;;; can't load the operand.
+;;;    Emit coerce VOPs for the args and results, as needed.
 ;;;
 (defun coerce-vop-operands (vop)
   (declare (type vop vop))
   (let ((info (vop-info vop)))
-    (macrolet ((scan (ops load-scs)
-		 `(do ((op ,ops (tn-ref-across op))
-		       (scs ,load-scs (cdr scs)))
-		      ((null scs))
-		    (unless (svref (car scs)
-				   (sc-number (tn-sc (tn-ref-tn op))))
-		      (emit-coerce-vop op (car scs))))))
-      (scan (vop-args vop) (vop-info-arg-load-scs info))
-      (scan (vop-results vop) (vop-info-result-load-scs info)))))
+    (coerce-some-operands (vop-args vop) (vop-info-arg-load-scs info) vop)
+    (coerce-some-operands (vop-results vop) (vop-info-result-load-scs info)
+			  (vop-next vop))))
 
 
 ;;; EMIT-ARG-MOVES  --  Internal
 ;;;
+;;;    Iterate over the more operands to a call VOP, emitting move-arg VOPs and
+;;; any necessary coercions.  We determine which FP to use by looking at the
+;;; MOVE-ARGS annotation.
+;;;
 (defun emit-arg-moves (vop)
   (let* ((info (vop-info vop))
 	 (node (vop-node vop))
@@ -325,7 +340,8 @@
 	 (nfp-tn (if (eq how :local-call)
 		     (tn-ref-tn (tn-ref-across args))
 		     nil))
-	 (pass-locs (first (vop-codegen-info vop))))
+	 (pass-locs (first (vop-codegen-info vop)))
+	 (prev (vop-prev vop)))
     (do ((val (do ((arg args (tn-ref-across arg))
 		   (req (template-arg-types info) (cdr req)))
 		  ((null req) arg))
@@ -340,20 +356,25 @@
 			 (sc-number (tn-sc val-tn)))))
 	(unless res
 	  (bad-move-arg-error val-tn pass-tn))
-
-	(let ((this-fp
-	       (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
-		     (nfp-tn)
-		     (t
-		      (assert (eq how :known-return))
-		      (setq nfp-tn
-			    (make-representation-tn
-			     (first (primitive-type-scs
-				     *any-primitive-type*))))
-		      (emit-context-template node block nfp-tn vop)
-		      nfp-tn))))
-	(emit-move-arg-template node block res val-tn this-fp pass-tn vop)))))
-
+	
+	(change-tn-ref-tn val pass-tn)
+	(let* ((this-fp
+		(cond ((not (sc-number-stack-p pass-sc)) fp-tn)
+		      (nfp-tn)
+		      (t
+		       (assert (eq how :known-return))
+		       (setq nfp-tn
+			     (make-representation-tn
+			      (first (primitive-type-scs
+				      *any-primitive-type*))))
+		       (emit-context-template node block nfp-tn vop)
+		       nfp-tn)))
+	       (new (emit-move-arg-template node block res val-tn this-fp
+					    pass-tn vop)))
+	  (coerce-some-operands (vop-args new) (vop-info-arg-load-scs res)
+				(if prev
+				    (vop-next prev)
+				    (ir2-block-start-vop block)))))))
   (undefined-value))
 
 
-- 
GitLab