[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/11: Fix bug compiling fixpoint combinator
From: |
Andy Wingo |
Subject: |
[Guile-commits] 03/11: Fix bug compiling fixpoint combinator |
Date: |
Wed, 20 May 2015 17:32:55 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 4632f3d9988f9a234298b7cc860b2374e2bcc712
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. Fix construction of rest bindings
as well.
* test-suite/tests/peval.test ("partial evaluation"): New test.
---
module/language/tree-il/peval.scm | 22 ++++++++++------------
test-suite/tests/peval.test | 30 ++++++++++++++++++++++++++++--
2 files changed, 38 insertions(+), 14 deletions(-)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 3daa2ec..fca849e 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -275,7 +275,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)
@@ -286,7 +286,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
@@ -787,16 +787,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)
@@ -913,7 +913,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)
@@ -933,9 +933,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))
@@ -943,7 +941,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
@@ -1397,8 +1395,8 @@ top-level bindings from ENV and return the resulting
expression."
(list (make-primcall
#f 'list
(drop orig-args (+ nreq nopt)))))
- (rest (list (make-const #f '())))
- (else '()))))
+ ((null? rest) '())
+ (else (list (make-const #f '()))))))
(if (>= nargs (+ nreq nopt))
(make-let src
(append req opt rest)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 7cc5a31..93988af 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1372,9 +1372,35 @@
(if (pair? arg)
(set! l arg))
(apply f l))
- (let (l) (_) ((const ()))
+ (let (l) (_) ((const ()))
(seq
(if (primcall pair? (toplevel arg))
(set! (lexical l _) (toplevel arg))
(void))
- (primcall apply (toplevel f) (lexical l _))))))
+ (primcall apply (toplevel f) (lexical l _)))))
+
+ (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*)
+ (_)
+ ((call (lexical f _) (lexical x _)))
+ (if (primcall
+ eq?
+ (lexical x _)
+ (lexical x* _))
+ (lexical x* _)
+ (call (lexical lp _)
+ (lexical x* _))))))))
+ (call (lexical lp _)
+ (lexical x _))))))))
- [Guile-commits] branch master updated (ef5f2fc -> 48b2f19), Andy Wingo, 2015/05/20
- [Guile-commits] 04/11: Add two-argument fixpoint arity, Andy Wingo, 2015/05/20
- [Guile-commits] 02/11: Fix fixpoint, Andy Wingo, 2015/05/20
- [Guile-commits] 01/11: Fix sub/- primcall bug, Andy Wingo, 2015/05/20
- [Guile-commits] 03/11: Fix bug compiling fixpoint combinator,
Andy Wingo <=
- [Guile-commits] 07/11: Add arity to worklist-fold, Andy Wingo, 2015/05/20
- [Guile-commits] 06/11: Variadic intset-fold, intmap-fold, Andy Wingo, 2015/05/20
- [Guile-commits] 08/11: intmaps and intsets print with abbreviated key ranges, Andy Wingo, 2015/05/20
- [Guile-commits] 09/11: Fix bug in CPS2 simplify's "transform-conts", Andy Wingo, 2015/05/20
- [Guile-commits] 05/11: Intmaps do not treat #f specially as a value, Andy Wingo, 2015/05/20
- [Guile-commits] 10/11: Port effects analysis to CPS2, Andy Wingo, 2015/05/20
- [Guile-commits] 11/11: Port dead code elimination (DCE) pass to CPS2, Andy Wingo, 2015/05/20