From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 5 Nov 2001 18:12:13 +0000 (+0000)
Subject: Three fixes that together resolve the problem of compiling the XML
X-Git-Tag: 20090517-FFI~2468
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1bad3b034f90c2945252385847975c79da7dd13f;p=mit-scheme.git

Three fixes that together resolve the problem of compiling the XML
parser.  (1) FOR-EACH-CALLEE! claimed to examine all of the callees,
but it wasn't looking at procedures called from descendant blocks that
had been disowned.  (2) When removing dependent constraints, due to
closure, constraints that had indirect dependencies on the now-closed
procedure weren't being removed.  (3) When adding undrifting
constraints due to closure contagion, it's wrong to constrain the
invocation block of a trivial closure.
---

diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm
index a3b25f368..0a8151c6f 100644
--- a/v7/src/compiler/fgopt/closan.scm
+++ b/v7/src/compiler/fgopt/closan.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: closan.scm,v 4.26 2001/11/03 05:16:48 cph Exp $
+$Id: closan.scm,v 4.27 2001/11/05 18:12:13 cph Exp $
 
 Copyright (c) 1987-1991, 1998, 1999, 2001 Massachusetts Institute of Technology
 
@@ -302,10 +302,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 			     (application-operator application))))
 		(block-applications block))
       (for-each loop (block-children block))
-      #|
-      (for-each loop (block-disowned-children block))
-      |#
-      )))
+      (for-each loop (block-disowned-children block)))))
 
 (define (undrifting-constraint! block block* condition)
   ;; Undrift BLOCK so it is a descendant of BLOCK*, due to CONDITION.
@@ -323,8 +320,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 						   block*))
 		     (loop (block-parent block))
 		     block))))
-	  (if (add-constraint block block* condition)
-	      (update-callers-and-callees! block block* condition))))))
+	  (if (not (and (eq? (condition-keyword condition) 'CONTAGION)
+			(let ((procedure (block-procedure block)))
+			  (and procedure
+			       (procedure/trivial-closure? procedure)))))
+	      (if (add-constraint block block* condition)
+		  (update-callers-and-callees! block block* condition)))))))
 
 (define (update-callers-and-callees! block block* condition)
   ;; The context of BLOCK has changed, so it may be necessary to
@@ -407,11 +408,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 			    (and condition
 				 (or (eq? procedure
 					  (condition-procedure condition))
-				     #|
 				     (memq procedure
-					   (condition-dependencies condition))
-				     |#
-				     )
+					   (condition-dependencies condition)))
 				 (begin
 				   (debug:remove-condition (car entry)
 							   (car entry*)