From 911c58b8da8c1b0089202b12e7e67a1ab4a4a854 Mon Sep 17 00:00:00 2001 From: Chris Hanson <org/chris-hanson/cph> Date: Fri, 4 Dec 1987 19:06:50 +0000 Subject: [PATCH] Major redesign of front end of compiler. Continuations are now modeled more exactly by means of a CPS-style analysis. Poppers have been flushed in favor of dynamic links, and optimizations have been added that eliminate the use of static and dynamic links in many cases. --- v7/src/compiler/fgopt/folcon.scm | 162 ++++++++++---------- v7/src/compiler/fgopt/outer.scm | 244 ++++++++++++++++-------------- v7/src/compiler/fgopt/simapp.scm | 245 +++++++++++++++++-------------- 3 files changed, 347 insertions(+), 304 deletions(-) diff --git a/v7/src/compiler/fgopt/folcon.scm b/v7/src/compiler/fgopt/folcon.scm index 62c1a0122..bff3111c3 100644 --- a/v7/src/compiler/fgopt/folcon.scm +++ b/v7/src/compiler/fgopt/folcon.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -32,107 +32,97 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Dataflow Analysis: Constant Folding +;;;; Constant Folding (declare (usual-integrations)) (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)))) -(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 diff --git a/v7/src/compiler/fgopt/outer.scm b/v7/src/compiler/fgopt/outer.scm index 68c4e0223..6097c9f4e 100644 --- a/v7/src/compiler/fgopt/outer.scm +++ b/v7/src/compiler/fgopt/outer.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -32,122 +32,144 @@ Technology nor of any adaptation thereof in any advertising, 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)) (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)) -(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))) -(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!) + +(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 diff --git a/v7/src/compiler/fgopt/simapp.scm b/v7/src/compiler/fgopt/simapp.scm index 68c6a91a5..c582e8589 100644 --- a/v7/src/compiler/fgopt/simapp.scm +++ b/v7/src/compiler/fgopt/simapp.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -38,114 +38,145 @@ MIT in each case. |# (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)))))))) -(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))))))) -(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))))) -(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 -- 2.25.1