From 062bf3aa443c33a2f07fe929aba03fcd44d959b1 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 23 Sep 2011 00:18:13 +0200
Subject: [PATCH] more peval refactoring

* module/language/tree-il/optimize.scm (peval): Rename `var-table' to
  `store', as we're going to put some more things in it.  Rename
  `record-lexical-bindings' to `record-source-expression', which also
  takes the original, pre-renaming expression.  Keep a mapping from new
  expressions to original expressions, available using the
  `source-expression' helper.
---
 module/language/tree-il/optimize.scm | 24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 20087545c..7ac68e926 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -320,18 +320,28 @@ it does not handle <fix> and <let-values>, it should be called before
   (define (local-toplevel? name)
     (vhash-assq name local-toplevel-env))
 
-  (define var-table (build-var-table exp))
-  (define (record-lexical-bindings! x)
-    (set! var-table (build-var-table x var-table))
-    x)
+  (define store (build-var-table exp))
+
   (define (assigned-lexical? sym)
-    (let ((v (vhash-assq sym var-table)))
+    (let ((v (vhash-assq sym store)))
       (and v (var-set? (cdr v)))))
+
   (define (lexical-refcount sym)
-    (let ((v (vhash-assq sym var-table)))
+    (let ((v (vhash-assq sym store)))
       (if v (var-refcount (cdr v)) 0)))
 
+  (define (record-source-expression! orig new)
+    (set! store (vhash-consq new
+                             (source-expression orig)
+                             (build-var-table new store)))
+    new)
+
+  (define (source-expression new)
+    (let ((x (vhash-assq new store)))
+      (if x (cdr x) new)))
+
   (define residual-lexical-references (make-hash-table))
+
   (define (record-residual-lexical-reference! sym)
     (hashq-set! residual-lexical-references sym #t))
 
@@ -528,7 +538,7 @@ it does not handle <fix> and <let-values>, it should be called before
        ;; This is an anonymous lambda that we're going to inline.
        ;; Inlining creates new variable bindings, so we need to provide
        ;; the new code with fresh names.
-       (make-lambda src '() (record-lexical-bindings! (alpha-rename lc))))
+       (record-source-expression! new (alpha-rename new)))
       (_ new)))
 
   (catch 'match-error