From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 14 Mar 1989 19:45:15 +0000 (+0000)
Subject: `undrift-procedure!' must set the block-parent of the procedure's
X-Git-Tag: 20090517-FFI~12228
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eb87babee6991807790aa064ba6173f36401f85e;p=mit-scheme.git

`undrift-procedure!' must set the block-parent of the procedure's
block to match the new closing-limit.  Also: change the handling of
the closing-limit to guarantee that it is always either the same as
the closing-block, or #F; reorganize the code a bit.
---

diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm
index 662620aac..058d7d329 100644
--- a/v7/src/compiler/fgopt/closan.scm
+++ b/v7/src/compiler/fgopt/closan.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.6 1988/12/13 13:03:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.7 1989/03/14 19:45:15 cph Exp $
 
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -64,10 +64,10 @@ simple techniques it generates more information than is needed.
 implementation of closures.  If a closure invokes another procedure
 which is not a child, the current implementation requires that the
 other procedure also be a closure.  However, if the closing-limit of
-the caller is the same as the closure-block of the callee, the callee
-will not be marked as a closure.  This has disastrous results.  As a
-result, the analysis has been modified to force the closing-limit to
-#F whenever a closure is identified.
+the (closed) caller is the same as that of the (open) callee, the
+callee will not be marked as a closure.  This has disastrous results.
+As a result, the analysis has been modified to force the closing-limit
+to #F whenever a closure is identified.
 
 |#
 
@@ -79,7 +79,13 @@ result, the analysis has been modified to force the closing-limit to
     (for-each initialize-arguments! applications)
     (transitive-closure
      (lambda ()
-       (for-each close-passed-out! procedures))
+       (for-each (lambda (procedure)
+		   (if (procedure-passed-out? procedure)
+		       (maybe-close-procedure! procedure
+					       false
+					       'PASSED-OUT
+					       false)))
+		 procedures))
      (lambda (item)
        (if (rvalue/procedure? item)
 	   (analyze-procedure item)
@@ -95,18 +101,15 @@ result, the analysis has been modified to force the closing-limit to
 
 (define (initialize-lvalues-lists! lvalue)
   (if (lvalue/variable? lvalue)
-      (for-each (lambda (val)
-		  (if (rvalue/procedure? val)
+      (for-each (lambda (value)
+		  (if (rvalue/procedure? value)
 		      (set-procedure-variables!
-		       val
-		       (cons lvalue (procedure-variables val))))
-		  'DONE)
+		       value
+		       (cons lvalue (procedure-variables value)))))
 		(lvalue-values lvalue))))
 
 (define (initialize-closure-limit! procedure)
-  (set-procedure-closing-limit! procedure
-				(procedure-closing-block procedure))
-  'DONE)
+  (set-procedure-closing-limit! procedure (procedure-closing-block procedure)))
 
 (define (initialize-arguments! application)
   (if (application/combination? application)
@@ -127,11 +130,6 @@ result, the analysis has been modified to force the closing-limit to
 	(set-combination/model!
 	 application
 	 (rvalue-known-value (combination/operator application))))))
-
-(define (close-passed-out! procedure)
-  (if (and (not (procedure-continuation? procedure))
-	   (procedure-passed-out? procedure))
-      (maybe-close-procedure! procedure false 'PASSED-OUT false)))
 
 (define (analyze-procedure procedure)
   (for-each (lambda (variable)
@@ -148,16 +146,16 @@ result, the analysis has been modified to force the closing-limit to
     (cond ((not (application/combination? application))
 	   ;; If the combination is not an application, we need not
 	   ;; examine the operators for compatibility.
-	   'DONE)
+	   unspecific)
 	  ((rvalue-passed-in? operator)
 	   ;; We don't need to close the operands because
 	   ;; they have been marked as passed out already.
-	   (close-rvalue! operator false 'APPLY-COMPATIBILITY application))
+	   (close-rvalue! operator 'APPLY-COMPATIBILITY application))
 	  ((null? procs)
 	   ;; The (null? procs) case is the NOP node case.  This combination
 	   ;; should not be executed, so it should have no effect on any items
 	   ;; involved in it.
-	   'DONE)
+	   unspecific)
 	  ((not proc)
 	   (let ((class (compatibility-class procs))
 		 (model (car procs)))
@@ -170,119 +168,171 @@ result, the analysis has been modified to force the closing-limit to
 			     (set-procedure-virtual-closure?! proc true))
 			   procs)
 		 (begin
-		   (close-rvalue! operator false class application)
+		   (close-rvalue! operator class application)
 		   (close-application-arguments! application false)))))
 	  ((or (not (rvalue/procedure? proc))
 	       (procedure-closure-context proc))
 	   (close-application-arguments! application false))
 	  (else
-	   'DONE))))
+	   unspecific))))
 
 (define (close-application-arguments! application block)
-  (let* ((previous (application-destination-block application))
-	 (new (cond ((eq? previous true)
-		     block)
-		    ((or (false? previous)
-			 (false? block))
-		     false)
-		    (else
-		     (block-nearest-common-ancestor block previous)))))
-    (if (not (eq? new previous))
-	(begin
-	  (set-application-destination-block! application new)
-	  (close-values!
-	   (application-operand-values application)
-	   new
-	   'ARGUMENT
-	   application)))))
-
-(define (with-procedure-arity proc receiver)
-  (let ((req (length (procedure-required proc))))
-    (receiver req
-	      (if (procedure-rest proc)
-		  -1
-		  (+ req (length (procedure-optional proc)))))))
+  (let ((previous (application-destination-block application)))
+    (let ((new
+	   (if (eq? previous true)
+	       block
+	       (and previous
+		    block
+		    (block-nearest-common-ancestor block previous)))))
+      (if (not (eq? new previous))
+	  (begin
+	    (set-application-destination-block! application new)
+	    (close-values! (application-operand-values application)
+			   new
+			   'ARGUMENT
+			   application))))))
 
 (define (compatibility-class procs)
   (if (not (for-all? procs rvalue/procedure?))
       'APPLY-COMPATIBILITY
       (let* ((model (car procs))
 	     (model-env (procedure-closing-limit model)))
-	(with-procedure-arity
-	 model
-	 (lambda (model-min model-max)
-	   (let loop ((procs (cdr procs))
-		      (class (if (procedure/closure? model)
-				 'COMPATIBILITY
-				 'POTENTIAL)))
-	     (if (null? procs)
-		 class
-		 (let ((this (car procs)))
-		   (with-procedure-arity
-		    this
-		    (lambda (this-min this-max)
-		      (cond ((not (and (= model-min this-min)
-				       (= model-max this-max)))
-			     'APPLY-COMPATIBILITY)
-			    ((or (procedure/closure? this)
-				 (not (eq? (procedure-closing-limit this)
-					   model-env)))
-			     (loop (cdr procs) 'COMPATIBILITY))
-			    (else
-			     (loop (cdr procs) class)))))))))))))
+	(with-values (lambda () (procedure-arity-encoding model))
+	  (lambda (model-min model-max)
+	    (let loop
+		((procs (cdr procs))
+		 (class
+		  (if (procedure/closure? model) 'COMPATIBILITY 'POTENTIAL)))
+	      (if (null? procs)
+		  class
+		  (let ((this (car procs)))
+		    (with-values (lambda () (procedure-arity-encoding this))
+		      (lambda (this-min this-max)
+			(if (and (= model-min this-min)
+				 (= model-max this-max))
+			    (loop (cdr procs)
+				  (if (and (not (procedure/closure? this))
+					   (eq? (procedure-closing-limit this)
+						model-env))
+				      class
+				      'COMPATIBILITY))
+			    'APPLY-COMPATIBILITY)))))))))))
 
-(define-integrable (close-rvalue! rvalue binding-block reason1 reason2)
-  (close-values! (rvalue-values rvalue) binding-block reason1 reason2))
+(define-integrable (close-rvalue! rvalue reason1 reason2)
+  (close-values! (rvalue-values rvalue) false reason1 reason2))
 
 (define (close-values! values binding-block reason1 reason2)
   (for-each (lambda (value)
 	      (if (and (rvalue/procedure? value)
 		       (not (procedure-continuation? value)))
-		  (maybe-close-procedure! value binding-block
-					  reason1 reason2)))
+		  (maybe-close-procedure! value
+					  binding-block
+					  reason1
+					  reason2)))
 	    values))
 
 (define (maybe-close-procedure! procedure binding-block reason1 reason2)
-  (let* ((closing-limit (procedure-closing-limit procedure))
-	 (new-closing-limit
-	  (and binding-block
-	       closing-limit
-	       (block-nearest-common-ancestor binding-block closing-limit))))
-    (cond ((not (eq? new-closing-limit closing-limit))
+  (let ((closing-limit (procedure-closing-limit procedure)))
+    (cond ((not closing-limit)
+	   (add-closure-reason! procedure reason1 reason2))
+	  ((not (and binding-block
+		     (block-ancestor-or-self? binding-block closing-limit)))
+	   (set-procedure-closing-limit! procedure false)
 	   (if (procedure-virtual-closure? procedure)
 	       (set-procedure-virtual-closure?! procedure false))
-	   (close-procedure! procedure new-closing-limit reason1 reason2))
-	  ((false? new-closing-limit)
-	   (add-closure-reason! procedure reason1 reason2)))))
+	   (close-procedure! procedure reason1 reason2)))))
+
+(define (close-procedure! procedure reason1 reason2)
+  (let ((previously-trivial? (procedure/trivial-closure? procedure)))
+    ;; We can't change the closing block yet.
+    ;; blktyp has a consistency check that depends on the closing block
+    ;; remaining the same.
+    (add-closure-reason! procedure reason1 reason2)
+    ;; Force the procedure's type to CLOSURE.
+    (if (not (procedure-closure-context procedure))
+	(set-procedure-closure-context! procedure true))
+    ;; The code generator needs all callees to be closed.
+    (let ((block (procedure-block procedure)))
+      (for-each-callee! block
+	(lambda (value)
+	  (if (not (block-ancestor-or-self? (procedure-block value) block))
+	      (maybe-close-procedure! value false 'CONTAGION procedure)))))
+    ;; The environment optimizer may have moved some procedures in the
+    ;; environment tree based on the (now incorrect) assumption that this
+    ;; procedure was not closed.  Fix this.
+    ;; On the other hand, if it was trivial before, it is still trivial
+    ;; now, so the callers are not affected.
+    (if (not previously-trivial?)
+	(examine-free-callers! procedure))
+    ;; We need to reexamine those applications which may have this procedure
+    ;; as an operator, since the compatibility class of the operator may have
+    ;; changed.
+    (enqueue-nodes! (procedure-applications procedure))))
 
-(define (close-procedure! procedure new-closing-limit reason1 reason2)
-  new-closing-limit
-  ;; **** Force trivial closure limit due to poor code generator. ****
-  (let ((new-closing-limit false))
-    (let ((previously-trivial? (procedure/trivial-closure? procedure)))
-      (set-procedure-closing-limit! procedure new-closing-limit)
-      ;; We can't change the closing block yet.
-      ;; blktyp has a consistency check that depends on the closing block
-      ;; remaining the same.
-      (add-closure-reason! procedure reason1 reason2)
-      ;; Force the procedure's type to CLOSURE.
-      (if (not (procedure-closure-context procedure))
-	  (set-procedure-closure-context! procedure true))
-      ;; The code generator needs all callees to be closed.
-      (close-callees! (procedure-block procedure)
-		      new-closing-limit
-		      procedure)
-      ;; The environment optimizer may have moved some procedures in the
-      ;; environment tree based on the (now incorrect) assumption that this
-      ;; procedure was not closed.  Fix this.
-      ;; On the other hand, if it was trivial before, it is still trivial
-      ;; now, so the callers are not affected.
-      (if (not previously-trivial?)
-	  (examine-free-callers! procedure))
-      ;; We need to reexamine those applications which may have this procedure
-      ;; as an operator, since the compatibility class of the operator may have
-      ;; changed.
-      (enqueue-nodes! (procedure-applications procedure)))))
+(define (for-each-callee! block procedure)
+  (for-each-block-descendent! block
+    (lambda (block*)
+      (for-each (lambda (application)
+		  (for-each (lambda (value)
+			      (if (and (rvalue/procedure? value)
+				       (not (procedure-continuation? value)))
+				  (procedure value)))
+			    (rvalue-values
+			     (application-operator application))))
+		(block-applications block*)))))
+
+(define (examine-free-callers! procedure)
+  (let ((block (procedure-block procedure)))
+    (for-each
+     (lambda (procedure*)
+       (if (not (procedure-closure-context procedure*))
+	   (let ((parent (procedure-closing-block procedure*))
+		 (original-parent (procedure-target-block procedure*)))
+	     ;; No need to do anything if PROCEDURE* hasn't drifted
+	     ;; relative to PROCEDURE.
+	     (if (and (not (eq? parent original-parent))
+		      (not (block-ancestor-or-self? parent block)))
+		 (let ((binding-block
+			(reduce original-block-nearest-common-ancestor
+				false
+				(map variable-block
+				     (cdr (assq procedure
+						(procedure-free-callees
+						 procedure*)))))))
+		   (if (not (block-ancestor-or-self? parent binding-block))
+		       ;; PROCEDURE* has drifted towards the
+		       ;; environment root past the point where we
+		       ;; have access to PROCEDURE (by means of free
+		       ;; variables).  We must drift it away from
+		       ;; the root until we regain access to PROCEDURE.
+		       (undrift-procedure! procedure* binding-block)))))))
+     (procedure-free-callers procedure))))
+
+(define (undrift-procedure! procedure new-parent)
+  (let ((block (procedure-block procedure))
+	(parent (procedure-closing-block procedure))
+	(original-parent (procedure-target-block procedure)))
+    ;; (assert! (eq? parent (procedure-closing-limit procedure)))
+    (set-block-children! parent (delq! block (block-children parent)))
+    (set-block-parent! block new-parent)
+    (set-block-children! new-parent (cons block (block-children new-parent)))
+    (set-procedure-closing-limit! procedure new-parent)
+    (enqueue-nodes! (cons procedure (procedure-applications procedure)))
+    (if (eq? new-parent original-parent)
+	(set-block-disowned-children!
+	 original-parent
+	 (delq! block (block-disowned-children original-parent)))
+	(let ((parent-procedure (block-procedure original-parent)))
+	  (if (and (not (block-ancestor-or-self? original-parent new-parent))
+		   (rvalue/procedure? parent-procedure)
+		   (not (procedure-closure-context parent-procedure)))
+	      ;; My original parent has drifted to a place where I
+	      ;; can't be closed.  I must drag it back.
+	      (if (original-block-ancestor-or-self? original-parent new-parent)
+		  (undrift-procedure! parent-procedure new-parent)
+		  (error "Procedure has free variables in hyperspace!"
+			 procedure)))))
+    (examine-free-callers! procedure)))
 
 ;; These are like the corresponding standard block operations, but
 ;; they ignore any block drifting caused by envopt.
@@ -296,11 +346,6 @@ result, the analysis has been modified to force the closing-limit to
   (or (eq? block block*)
       (loop (original-block-parent block))))
 
-(define (original-block-ancestry block path)
-  (if (block-parent block)
-      (original-block-ancestry (original-block-parent block) (cons block path))
-      (cons block path)))
-
 (define (original-block-nearest-common-ancestor block block*)
   (let loop
       ((join false)
@@ -311,80 +356,9 @@ result, the analysis has been modified to force the closing-limit to
 	     (eq? (car ancestry) (car ancestry*)))
 	(loop (car ancestry) (cdr ancestry) (cdr ancestry*))
 	join)))
-
-(define-integrable (block<= ancestor descendant)
-  (block-ancestor-or-self? descendant ancestor))
-
-(define (undrift-procedure! procedure block)
-  (let ((myblock (procedure-block procedure))
-	(closing-block (procedure-closing-limit procedure))
-	(original-closing-block (procedure-target-block procedure)))
-    (set-procedure-closing-limit! procedure block)
-    (set-block-children! closing-block
-			 (delq! myblock (block-children closing-block)))
-    (set-block-children! block (cons myblock (block-children block)))
-    (enqueue-nodes! (cons procedure (procedure-applications procedure)))
-    (cond ((eq? block original-closing-block)
-	   (set-block-disowned-children! original-closing-block
-					 (delq! myblock
-						(block-disowned-children
-						 original-closing-block))))
-	  ((and (not (block<= block original-closing-block))
-		(rvalue/procedure? (block-procedure original-closing-block))
-		(not (procedure-closure-context
-		      (block-procedure original-closing-block))))
-	   ;; My original parent has drifted to a place where I can't
-	   ;; be closed.  I must drag it back.
-	   (if (not (original-block-ancestor-or-self? original-closing-block
-						      block))
-	       (error "Procedure has free variables in hyperspace!"
-		      procedure))
-	   (undrift-procedure! (block-procedure original-closing-block)
-			       block)))
-    (examine-free-callers! procedure)))
-
-(define (examine-free-callers! procedure)
-  (let ((myblock (procedure-block procedure)))
-    (for-each
-     (lambda (procedure*)
-       (if (false? (procedure-closure-context procedure*))
-	   (let ((closing-block (procedure-closing-limit procedure*))
-		 (original-closing-block (procedure-target-block procedure*)))
-	     ;; No need to do anything if PROCEDURE* hasn't drifted
-	     ;; relative to PROCEDURE.
-	     (if (and (not (eq? closing-block original-closing-block))
-		      (not (block<= myblock closing-block)))
-		 (let ((binding-block
-			(reduce original-block-nearest-common-ancestor
-				false
-				(map variable-block
-				     (cdr (assq procedure
-						(procedure-free-callees
-						 procedure*)))))))
-		   (if (not (block<= binding-block closing-block))
-		       ;; PROCEDURE* has drifted towards the
-		       ;; environment root past the point where we
-		       ;; have access to PROCEDURE (by means of free
-		       ;; variables).  We must drift it away from
-		       ;; the root until we regain access to PROCEDURE.
-		       (undrift-procedure! procedure* binding-block)))))))
-     (procedure-free-callers procedure))))
-
-(define (close-callees! block new-closing-limit culprit)
-  (for-each-callee! block
-    (lambda (value)
-      (if (not (block-ancestor-or-self? (procedure-block value) block))
-	  (maybe-close-procedure! value new-closing-limit
-				  'CONTAGION culprit)))))
 
-(define (for-each-callee! block procedure)
-  (for-each-block-descendent! block
-    (lambda (block*)
-      (for-each (lambda (application)
-		  (for-each (lambda (value)
-			      (if (and (rvalue/procedure? value)
-				       (not (procedure-continuation? value)))
-				  (procedure value)))
-			    (rvalue-values
-			     (application-operator application))))
-		(block-applications block*)))))
\ No newline at end of file
+(define (original-block-ancestry block path)
+  (let ((parent (original-block-parent block)))
+    (if parent
+	(original-block-ancestry parent (cons block path))
+	(cons block path))))
\ No newline at end of file