#| -*-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
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.
|#
\f
(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)
(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)
(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)))
\f
(define (analyze-procedure procedure)
(for-each (lambda (variable)
(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)))
(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))))
\f
(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)))))))))))
\f
-(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*)))))
+\f
+(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)))
\f
;; These are like the corresponding standard block operations, but
;; they ignore any block drifting caused by envopt.
(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)
(eq? (car ancestry) (car ancestry*)))
(loop (car ancestry) (cdr ancestry) (cdr ancestry*))
join)))
-\f
-(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)))
-\f
-(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
projects / mit-scheme.git / commitdiff