From 3cdf64f68f9e9e908c15dce08ec7625c80d12d67 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 11 Dec 1991 16:55:09 +0000
Subject: [PATCH] Give a warning in DERIVE-NODE-TYPE when we prove inconsistent
 types.  This is probably always a bug, but I don't want to use ASSERT until
 all the problems are fixed. Changed RETURN optimization to call
 MAYBE-CONVERT-TAIL-CALL. Updated for new tail-set semantics. Changed VALUES
 IR1 transform and SUBSTITUTE-SINGLE-USE-CONTINUATION to clear out the old
 NODE-DERIVED-TYPE so that the type doesn't spuriously go to NIL.

---
 compiler/ir1opt.lisp | 54 +++++++++++++++++++++++++++-----------------
 1 file changed, 33 insertions(+), 21 deletions(-)

diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp
index 73ce82d7a..d3a9d91c1 100644
--- a/compiler/ir1opt.lisp
+++ b/compiler/ir1opt.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/ir1opt.lisp,v 1.33 1991/11/16 15:41:39 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.34 1991/12/11 16:55:09 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -190,6 +190,13 @@
     (unless (eq node-type rtype)
       (let ((int (values-type-intersection node-type rtype)))
 	(when (type/= node-type int)
+	  (when (and (eq int *empty-type*)
+		     (not (eq rtype *empty-type*)))
+	    (let ((*compiler-error-context* node))
+	      (compiler-warning
+	       "New inferred type ~S conflicts with old type:~
+		~%  ~S~%*** Bug?"
+	       (type-specifier rtype) (type-specifier node-type))))
 	  (setf (node-derived-type node) int)
 	  (reoptimize-continuation (node-cont node))))))
   (undefined-value))
@@ -450,9 +457,11 @@
 ;;;    This function is called on RETURN nodes that have their REOPTIMIZE flag
 ;;; set.  It iterates over the uses of the RESULT, looking for interesting
 ;;; stuff to update the TAIL-SET:
-;;;  -- If a use is a local call, then we check that the called function has
-;;;     the tail set Tails.  If we encounter any different tail set, we return
-;;;     the second value true.
+;;;  -- If a use is a tail local call, then we check that the called function
+;;;     has the tail set Tails.  If we encounter any different tail set, we
+;;;     return true.  If NODE-TAIL-P is not set, we also call
+;;;     CONVERT-TAIL-LOCAL-CALL, which changes the succesor of the call to be
+;;;     the called function and checks if the call can become an assignment.
 ;;;  -- If a use isn't a local call, then we union its type together with the
 ;;;     types of other such uses.  We assign to the RETURN-RESULT-TYPE the
 ;;;     intersection of this type with the RESULT's asserted type.  We can make
@@ -465,11 +474,14 @@
 	(retry nil))
     (collect ((use-union *empty-type* values-type-union))
       (do-uses (use result)
-	(if (and (basic-combination-p use)
-		 (eq (basic-combination-kind use) :local))
-	    (when (merge-tail-sets use tails)
-	      (setq retry t))
-	    (use-union (node-derived-type use))))
+	(cond ((and (basic-combination-p use)
+		    (eq (basic-combination-kind use) :local)
+		    (immediately-used-p result use))
+	       (when (merge-tail-sets use tails)
+		 (setq retry t))
+	       (maybe-convert-tail-local-call use))
+	      (t
+	       (use-union (node-derived-type use)))))
       (let ((int (values-type-intersection
 		  (continuation-asserted-type result)
 		  (use-union))))
@@ -487,13 +499,10 @@
 ;;; destructively modify the set for the returning function to represent both,
 ;;; and then change all the functions in callee's set to reference the first.
 ;;;
-;;;    If the called function has no tail set, then do nothing; if it doesn't
-;;; return, then it can't affect the callers value.
-;;;
 (defun merge-tail-sets (call ret-set)
   (declare (type basic-combination call) (type tail-set ret-set))
   (let ((fun-set (lambda-tail-set (combination-lambda call))))
-    (when (and fun-set (not (eq ret-set fun-set)))
+    (unless (eq ret-set fun-set)
       (let ((funs (tail-set-functions fun-set)))
 	(dolist (fun funs)
 	  (setf (lambda-tail-set fun) ret-set))
@@ -536,10 +545,11 @@
 	  (let ((funs (tail-set-functions tails)))
 	    (dolist (fun funs)
 	      (let ((return (lambda-return fun)))
-		(when (node-reoptimize return)
-		  (setf (node-reoptimize node) nil)
-		  (when (find-result-type return tails) (return-from RETRY)))
-		(res (return-result-type return)))))
+		(when return
+		  (when (node-reoptimize return)
+		    (setf (node-reoptimize node) nil)
+		    (when (find-result-type return tails) (return-from RETRY)))
+		  (res (return-result-type return))))))
 	  (return)))
       
       (when (type/= (res) (tail-set-type tails))
@@ -829,10 +839,10 @@
 	  ((functional-p (ref-leaf use))
 	   (let ((leaf (ref-leaf use)))
 	     (cond ((eq (combination-kind call) :local)
-		    (let ((tail-set (lambda-tail-set leaf)))
-		      (when tail-set
-			(derive-node-type
-			 call (tail-set-type tail-set)))))
+		    (unless (member (functional-kind leaf)
+				    '(:let :assignment))
+		      (derive-node-type
+		       call (tail-set-type (lambda-tail-set leaf)))))
 		   ((not (eq (ref-inlinep use) :notinline))
 		    (convert-call-if-possible use call)
 		    (maybe-let-convert leaf)))))
@@ -1136,6 +1146,7 @@
       (assert (member (continuation-kind arg)
 		      '(:block-start :deleted-block-start :inside-block)))
       (assert-continuation-type arg (continuation-asserted-type cont))
+      (setf (node-derived-type ref) *wild-type*)
       (change-ref-leaf ref (find-constant nil))
       (substitute-continuation arg cont)
       (reoptimize-continuation arg)
@@ -1531,6 +1542,7 @@
   (when (typep (continuation-dest (node-cont node))
 	       '(or creturn exit mv-combination))
     (give-up))
+  (setf (node-derived-type node) *wild-type*)
   (if vals
       (let ((dummies (loop repeat (1- (length vals))
 		       collect (gensym))))
-- 
GitLab