#| -*-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
(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
(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))))
;; 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)
(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)
(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)
(not (pending-undrifting? this)))
class
'COMPATIBILITY))
- 'APPLY-COMPATIBILITY)))))))))))
+ 'APPLY-COMPATIBILITY))))
+ class)))))))
\f
(define-integrable (close-rvalue! rvalue reason1 reason2)
(close-values! (rvalue-values rvalue) reason1 reason2))
;; 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)
;; 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.
(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)
(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)
(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))))
(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))
#| -*-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
(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*)))
-|#
-\f
(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
;; 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)))))))))
-\f
-;;; 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))
-|#
-\f
;; Note that when this is run there are no closures yet.
;; The closure analysis happens after this pass.
(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)
(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))))
+\f
+(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
projects / mit-scheme.git / commitdiff