From 07670e92dbbe94d60bbf51d53749b854a2105788 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 24 Oct 1990 16:21:51 +0000
Subject: [PATCH] Added representation selection efficency notes to warn when
 we are doing an expensive coercion (like number consing.)

---
 compiler/represent.lisp | 88 ++++++++++++++++++++++++++++++++++++-----
 1 file changed, 78 insertions(+), 10 deletions(-)

diff --git a/compiler/represent.lisp b/compiler/represent.lisp
index 913ec6c2d..0fd71270f 100644
--- a/compiler/represent.lisp
+++ b/compiler/represent.lisp
@@ -304,6 +304,61 @@
   (undefined-value))
 
 
+;;; GET-OPERAND-NAME  --  Internal
+;;;
+;;;    If TN is a variable, return the name.  If TN is used by a VOP emitted
+;;; for a return, then return a string indicating this.  Otherwise, return NIL.
+;;;
+(defun get-operand-name (tn arg-p)
+  (declare (type tn tn))
+  (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn))
+	 (reads (tn-reads tn))
+	 (leaf (tn-leaf actual)))
+    (cond ((lambda-var-p leaf) (leaf-name leaf))
+	  ((and (not arg-p) reads
+		(return-p (vop-node (tn-ref-vop reads))))
+	   "<return value>")
+	  (t
+	   nil))))
+
+
+;;; DO-COERCE-EFFICENCY-NOTE  --  Internal
+;;;
+;;;    If policy indicates, give an efficency note for doing the a coercion
+;;; Vop, where Op is the operand we are coercing for and Dest-TN is the
+;;; distinct destination in a move.
+;;;
+(defun do-coerce-efficency-note (vop op dest-tn)
+  (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn))
+  (let* ((note (or (template-note vop) (template-name vop)))
+	 (cost (template-cost vop))
+	 (op-vop (tn-ref-vop op))
+	 (op-node (vop-node op-vop))
+	 (op-tn (tn-ref-tn op))
+	 (*compiler-error-context* op-node))
+    (cond ((eq (tn-kind op-tn) :constant))
+	  ((policy op-node (<= speed brevity) (<= space brevity)))
+	  ((null dest-tn)
+	   (let* ((op-info (vop-info op-vop))
+		  (op-note (or (template-note op-info)
+			       (template-name op-info)))
+		  (arg-p (not (tn-ref-write-p op)))
+		  (name (get-operand-name op-tn arg-p)))
+	     (multiple-value-bind (ignore pos)
+				  (get-operand-info op)
+	       (declare (ignore ignore))
+	       (compiler-note
+		"Doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
+		The ~:R ~:[result~;argument~] of ~A."
+		note cost name arg-p name
+		pos arg-p op-note))))
+	  (t
+	   (compiler-note "Doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]."
+			  note cost (get-operand-name op-tn t)
+			  (get-operand-name dest-tn nil)))))
+  (undefined-value))
+
+
 ;;; EMIT-COERCE-VOP  --  Internal
 ;;;
 ;;;    Emit a coercion VOP for Op Before the specifed VOP or die trying.  SCS
@@ -316,11 +371,15 @@
 ;;; between the operand's SC and load SC.  If we find such a VOP, then we make
 ;;; a TN having the load SC as the representation.
 ;;;
+;;;    Dest-TN is the TN that we are moving to, for a move or move-arg.  This
+;;; is only for efficiency notes.
+;;;
 ;;;    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 before)
-  (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before))
+(defun emit-coerce-vop (op dest-tn scs before)
+  (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)
+	   (type (or tn null) dest-tn))
   (let* ((op-tn (tn-ref-tn op))
 	 (op-sc (tn-sc op-tn))
 	 (op-scn (sc-number op-sc))
@@ -337,6 +396,8 @@
 			 (svref (sc-move-vops op-sc) i)
 			 (svref (sc-move-vops i-sc) op-scn))))
 	    (when res
+	      (when (>= (vop-info-cost res) *efficency-note-cost-threshold*)
+		(do-coerce-efficency-note res op dest-tn))
 	      (let ((temp (make-representation-tn ptype i)))
 		(change-tn-ref-tn op temp)
 		(cond
@@ -352,17 +413,19 @@
 ;;;
 ;;;    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.
+;;; Dest-TN is the destination TN if we are doing a move or move-arg, and is
+;;; NIL otherwise.  This is only used for efficency notes.
 ;;;
 (proclaim '(inline coerce-some-operands))
-(defun coerce-some-operands (ops load-scs before)
+(defun coerce-some-operands (ops dest-tn load-scs before)
   (declare (type (or tn-ref null) ops) (list load-scs)
-	   (type (or vop null) before))
+	   (type (or tn null) dest-tn) (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)))
+      (emit-coerce-vop op dest-tn (car scs) before)))
   (undefined-value))
 
 
@@ -373,9 +436,10 @@
 (defun coerce-vop-operands (vop)
   (declare (type vop vop))
   (let ((info (vop-info vop)))
-    (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))))
+    (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop)
+    (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info)
+			  (vop-next vop)))
+  (undefined-value))
 
 
 ;;; EMIT-ARG-MOVES  --  Internal
@@ -430,7 +494,8 @@
 		       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)
+	  (coerce-some-operands (vop-args new) pass-tn
+				(vop-info-arg-load-scs res)
 				(if prev
 				    (vop-next prev)
 				    (ir2-block-start-vop block)))))))
@@ -452,11 +517,14 @@
 	  (block (vop-block vop)))
       (cond
        ((eq (vop-info-name info) 'move)
-	(let* ((x (tn-ref-tn (vop-args vop)))
+	(let* ((args (vop-args vop))
+	       (x (tn-ref-tn args))
 	       (y (tn-ref-tn (vop-results vop)))
 	       (res (svref (sc-move-vops (tn-sc y))
 			   (sc-number (tn-sc x)))))
 	  (cond (res
+		 (when (>= (vop-info-cost res) *efficency-note-cost-threshold*)
+		   (do-coerce-efficency-note res args y))
 		 (emit-move-template node block res x y vop)
 		 (delete-vop vop))
 		(t
-- 
GitLab