From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 4 Dec 1987 19:06:50 +0000 (+0000)
Subject: Major redesign of front end of compiler.  Continuations are now
X-Git-Tag: 20090517-FFI~13023
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=911c58b8da8c1b0089202b12e7e67a1ab4a4a854;p=mit-scheme.git

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.
---

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