From: Chris Hanson Date: Sun, 24 Sep 1989 03:33:55 +0000 (+0000) Subject: Change code back to clobber the procedure-block's parent when a X-Git-Tag: 20090517-FFI~11781 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ea7b5c88256fa1ed10abdcbdddde3f5e788972d9;p=mit-scheme.git Change code back to clobber the procedure-block's parent when a procedure is undrifted. If this is not done the operations `block-ancestor-or-self?' and `block-nearest-common-ancestor' return the wrong answers, and consequently must be replaced with new operations that take the undrifting into account (yet another set of nearly-identical operations!). Rather than do this, I attacked the problem of why clobbering the parent causes problems. The losing scenario seems to be as follows: procedure A is a child of procedure B; procedure B and procedure C are siblings; procedure A is a free-caller of procedure C (and so is procedure B by transitivity); procedure B has drifted up one or more blocks, while A and C have not drifted at all. The problem occurs when A is examined before B for undrifting: because C is not accessible from A (due to B's drifting), it is undrifted. Later, B is also undrifted (because it is also a free-caller of C); note that had B been undrifted before we looked at A there would have been no reason to undrift A. Finally, `setup-block-types!' closes both A and B because they have been undrifted, which allows them both to reference their free variables; this reference is possible -because- the original parent was not changed when the undrifting occurred. Had the original parent been changed at that time, the closing would have failed. Now many times the only reason that A and B are being closed is because of the undrifting -- there is really no reason for them to be closed at all (in these cases, we would have been better off never having tried to drift procedure A in the first place). Furthermore, because this closing is bypassing the normal closing mechanism, some other inconsistencies are introduced, in particular the `virtual-closure?' bit is not cleared (it was the bug caused by this inconsistency which forced me to reexamine this code in the first place). OK, so let's try this again. Suppose we -don't- close undrifted procedures unless there's some other reason to do so (which we can detect by looking at the `closure-context' or `closure-reasons'). Then the way to avoid the losing scenario above is to guarantee that we undrift B before considering A for undrifting. This is easily accomplished by performing a topological sort on the `free-callers'. This sorting is sufficient because the decision to undrift A can only depend on ancestors who are also members of the `free-callers' set. So that's the story: I've added a topological sort of `procedure-free-callers', changed `undrift-procedure!' to immediately update the `procedure-closing-block', and changed `setup-block-types!' to base the closing decision on `procedure-closure-context' rather than (the now inaptly named) `close-procedure?'. --- diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index 7d53e4c46..a91ca6df3 100644 --- a/v7/src/compiler/fgopt/closan.scm +++ b/v7/src/compiler/fgopt/closan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.8 1989/05/10 03:01:40 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.9 1989/09/24 03:33:55 cph Exp $ Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology @@ -109,7 +109,20 @@ to #F whenever a closure is identified. (lvalue-values lvalue)))) (define (initialize-closure-limit! procedure) - (set-procedure-closing-limit! procedure (procedure-closing-block procedure))) + (set-procedure-closing-limit! procedure (procedure-closing-block procedure)) + ;; This sorting is crucial! It causes a procedure's ancestors to be + ;; considered for undrifting prior to the procedure being + ;; considered. This matters because the decision to undrift a + ;; procedure can be affected by whether or not the ancestors have + ;; been undrifted. + (set-procedure-free-callers! + procedure + (sort (procedure-free-callers procedure) + (lambda (x y) + (let ((y (procedure-block y)) + (x (procedure-block x))) + (and (not (eq? y x)) + (original-block-ancestor-or-self? y x))))))) (define (initialize-arguments! application) (if (application/combination? application) @@ -237,15 +250,15 @@ to #F whenever a closure is identified. (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 reason1 reason2))))) (define (close-procedure! procedure reason1 reason2) + (set-procedure-closing-limit! procedure false) + (if (procedure-virtual-closure? procedure) + (set-procedure-virtual-closure?! procedure false)) (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 + ;; We can't change the closing block yet. `setup-block-types!' + ;; 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. @@ -286,7 +299,7 @@ to #F whenever a closure is identified. (for-each (lambda (procedure*) (if (not (procedure-closure-context procedure*)) - (let ((parent (procedure-current-parent 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. @@ -308,27 +321,13 @@ to #F whenever a closure is identified. (undrift-procedure! procedure* binding-block))))))) (procedure-free-callers procedure)))) -;;; Don't update the block-parent (i.e. closing-block) of a procedure -;;; anywhere in this pass, because the order in which the side effects -;;; happen can permit blocks to be lost if this is done. If we were -;;; to do this update, the block-parent and the closing-limit would be -;;; the same, so instead use the closing-limit. This introduces an -;;; inconsistency which is fixed in the compiler's next pass, -;;; setup-block-types!, in which any procedure whose closing-limit and -;;; block-parent differ is closed (this is the definition of a -;;; closure). - -(define-integrable (procedure-current-parent procedure) - (procedure-closing-limit procedure)) - (define (undrift-procedure! procedure new-parent) (let ((block (procedure-block procedure)) - (parent (procedure-current-parent 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))) - ;; Don't set this! See note above. - ;; (set-block-parent! block new-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))) @@ -348,17 +347,15 @@ to #F whenever a closure is identified. procedure))))) (examine-free-callers! procedure))) -;; These are like the corresponding standard block operations, but -;; they ignore any block drifting caused by envopt. +;;; These are like the corresponding standard block operations, but +;;; they ignore any block drifting caused by envopt. (define (original-block-ancestor-or-self? block block*) - (define (loop block) - (and block - (or (eq? block block*) - (loop (original-block-parent block))))) - (or (eq? block block*) - (loop (original-block-parent block)))) + (let loop ((block (original-block-parent block))) + (and block + (or (eq? block block*) + (loop (original-block-parent block))))))) (define (original-block-nearest-common-ancestor block block*) (let loop