[Guile-commits] 01/01: Fix bug compiling fixpoint combinator

[Andy Wingo]

wingo pushed a commit to branch stable-2.0
in repository guile.

commit c691c0e15ab9c9b0d8638aad9b0112845fbdb580
Author: Andy Wingo <address@hidden>
Date:   Wed May 20 17:20:25 2015 +0200

    Fix bug compiling fixpoint combinator
    
    * module/language/tree-il/peval.scm (<operand>): Rename "alias-value"
      field to "alias", which is now an operand and not an expression.
      This allows the operand to capture its environment; before, the
      alias was being visited in its use environment instead of its
      definition environment.
      (peval): Adapt to operand change.
    * test-suite/tests/peval.test ("partial evaluation"): New test.
---
 module/language/tree-il/peval.scm |   18 ++++++++----------
 test-suite/tests/peval.test       |   24 +++++++++++++++++++++++-
 2 files changed, 31 insertions(+), 11 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 7dd572f..431c07e 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -281,7 +281,7 @@
 ;; 
 (define-record-type <operand>
   (%make-operand var sym visit source visit-count use-count
-                 copyable? residual-value constant-value alias-value)
+                 copyable? residual-value constant-value alias)
   operand?
   (var operand-var)
   (sym operand-sym)
@@ -292,7 +292,7 @@
   (copyable? operand-copyable? set-operand-copyable?!)
   (residual-value operand-residual-value %set-operand-residual-value!)
   (constant-value operand-constant-value set-operand-constant-value!)
-  (alias-value operand-alias-value set-operand-alias-value!))
+  (alias operand-alias set-operand-alias!))
 
 (define* (make-operand var sym #:optional source visit alias)
   ;; Bind SYM to VAR, with value SOURCE.  Unassigned bound operands are
@@ -780,16 +780,16 @@ top-level bindings from ENV and return the resulting 
expression."
          (else exp)))
       (($ <lexical-ref> _ _ gensym)
        (log 'begin-copy gensym)
-       (let ((op (lookup gensym)))
+       (let lp ((op (lookup gensym)))
          (cond
           ((eq? ctx 'effect)
            (log 'lexical-for-effect gensym)
            (make-void #f))
-          ((operand-alias-value op)
+          ((operand-alias op)
            ;; This is an unassigned operand that simply aliases some
            ;; other operand.  Recurse to avoid residualizing the leaf
            ;; binding.
-           => for-tail)
+           => lp)
           ((eq? ctx 'call)
            ;; Don't propagate copies if we are residualizing a call.
            (log 'residualize-lexical-call gensym op)
@@ -907,7 +907,7 @@ top-level bindings from ENV and return the resulting 
expression."
                              (map (cut make-lexical-ref #f <> <>)
                                   tmps tmp-syms)))))))
       (($ <let> src names gensyms vals body)
-       (define (compute-alias exp)
+       (define (lookup-alias exp)
          ;; It's very common for macros to introduce something like:
          ;;
          ;;   ((lambda (x y) ...) x-exp y-exp)
@@ -927,9 +927,7 @@ top-level bindings from ENV and return the resulting 
expression."
          (match exp
            (($ <lexical-ref> _ _ sym)
             (let ((op (lookup sym)))
-              (and (not (var-set? (operand-var op)))
-                   (or (operand-alias-value op)
-                       exp))))
+              (and (not (var-set? (operand-var op))) op)))
            (_ #f)))
 
        (let* ((vars (map lookup-var gensyms))
@@ -937,7 +935,7 @@ top-level bindings from ENV and return the resulting 
expression."
               (ops (make-bound-operands vars new vals
                                         (lambda (exp counter ctx)
                                           (loop exp env counter ctx))
-                                        (map compute-alias vals)))
+                                        (map lookup-alias vals)))
               (env (fold extend-env env gensyms ops))
               (body (loop body env counter ctx)))
          (cond
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 7421323..c4e4a71 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1329,4 +1329,26 @@
 
   (pass-if-peval
       (eqv? '(a b) '(a b))
-    (const #t)))
+    (const #t))
+
+  (pass-if-peval
+      (lambda (f x)
+        (let lp ((x x))
+          (let ((x* (f x)))
+            (if (eq? x x*) x* (lp x*)))))
+    (lambda ()
+      (lambda-case
+       (((f x) #f #f #f () (_ _))
+        (letrec (lp)
+          (_)
+          ((lambda ((name . lp))
+             (lambda-case
+              (((x) #f #f #f () (_))
+               (let (x*)
+                 (_)
+                 ((apply (lexical f _) (lexical x _)))
+                 (if (apply (primitive eq?) (lexical x _) (lexical x* _))
+                     (lexical x* _)
+                     (apply (lexical lp _) (lexical x* _))))))))
+          (apply (lexical lp _)
+                 (lexical x _))))))))