#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 1.2 1987/10/05 20:45:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 4.1 1987/12/04 19:06:29 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Dataflow Analysis: Constant Folding
+;;;; Constant Folding
(declare (usual-integrations))
\f
(package (fold-constants)
-;;;; Fold constants
-
-(define-export (fold-constants vnodes combinations receiver)
- (define (loop vnodes combinations)
- (let ((unknown-vnodes (eliminate-known-nodes vnodes)))
- (fold-combinations combinations
+(define-export (fold-constants lvalues applications)
+ (let loop
+ ((lvalues lvalues)
+ (combinations
+ (list-transform-positive applications application/combination?)))
+ (let ((unknown-lvalues (eliminate-known-nodes lvalues)))
+ (transmit-values (fold-combinations combinations)
(lambda (any-folded? not-folded)
(if any-folded?
- (loop unknown-vnodes not-folded)
- (receiver unknown-vnodes not-folded))))))
- (loop vnodes combinations))
+ (loop unknown-lvalues not-folded)
+ not-folded))))))
-(define (eliminate-known-nodes vnodes)
+(define (eliminate-known-nodes lvalues)
(let ((knowable-nodes
- (list-transform-positive vnodes
- (lambda (vnode)
- (and (not (or (vnode-unknowable? vnode)
- ;; Does this really matter? Seems like it
- ;; should be a noop if there is only one
- ;; value.
- (and (variable? vnode)
- (variable-assigned? vnode)
+ (list-transform-positive lvalues
+ (lambda (lvalue)
+ (and (not (or (lvalue-passed-in? lvalue)
+ (and (variable? lvalue)
+ (variable-assigned? lvalue)
(not (memq 'CONSTANT
- (variable-declarations vnode))))))
- (let ((procedures (vnode-procedures vnode))
- (values (vnode-values vnode)))
- (if (null? values)
- (and (not (null? procedures))
- (null? (cdr procedures)))
- (and (null? procedures)
- (null? (cdr values))
- (let ((value (car values)))
- (or (block? value)
- (and (constant? value)
- (object-immutable?
- (constant-value value)))))))))))))
- (for-each vnode-knowable! knowable-nodes)
- (transitive-closure delete-if-known! knowable-nodes))
- ;; **** Could flush KNOWABLE? and UNKNOWABLE? marks at this point.
- (list-transform-negative vnodes vnode-known?))
-
-(define (delete-if-known! vnode)
- (if (and (not (vnode-known? vnode))
- (null? (vnode-backward-links vnode)))
- (let ((value (car (if (null? (vnode-procedures vnode))
- (vnode-values vnode)
- (vnode-procedures vnode))))
- (forward-links (vnode-forward-links vnode)))
- (vnode-delete! vnode)
- (for-each (lambda (vnode*)
- ;; This is needed because, previously, VNODE*
- ;; inherited this value from VNODE.
- (vnode-connect! vnode* value)
- (if (vnode-knowable? vnode*)
- (enqueue-node! vnode*)))
- forward-links)
- (set-vnode-known-value! vnode value))))
+ (variable-declarations lvalue))))))
+ (let ((values (lvalue-values lvalue)))
+ (and (not (null? values))
+ (null? (cdr values))
+ (or (rvalue/procedure? (car values))
+ (and (rvalue/constant? (car values))
+ (object-immutable?
+ (constant-value (car values))))))))))))
+ (for-each (lambda (lvalue) (lvalue-mark-set! lvalue 'KNOWABLE))
+ knowable-nodes)
+ (transitive-closure false delete-if-known! knowable-nodes)
+ (for-each (lambda (lvalue) (lvalue-mark-clear! lvalue 'KNOWABLE))
+ knowable-nodes))
+ (list-transform-negative lvalues lvalue-known-value))
+
+(define (delete-if-known! lvalue)
+ (if (and (not (lvalue-known-value lvalue))
+ (null? (lvalue-backward-links lvalue)))
+ (let ((value (car (lvalue-values lvalue))))
+ (for-each (lambda (lvalue*)
+ (set-lvalue-backward-links!
+ lvalue*
+ (delq! lvalue (lvalue-backward-links lvalue*)))
+ ;; This is needed because, previously, LVALUE*
+ ;; inherited this value from LVALUE.
+ (lvalue-connect!:rvalue lvalue* value)
+ (if (lvalue-mark-set? lvalue* 'KNOWABLE)
+ (enqueue-node! lvalue*)))
+ (lvalue-forward-links lvalue))
+ (set-lvalue-forward-links! lvalue '())
+ (set-lvalue-initial-values! lvalue (list value))
+ (set-lvalue-known-value! lvalue value))))
\f
-(define (fold-combinations combinations receiver)
+(define (fold-combinations combinations)
(if (null? combinations)
- (receiver false '())
- (fold-combinations (cdr combinations)
+ (return-2 false '())
+ (transmit-values (fold-combinations (cdr combinations))
(lambda (any-folded? not-folded)
(if (fold-combination (car combinations))
- (receiver true not-folded)
- (receiver any-folded? (cons (car combinations) not-folded)))))))
+ (return-2 true not-folded)
+ (return-2 any-folded? (cons (car combinations) not-folded)))))))
(define (fold-combination combination)
- (let ((operator (combination-operator combination))
- (operands (combination-operands combination)))
- (and (subproblem-known-constant? operator)
- (all-known-constants? operands)
- (let ((operator (subproblem-constant-value operator)))
+ (let ((operator (combination/operator combination))
+ (continuation (combination/continuation combination))
+ (operands (combination/operands combination)))
+ (and (rvalue-known-constant? operator)
+ (let ((operator (rvalue-constant-value operator)))
(and (operator-constant-foldable? operator)
- (begin (let ((value
- (make-constant
- (apply operator
- (map subproblem-constant-value
- operands))))
- (cvalue (combination-value combination)))
- (vnode-known! cvalue value)
- (set-vnode-known-value! cvalue value))
- (set-combination-constant?! combination true)
- ;; Discard useless information to save space.
- (let ((block (combination-block combination)))
- (set-block-combinations!
- block
- (delq! combination (block-combinations block))))
- (set-combination-operator! combination false)
- (set-combination-operands! combination '())
- (set-combination-procedures! combination '())
- (set-combination-known-operator! combination false)
- true))))))
-
-(define all-known-constants?
- (for-all? subproblem-known-constant?))
+ (primitive-arity-correct? operator (length operands))))
+ ;; (rvalue-known? continuation)
+ ;; (uni-continuation? (rvalue-known-value continuation))
+ (for-all? operands rvalue-known-constant?)
+ (begin
+ (let ((constant
+ (make-constant
+ (apply (rvalue-constant-value operator)
+ (map rvalue-constant-value operands)))))
+ (combination/constant! combination constant)
+ (map (lambda (value)
+ (if (uni-continuation? value)
+ (lvalue-connect!:rvalue
+ (uni-continuation/parameter value)
+ constant)))
+ (rvalue-values continuation)))
+ true))))
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 1.2 1987/10/05 20:44:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 4.1 1987/12/04 19:06:50 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Dataflow Analysis: Outer Analysis
+;;;; Dataflow analysis: track values into or out of the graph
(declare (usual-integrations))
\f
(package (outer-analysis)
-;;;; Outer analysis
-
-;;; When this pass is completed, any combination which is known to
-;;; call only known procedures contains all of the procedural
-;;; arguments in its COMBINATION-PROCEDURES slot. This is taken
-;;; advantage of by the closure analysis.
-
-(define more-unknowable-vnodes?)
-
-(define-export (outer-analysis blocks vnodes combinations procedures
- quotations)
- (fluid-let ((more-unknowable-vnodes? false))
- (define (loop)
- (if more-unknowable-vnodes?
- (begin (set! more-unknowable-vnodes? false)
- (for-each check-combination combinations)
- (loop))))
- (for-each analyze-block blocks)
- ;; Don't bother to analyze ACCESSes now.
- (for-each (lambda (vnode)
- (if (access? vnode) (make-vnode-unknowable! vnode)))
- vnodes)
- (for-each (lambda (quotation)
- (let ((value (quotation-value quotation)))
- (if (vnode? value)
- (for-each make-procedure-externally-visible!
- (vnode-procedures value)))))
- quotations)
- (for-each prepare-combination combinations)
- (loop)))
-
-(define (analyze-block block)
- (if (ic-block? block)
- (begin (if (block-outer? block)
- (for-each make-vnode-externally-assignable!
- (block-free-variables block)))
- (for-each make-vnode-externally-accessible!
- (block-bound-variables block)))))
+(define-export (outer-analysis root-expression procedures applications)
+ (transitive-closure
+ (lambda ()
+ ;; Sort of a kludge, we assume that the root expression is
+ ;; evaluated in an IC block. Maybe this isn't so.
+ (block-passed-out! (expression-block root-expression))
+ (lvalue-passed-in! (expression-continuation root-expression))
+ (for-each (lambda (procedure)
+ ;; This is a kludge to handle the lack of a model for
+ ;; what really happens with rest parameters.
+ (if (procedure-rest procedure)
+ (lvalue-passed-in! (procedure-rest procedure))))
+ procedures)
+ (for-each prepare-application applications))
+ check-application
+ applications))
\f
-(define (prepare-combination combination)
- (set-combination-procedures!
- combination
- (mapcan (lambda (operand)
- (list-copy (subproblem-procedures operand)))
- (combination-operands combination)))
- (if (not (null? (subproblem-values (combination-operator combination))))
- (begin (combination-operator-unknowable! combination)
- (make-vnode-unknowable! (combination-value combination)))))
-
-(define any-primitives?
- (there-exists? primitive-procedure-constant?))
-
-(define (check-combination combination)
- (if (subproblem-unknowable? (combination-operator combination))
- (begin (combination-operator-unknowable! combination)
- (make-vnode-unknowable! (combination-value combination))))
- (if (any-unknowable-subproblems? (combination-operands combination))
- (make-vnode-unknowable! (combination-value combination))))
-
-(define any-unknowable-subproblems?
- (there-exists? subproblem-unknowable?))
-
-(define (combination-operator-unknowable! combination)
- (let ((procedures (combination-procedures combination)))
- (set-combination-procedures! combination '())
- (for-each make-procedure-externally-visible! procedures)))
+(define (prepare-application application)
+ (let ((values
+ (let ((operands (application-operands application)))
+ (if (null? operands)
+ '()
+ (eq-set-union* (rvalue-values (car operands))
+ (map rvalue-values (cdr operands)))))))
+ (set-application-operand-values! application values)
+ (set-application-arguments! application values))
+ ;; Need more sophisticated test here so that particular primitive
+ ;; operators only pass out specific operands. A good test case is
+ ;; `lexical-unassigned?' with a known block for its first argument
+ ;; and a known symbol for its second. Unfortunately, doing this
+ ;; optimally introduces feedback in this analysis.
+ (if (there-exists? (rvalue-values (application-operator application))
+ (lambda (value) (not (rvalue/procedure? value))))
+ (application-arguments-passed-out! application)))
+
+(define (check-application application)
+ (if (rvalue-passed-in? (application-operator application))
+ (application-arguments-passed-out! application))
+#|
+ ;; This looks like it isn't necessary, but I seem to recall that it
+ ;; was needed to fix some bug. If so, then there is a serious
+ ;; problem, since we could "throw" into some operand other than
+ ;; the continuation. -- CPH.
+ (if (and (application/combination? application)
+ (there-exists? (combination/operands application)
+ rvalue-passed-in?))
+ (for-each (lambda (value)
+ (if (uni-continuation? value)
+ (lvalue-passed-in! (uni-continuation/parameter value))))
+ (rvalue-values (combination/continuation application))))
+|#
+ )
+
+(define (application-arguments-passed-out! application)
+ (let ((arguments (application-arguments application)))
+ (set-application-arguments! application '())
+ (for-each rvalue-passed-out! arguments)))
\f
-(define (make-vnode-externally-assignable! vnode)
- (make-vnode-unknowable! vnode)
- (make-vnode-externally-visible! vnode))
-
-(define (make-vnode-externally-accessible! vnode)
- (cond ((not (memq 'CONSTANT (variable-declarations vnode)))
- (make-vnode-externally-assignable! vnode))
- ((not (vnode-externally-visible? vnode))
- (make-vnode-externally-visible! vnode))))
-
-(define (make-vnode-externally-visible! vnode)
- (if (not (vnode-externally-visible? vnode))
- (begin (vnode-externally-visible! vnode)
- (for-each make-procedure-externally-visible!
- (vnode-procedures vnode)))))
-
-(define (make-procedure-externally-visible! procedure)
- (if (not (procedure-externally-visible? procedure))
- (begin (procedure-externally-visible! procedure)
- (closure-procedure! procedure)
- (for-each make-vnode-unknowable! (procedure-required procedure))
- (for-each make-vnode-unknowable! (procedure-optional procedure))
- (if (procedure-rest procedure)
- ;; This is not really unknowable -- it is a list
- ;; whose length and elements are unknowable.
- (make-vnode-unknowable! (procedure-rest procedure)))
- (for-each make-procedure-externally-visible!
- (rvalue-procedures (procedure-value procedure))))))
-
-(define (make-vnode-unknowable! vnode)
- (if (not (vnode-unknowable? vnode))
- (begin (set! more-unknowable-vnodes? true)
- (vnode-unknowable! vnode)
- (make-vnode-forward-links-unknowable! vnode))))
-
-(define (make-vnode-forward-links-unknowable! vnode)
- ;; No recursion is needed here because the graph is transitively
- ;; closed, and thus the forward links of a node's forward links are
- ;; a subset of the node's forward links.
- (for-each (lambda (vnode)
- (if (not (vnode-unknowable? vnode))
- (begin (set! more-unknowable-vnodes? true)
- (vnode-unknowable! vnode))))
- (vnode-forward-links vnode)))
+(define (rvalue-passed-out! rvalue)
+ ((method-table-lookup passed-out-methods (tagged-vector/index rvalue))
+ rvalue))
+
+(define-integrable (%rvalue-passed-out! rvalue)
+ (set-rvalue-%passed-out?! rvalue true))
+
+(define passed-out-methods
+ (make-method-table rvalue-types %rvalue-passed-out!))
+
+(define-method-table-entry 'REFERENCE passed-out-methods
+ (lambda (reference)
+ (lvalue-passed-out! (reference-lvalue reference))))
+
+(define-method-table-entry 'PROCEDURE passed-out-methods
+ (lambda (procedure)
+ (if (not (rvalue-%passed-out? procedure))
+ (begin
+ (%rvalue-passed-out! procedure)
+ ;; The rest parameter was marked in the initialization.
+ (for-each lvalue-passed-in! (procedure-required procedure))
+ (for-each lvalue-passed-in! (procedure-optional procedure))))))
+
+(define (block-passed-out! block)
+ (if (not (rvalue-%passed-out? block))
+ (begin
+ (%rvalue-passed-out! block)
+ (for-each (let ((procedure (block-procedure block)))
+ (if (and (rvalue/procedure? procedure)
+ (not (procedure-continuation? procedure)))
+ (let ((continuation
+ (procedure-continuation-lvalue procedure)))
+ (lambda (lvalue)
+ (if (not (eq? lvalue continuation))
+ (lvalue-externally-visible! lvalue))))
+ lvalue-externally-visible!))
+ (block-bound-variables block))
+ (let ((parent (block-parent block)))
+ (if parent
+ (block-passed-out! parent)
+ (for-each lvalue-externally-visible!
+ (block-free-variables block)))))))
+
+(define-method-table-entry 'BLOCK passed-out-methods
+ block-passed-out!)
+\f
+(define (lvalue-externally-visible! lvalue)
+ (lvalue-passed-in! lvalue)
+ (lvalue-passed-out! lvalue))
+
+(define (lvalue-passed-in! lvalue)
+ (if (lvalue-passed-in? lvalue)
+ (set-lvalue-passed-in?! lvalue 'SOURCE)
+ (begin
+ (%lvalue-passed-in! lvalue 'SOURCE)
+ (for-each (lambda (lvalue)
+ (if (not (lvalue-passed-in? lvalue))
+ (%lvalue-passed-in! lvalue 'INHERITED)))
+ (lvalue-forward-links lvalue)))))
+
+(define (%lvalue-passed-in! lvalue value)
+ (set-lvalue-passed-in?! lvalue value)
+ (for-each (lambda (application)
+ (if (not (null? (application-arguments application)))
+ (enqueue-node! application)))
+ (lvalue-applications lvalue)))
+
+(define (lvalue-passed-out! lvalue)
+ (if (not (lvalue-passed-out? lvalue))
+ (begin (%lvalue-passed-out! lvalue)
+ (for-each %lvalue-passed-out! (lvalue-backward-links lvalue))
+ (for-each rvalue-passed-out! (lvalue-values lvalue)))))
+
+(define-integrable (%lvalue-passed-out! lvalue)
+ (set-lvalue-passed-out?! lvalue true))
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 1.3 1987/07/28 22:50:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.1 1987/12/04 19:06:39 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
(package (simulate-application)
-;;;; Simulate Application
-
-(define-export (simulate-application vnodes combinations)
- (for-each (lambda (vnode)
- (set-vnode-procedures-cache! vnode
- (vnode-initial-procedures vnode)))
- vnodes)
- (for-each (lambda (combination)
- (set-combination-procedures! combination '()))
- combinations)
- (transitive-closure process-combination combinations)
- (for-each (lambda (vnode)
- (set-vnode-procedures-cache! vnode 'NOT-CACHED))
- vnodes))
+(define-export (simulate-application lvalues applications)
+ (for-each initialize-lvalue-cache! lvalues)
+ (for-each (lambda (application)
+ (set-application-operators! application '()))
+ applications)
+ (transitive-closure false process-application applications)
+ (for-each reset-lvalue-cache! lvalues))
+
+(define (process-application application)
+ (set-application-operators!
+ application
+ (let ((operator (application-operator application)))
+ ((method-table-lookup process-application-methods
+ (tagged-vector/index operator))
+ (application-operators application)
+ operator
+ (operator-applicator application)))))
+
+(define process-application-methods
+ (make-method-table rvalue-types
+ (lambda (old operator apply-operator)
+ (warn "Unapplicable operator" operator)
+ operator)))
+
+(let ((processor
+ (lambda (old operator apply-operator)
+ (if (not (null? old))
+ (error "Encountered constant-operator application twice"
+ operator))
+ (apply-operator operator)
+ operator)))
+ (define-method-table-entry 'PROCEDURE process-application-methods processor)
+ (define-method-table-entry 'CONSTANT process-application-methods processor))
+
+(define-method-table-entry 'REFERENCE process-application-methods
+ (lambda (old operator apply-operator)
+ (let ((new (lvalue-values-cache (reference-lvalue operator))))
+ (let loop ((operators new))
+ ;; We can use `eq?' here because we assume that
+ ;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
+ ;; This is also noted at the definition of `eq-set-union'.
+ (if (eq? operators old)
+ new
+ (begin (apply-operator (car operators))
+ (loop (cdr operators))))))))
\f
-(define (process-combination combination)
- (set-combination-procedures!
- combination
- (let ((operator (subproblem-value (combination-operator combination)))
- (old (combination-procedures combination))
- (apply-procedure
- (procedure-applicator (combination-operands combination)
- (combination-value combination))))
- (define (process-vnode vnode)
- (let ((new (vnode-procedures-cache vnode)))
- (define (loop procedures)
- ;; We can use `eq?' here because we assume that
- ;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
- ;; This is also noted at the definition of `eq-set-union'.
- (if (eq? procedures old)
- new
- (begin (apply-procedure (car procedures))
- (loop (cdr procedures)))))
- (loop new)))
- (cond ((vnode? operator)
- (process-vnode operator))
- ((reference? operator)
- (process-vnode (reference-variable operator)))
- ((not (null? old))
- (error "Encountered constant-operator combination twice"
- combination))
- (else
- (if (procedure? operator)
- (apply-procedure operator))
- true)))))
+(define (operator-applicator application)
+ (let ((operands (application-operands application)))
+ (let ((number-supplied (length operands)))
+ (lambda (operator)
+ (cond ((rvalue/procedure? operator)
+ (set-procedure-applications!
+ operator
+ (cons application (procedure-applications operator)))
+ (if (not (procedure-arity-correct? operator number-supplied))
+ (warn "Wrong number of arguments" operator operands))
+ ;; We should have some kind of LIST rvalue type to handle
+ ;; the case of rest parameters, but for now we just
+ ;; define them to be passed-in. This is handled
+ ;; specially in that part of the analysis.
+ (let loop
+ ((parameters
+ (append (procedure-required operator)
+ (procedure-optional operator)))
+ (operands operands))
+ (if (not (null? parameters))
+ (if (null? operands)
+ (for-each lvalue-unassigned! parameters)
+ (begin
+ (lvalue-connect! (car parameters) (car operands))
+ (loop (cdr parameters) (cdr operands)))))))
+ ((rvalue/constant? operator)
+ (let ((value (constant-value operator)))
+ (if (primitive-procedure? value)
+ (if (not (primitive-arity-correct? value
+ (-1+ number-supplied)))
+ (warn
+ "Primitive called with wrong number of arguments"
+ value
+ number-supplied))
+ (warn "Inapplicable operator" value))))
+ (else
+ (warn "Inapplicable operator" operator)))))))
\f
-(define (procedure-applicator operands combination-value)
- (let ((number-supplied (length operands)))
- (lambda (procedure)
- (let ((number-required (length (procedure-required procedure)))
- (number-optional (length (procedure-optional procedure)))
- (rest (procedure-rest procedure)))
- (cond ((< number-supplied number-required)
- (warn "Too few arguments" procedure operands))
- (rest
- (if (<= number-supplied (+ number-required number-optional))
- ((vnode-connect!:constant (make-constant '())) rest)
- ;; Can make this a LIST rvalue when that is implemented.
- (vnode-unknowable! rest)))
- ((> number-supplied (+ number-required number-optional))
- (warn "Too many arguments" procedure operands))))
- (let loop ((parameters
- (append (procedure-required procedure)
- (procedure-optional procedure)))
- (operands operands))
- (if (not (null? parameters))
- (if (null? operands)
- (for-each vnode-unknowable! parameters)
- (begin (vnode-connect! (car parameters) (car operands))
- (loop (cdr parameters) (cdr operands))))))
- ((vnode-connect!:vnode (procedure-value procedure)) combination-value))))
+(define (initialize-lvalue-cache! lvalue)
+ (set-lvalue-values-cache! lvalue (lvalue-values lvalue)))
+
+(define (lvalue-values lvalue)
+ ;; This is slow but works even with cycles in the DFG.
+ (let ((lvalues '()))
+ (let loop ((lvalue lvalue))
+ (if (not (memq lvalue lvalues))
+ (begin (set! lvalues (cons lvalue lvalues))
+ (for-each loop (lvalue-backward-links lvalue)))))
+ (eq-set-union* (lvalue-initial-values (car lvalues))
+ (map lvalue-initial-values (cdr lvalues)))))
\f
-(define-integrable (vnode-connect! vnode operand)
- ((&vnode-connect! (subproblem-value operand)) vnode))
-
-(define ((vnode-connect!:procedure procedure) vnode)
- (let ((procedures (vnode-initial-procedures vnode)))
- (if (not (memq procedure procedures))
- (set-vnode-initial-procedures! vnode (cons procedure procedures))))
- (let loop ((vnode vnode))
- (let ((procedures (vnode-procedures-cache vnode)))
- (if (not (memq procedure procedures))
- (begin (enqueue-nodes! (vnode-combinations vnode))
- (set-vnode-procedures-cache! vnode
- (cons procedure procedures))
- (for-each loop (vnode-forward-links vnode)))))))
-
-(define (vnode-connect!:vnode from)
- (define (self to)
- (if (not (memq from (vnode-backward-links to)))
- (begin (enqueue-nodes! (vnode-combinations to))
- (set-vnode-backward-links! to
- (cons from
- (vnode-backward-links to)))
- (set-vnode-forward-links! from
- (cons to (vnode-forward-links from)))
- (set-vnode-procedures-cache!
- to
- (eq-set-union (vnode-procedures-cache from)
- (vnode-procedures-cache to)))
- (for-each (lambda (backward)
- ((vnode-connect!:vnode backward) to))
- (vnode-backward-links from))
- (for-each self (vnode-forward-links to)))))
- self)
-
-(define &vnode-connect!
- (standard-rvalue-operation vnode-connect!:constant vnode-connect!:procedure
- vnode-connect!:vnode))
+(define (lvalue-unassigned! lvalue)
+ (lvalue-connect! lvalue (make-constant (scode/make-unassigned-object))))
+
+(define-integrable (lvalue-connect! lvalue rvalue)
+ (if (rvalue/reference? rvalue)
+ (lvalue-connect!:lvalue lvalue (reference-lvalue rvalue))
+ (lvalue-connect!:rvalue lvalue rvalue)))
+
+(define (lvalue-connect!:rvalue lvalue rvalue)
+ (if (not (memq rvalue (lvalue-initial-values lvalue)))
+ (begin
+ (set-lvalue-initial-values! lvalue
+ (cons rvalue
+ (lvalue-initial-values lvalue)))
+ (if (not (memq rvalue (lvalue-values-cache lvalue)))
+ (begin
+ (update-lvalue-cache! lvalue rvalue)
+ (for-each (lambda (lvalue)
+ (if (not (memq rvalue (lvalue-values-cache lvalue)))
+ (update-lvalue-cache! lvalue rvalue)))
+ (lvalue-forward-links lvalue)))))))
+
+(define (update-lvalue-cache! lvalue rvalue)
+ (enqueue-nodes! (lvalue-applications lvalue))
+ (set-lvalue-values-cache! lvalue
+ (cons rvalue
+ (lvalue-values-cache lvalue))))
+
+(define (lvalue-connect!:lvalue to from)
+ (if (not (memq from (lvalue-backward-links to)))
+ (begin
+ (enqueue-nodes! (lvalue-applications to))
+ (set-lvalue-backward-links! to (cons from (lvalue-backward-links to)))
+ (set-lvalue-forward-links! from (cons to (lvalue-forward-links from)))
+ (set-lvalue-values-cache! to
+ (eq-set-union (lvalue-values-cache from)
+ (lvalue-values-cache to)))
+ (for-each (lambda (from)
+ (lvalue-connect!:lvalue to from))
+ (lvalue-backward-links from))
+ (for-each (lambda (to)
+ (lvalue-connect!:lvalue to from))
+ (lvalue-forward-links to)))))
)
\ No newline at end of file
projects / mit-scheme.git / commitdiff