[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix bug compiling fixpoint combinator
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/01: Fix bug compiling fixpoint combinator |
Date: |
Sat, 16 Jul 2016 10:06:51 +0000 (UTC) |
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 _))))))))