From: Chris Hanson Date: Thu, 1 Nov 2001 18:37:39 +0000 (+0000) Subject: Rewrite for style. X-Git-Tag: 20090517-FFI~2479 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=aa9322a9f9c6762f46cc61345c5d476e5531aed1;p=mit-scheme.git Rewrite for style. --- diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index a9bc1b212..179ee0e69 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.19 2001/11/01 18:29:59 cph Exp $ +$Id: closan.scm,v 4.20 2001/11/01 18:37:39 cph Exp $ Copyright (c) 1987-1991, 1998, 1999, 2001 Massachusetts Institute of Technology @@ -47,16 +47,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (lambda (combination) (let ((values (let ((operands (application-operands combination))) - (if (null? operands) - '() + (if (pair? operands) (eq-set-union* (rvalue-values (car operands)) - (map rvalue-values (cdr operands))))))) + (map rvalue-values (cdr operands))) + '())))) (set-application-operand-values! combination values) (for-each (lambda (value) (if (and (rvalue/procedure? value) (not (procedure-continuation? value))) - (set-procedure-virtual-closure?! value true))) + (set-procedure-virtual-closure?! value #t))) values)) (set-combination/model! combination @@ -71,7 +71,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (for-each (lambda (procedure) (if (procedure-passed-out? procedure) - (close-procedure! procedure 'PASSED-OUT false) + (close-procedure! procedure 'PASSED-OUT #f) (analyze-procedure procedure (procedure-closing-block procedure)))) @@ -102,8 +102,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; they have been marked as passed out already. (close-rvalue! operator 'APPLY-COMPATIBILITY combination)) ((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 + ;; This is the NOP node case. This combination should not + ;; be executed, so it should have no effect on any items ;; involved in it. unspecific) ((not proc) @@ -111,11 +111,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (model (car procs))) (set-combination/model! combination (if (eq? class 'APPLY-COMPATIBILITY) - false + #f model)) (if (eq? class 'POTENTIAL) (for-each (lambda (proc) - (set-procedure-virtual-closure?! proc true)) + (set-procedure-virtual-closure?! proc #t)) procs) (begin (close-rvalue! operator class combination) @@ -144,11 +144,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let loop ((procs (cdr procs)) (class - (if (or (procedure/closure? model) (pending-undrifting? model)) - 'COMPATIBILITY ; Cop-out. Could be postponed 'til later. + (if (or (procedure/closure? model) + (pending-undrifting? model)) + 'COMPATIBILITY ;Cop-out. Could be postponed 'til later. 'POTENTIAL))) - (if (null? procs) - class + (if (pair? procs) (let ((this (car procs))) (with-values (lambda () (procedure-arity-encoding this)) (lambda (this-min this-max) @@ -161,7 +161,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (not (pending-undrifting? this))) class 'COMPATIBILITY)) - 'APPLY-COMPATIBILITY))))))))))) + 'APPLY-COMPATIBILITY)))) + class))))))) (define-integrable (close-rvalue! rvalue reason1 reason2) (close-values! (rvalue-values rvalue) reason1 reason2)) @@ -193,9 +194,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; Force the procedure's type to CLOSURE. Don't change the ;; closing block yet -- that will be taken care of by ;; `setup-block-types!'. - (set-procedure-closure-context! procedure true) + (set-procedure-closure-context! procedure #t) (if (procedure-virtual-closure? procedure) - (set-procedure-virtual-closure?! procedure false)) + (set-procedure-virtual-closure?! procedure #f)) ;; This procedure no longer requires undrifting of others ;; since it has been closed anyway. (cancel-dependent-undrifting-constraints! procedure) @@ -206,9 +207,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; trivial now, so the callers are not affected. (if (not (procedure/trivial-closure? procedure)) (begin - (undrift-disowned-children! block block false + (undrift-disowned-children! block block #f 'CONTAGION procedure) - (examine-free-callers! procedure block false + (examine-free-callers! procedure block #f 'CONTAGION procedure) (guarantee-connectivity! procedure) ;; Guarantee that all callees are contained within. @@ -237,7 +238,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let ((block** (variable-block var))) (if (not (block-ancestor-or-self? block* block**)) (undrifting-constraint! - block* block** false 'CONTAGION procedure))))))) + block* block** #f 'CONTAGION procedure))))))) (block-free-variables block)))) (define (undrift-disowned-children! block block* procedure reason1 reason2) @@ -324,7 +325,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (undrifting-constraint! block block* procedure reason1 reason2) ;; Undrift `block' so it is a descendant of `block*' in order not ;; to close `procedure' for <`reason1',`reason2'> - ;; If `procedure' is false, undrift unconditionally + ;; If `procedure' is #f, undrift unconditionally (if (block-ancestor? block block*) (error "Attempt to undrift block below an ancestor:" block block*)) (if (or (not procedure) @@ -382,7 +383,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (cdr entry)) (if (there-exists? (cdr entry) (lambda (entry*) - (and (not (null? (cdr entry*))) + (and (pair? (cdr entry*)) (block-ancestor-or-self? (car entry*) block)))) (close-non-descendant-callees! (car entry) block 'CONTAGION procedure)))) @@ -402,10 +403,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (and condition (eq? 'CONTAGION (cadr condition)) (procedure/trivial-closure? (caddr condition))))))))) - (if (not (null? entries)) + (if (pair? entries) (undrift-block! (car entry) (reduce original-block-nearest-ancestor - false + #f (map car entries)))))) constraints)) diff --git a/v7/src/compiler/fgopt/envopt.scm b/v7/src/compiler/fgopt/envopt.scm index d76423b0c..c8a85651a 100644 --- a/v7/src/compiler/fgopt/envopt.scm +++ b/v7/src/compiler/fgopt/envopt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: envopt.scm,v 1.9 2001/11/01 18:30:05 cph Exp $ +$Id: envopt.scm,v 1.10 2001/11/01 18:35:36 cph Exp $ Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology @@ -28,86 +28,27 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (optimize-environments! procedures&continuations) ;; Does this really have to ignore continuations? ;; Is this only because we implement continuations differently? - (let ((procedures (list-transform-negative - procedures&continuations - procedure-continuation?))) - (if (not compiler:optimize-environments?) + (let ((procedures + (list-transform-negative procedures&continuations + procedure-continuation?))) + (if compiler:optimize-environments? + (begin + (for-each initialize-target-block! procedures) + (transitive-closure #f examine-procedure! procedures) + (for-each choose-target-block! procedures)) (for-each (lambda (proc) ;; This is needed by the next pass. (set-procedure-target-block! proc (procedure-closing-block proc))) - procedures) - (begin - (for-each initialize-target-block! procedures) - (transitive-closure false examine-procedure! procedures) - (for-each choose-target-block! procedures))))) - -#| -;; All the commented out code would be used if the compiler was based -;; on the concept of quantities, rather than on the concept of locations -;; (variables). The relevant question would then be -;; "What quantities not computed internally does this code use?" rather than -;; "What locations does this code reference freely?" -;; -;; Until we understand better the relationship between circularities in the -;; control graph and assignment, we will not be able to move to the quantity -;; world (which is ultimately functional). - -(define (for-each-callee! block procedure) - (for-each-block-descendant! 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*))))) + procedures)))) -(define (check-bound-variable! procedure block variable) - (let ((value (lvalue-known-value variable))) - (if (and value - (rvalue/procedure? value) - ;; 1. Worry about procedures which receive their - ;; descendants as arguments. How can we distinguish - ;; that from letrec in the case of children? - ;; 2. Do we really have to worry? Internal - ;; procedures should move as a block with the parent, - ;; only depending on free variables and other - ;; external stuff, and irrelevant of whether they are - ;; closures or not. - (not (block-ancestor-or-self? (procedure-block value) block))) - (add-caller&callee! procedure value variable)))) - -(define (check-callee! procedure block callee) - ;; Here we do not need to worry about such things *** - (if (not (block-ancestor-or-self? (procedure-block callee) block)) - (add-caller&callee! procedure callee *NEED-A-VARIABLE-HERE*))) -|# - (define (initialize-target-block! procedure) (let ((block (procedure-block procedure))) - (let loop ((target-block (find-outermost-block block)) - (free-vars (block-free-variables block))) - (if (null? free-vars) - (begin - #| - ;; It seems that enabling this makes the analysis worse for no - ;; good reason. I should understand why. - ;; Abstractly, as long as the compiler is variable/location based - ;; rather than quantity/fixed-point based, looking at the free - ;; variables should be sufficient. - (for-each (lambda (var) - (check-bound-variable! procedure block var)) - (block-bound-variables block)) - (for-each-callee! - block - (lambda (callee) - (check-callee! procedure block callee))) - |# - (set-procedure-target-block! procedure target-block)) + (let loop + ((target-block (find-outermost-block block)) + (free-vars (block-free-variables block))) + (if (pair? free-vars) (let ((value (lvalue-known-value (car free-vars))) (new-block (variable-block (car free-vars)))) ;; Should this piece of code deal with sets @@ -126,57 +67,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; The current free variable is bound in a block ;; which encloses the current target block, ;; the limit is therefore the current target block. - (loop target-block (cdr free-vars))))))))) - -;;; choose-target-block! is simpler than the old version, below, -;;; because the undrifting code fixes LET-like procedures that -;;; would otherwise have been closed. + (loop target-block (cdr free-vars))))) + (set-procedure-target-block! procedure target-block))))) -(define (choose-target-block! procedure) - (let ((block (procedure-block procedure)) - (parent (procedure-closing-block procedure)) - (target-block (procedure-target-block procedure))) - ;; This now becomes `original-block-parent' of the procedure's - ;; invocation block. - (set-procedure-target-block! procedure parent) - (if (not (eq? parent target-block)) - (transfer-block-child! block parent target-block)))) - -#| -(define (choose-target-block! procedure) - (let ((block (procedure-block procedure)) - (parent (procedure-closing-block procedure)) - (target-block (procedure-target-block procedure))) - ;; This now becomes `original-block-parent' of the procedure's - ;; invocation block. - (set-procedure-target-block! procedure parent) - (if (and (block-ancestor? parent target-block) - ;; If none of the free variables of this procedure - ;; require lookup, then it will eventually become a - ;; trivial procedure. So it should be OK to raise it as - ;; far as we like. - (or (for-all? (block-free-variables block) - (lambda (variable) - (let ((value (lvalue-known-value variable))) - (and value - (or (eq? value procedure) - (rvalue/constant? value) - (and (rvalue/procedure? value) - (procedure/trivial-closure? - value))))))) - ;; The following clause makes some cases of LET-like - ;; procedures track their parents in order to avoid - ;; closing over the same variables twice. - (not (and (null? (procedure-free-callers procedure)) - (procedure-always-known-operator? procedure) - (for-all? (procedure-applications procedure) - (lambda (application) - (eq? (application-block application) - parent))))))) - (transfer-block-child! block parent target-block)) - unspecific)) -|# - ;; Note that when this is run there are no closures yet. ;; The closure analysis happens after this pass. @@ -186,7 +79,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let loop ((dependencies (procedure-free-callees procedure)) (target-block original)) ;; (constraint (block-ancestor-or-self? block target-block)) - (cond ((not (null? dependencies)) + (cond ((pair? dependencies) (let ((this-block (procedure-target-block (caar dependencies)))) (if (block-ancestor-or-self? this-block block) (loop (cdr dependencies) target-block) @@ -200,27 +93,28 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (set-procedure-target-block! procedure target-block) (enqueue-nodes! (procedure-free-callers procedure))))))) -;;; Utilities - -(define (add-caller&callee! procedure on-whom var) - (if (not (procedure-continuation? on-whom)) +(define (choose-target-block! procedure) + (let ((block (procedure-block procedure)) + (parent (procedure-closing-block procedure)) + (target-block (procedure-target-block procedure))) + ;; This now becomes `original-block-parent' of the procedure's + ;; invocation block. + (set-procedure-target-block! procedure parent) + (if (not (eq? parent target-block)) + (transfer-block-child! block parent target-block)))) + +(define (add-caller&callee! caller callee variable) + (if (not (procedure-continuation? callee)) (begin - (add-free-callee! procedure on-whom var) - (add-free-caller! on-whom procedure)))) - -(define (add-free-callee! procedure on-whom variable) - (let ((entries (procedure-free-callees procedure)) - (block (variable-block variable))) - (let ((entry (assq on-whom entries))) - (if entry - (if (not (memq block (cdr entry))) - (set-cdr! entry (cons block (cdr entry)))) - (set-procedure-free-callees! procedure - (cons (list on-whom block) entries)))))) - -(define (add-free-caller! procedure on-whom) - (let ((bucket (procedure-free-callers procedure))) - (cond ((null? bucket) - (set-procedure-free-callers! procedure (list on-whom))) - ((not (memq on-whom bucket)) - (set-procedure-free-callers! procedure (cons on-whom bucket)))))) \ No newline at end of file + (let ((entries (procedure-free-callees caller)) + (block (variable-block variable))) + (let ((entry (assq callee entries))) + (if entry + (if (not (memq block (cdr entry))) + (set-cdr! entry (cons block (cdr entry)))) + (set-procedure-free-callees! caller + (cons (list callee block) + entries))))) + (let ((callers (procedure-free-callers callee))) + (if (not (memq caller callers)) + (set-procedure-free-callers! callee (cons caller callers))))))) \ No newline at end of file