[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/10: Fix eta reduction on CPS2
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/10: Fix eta reduction on CPS2 |
Date: |
Thu, 04 Jun 2015 22:57:49 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit b0148e11dbb649454a93dc2e864e2662feed43d1
Author: Andy Wingo <address@hidden>
Date: Thu Jun 4 13:44:57 2015 +0200
Fix eta reduction on CPS2
* module/language/cps2/simplify.scm (compute-singly-referenced-vars):
New helper.
(compute-eta-reductions): Turns out, eta conversion on a graph
doesn't work the same way that it works on nested terms -- since
uses and defs are computed using the flow graph and not nested
terms, we need to check additionally that the vars are singly-used.
---
module/language/cps2/simplify.scm | 92 ++++++++++++++++++++++++++----------
1 files changed, 66 insertions(+), 26 deletions(-)
diff --git a/module/language/cps2/simplify.scm
b/module/language/cps2/simplify.scm
index 5aa1bb1..685327a 100644
--- a/module/language/cps2/simplify.scm
+++ b/module/language/cps2/simplify.scm
@@ -63,8 +63,42 @@
conts
conts)))
-;;; Continuations that simply forward their values to another may be
-;;; elided via eta reduction over labels.
+(define (compute-singly-referenced-vars conts)
+ (define (visit label cont single multiple)
+ (define (add-ref var single multiple)
+ (if (intset-ref single var)
+ (values single (intset-add! multiple var))
+ (values (intset-add! single var) multiple)))
+ (define (ref var) (add-ref var single multiple))
+ (define (ref* vars) (fold2 add-ref vars single multiple))
+ (match cont
+ (($ $kargs _ _ ($ $continue _ _ exp))
+ (match exp
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $rec))
+ (values single multiple))
+ (($ $call proc args)
+ (ref* (cons proc args)))
+ (($ $callk k proc args)
+ (ref* (cons proc args)))
+ (($ $primcall name args)
+ (ref* args))
+ (($ $values args)
+ (ref* args))
+ (($ $branch kt ($ $values (var)))
+ (ref var))
+ (($ $branch kt ($ $primcall name args))
+ (ref* args))
+ (($ $prompt escape? tag handler)
+ (ref tag))))
+ (_
+ (values single multiple))))
+ (let*-values (((single multiple) (values empty-intset empty-intset))
+ ((single multiple) (intmap-fold visit conts single multiple)))
+ (intset-subtract (persistent-intset single)
+ (persistent-intset multiple))))
+
+;;; Continuations whose values are simply forwarded to another and not
+;;; used in any other way may be elided via eta reduction over labels.
;;;
;;; There is an exception however: we must exclude strongly-connected
;;; components (SCCs). The only kind of SCC we can build out of $values
@@ -78,30 +112,36 @@
;;; optimal if labels are sorted. If the labels aren't sorted it's
;;; suboptimal but cheap.
(define (compute-eta-reductions conts kfun)
- (define (visit-fun kfun nested-funs eta)
- (let ((body (compute-function-body conts kfun)))
- (define (visit-cont label nested-funs eta)
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src ($ $values vars)))
- (values nested-funs
- (intset-maybe-add! eta label
- (match (intmap-ref conts k)
- (($ $kargs)
- (and (not (eqv? label k)) ; A
- (not (intset-ref eta label)) ; B
- ))
- (_ #f)))))
- (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
- (values (intset-add! nested-funs kfun) eta))
- (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
- (values (intset-add*! nested-funs kfun) eta))
- (_
- (values nested-funs eta))))
- (intset-fold visit-cont body nested-funs eta)))
- (define (visit-funs worklist eta)
- (intset-fold visit-fun worklist empty-intset eta))
- (persistent-intset
- (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))
+ (let ((singly-used (compute-singly-referenced-vars conts)))
+ (define (singly-used? vars)
+ (match vars
+ (() #t)
+ ((var . vars)
+ (and (intset-ref singly-used var) (singly-used? vars)))))
+ (define (visit-fun kfun nested-funs eta)
+ (let ((body (compute-function-body conts kfun)))
+ (define (visit-cont label nested-funs eta)
+ (match (intmap-ref conts label)
+ (($ $kargs names vars ($ $continue k src ($ $values vars)))
+ (values nested-funs
+ (intset-maybe-add! eta label
+ (match (intmap-ref conts k)
+ (($ $kargs)
+ (and (not (eqv? label k)) ; A
+ (not (intset-ref eta label)) ;
B
+ (singly-used? vars)))
+ (_ #f)))))
+ (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
+ (values (intset-add! nested-funs kfun) eta))
+ (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
+ (values (intset-add*! nested-funs kfun) eta))
+ (_
+ (values nested-funs eta))))
+ (intset-fold visit-cont body nested-funs eta)))
+ (define (visit-funs worklist eta)
+ (intset-fold visit-fun worklist empty-intset eta))
+ (persistent-intset
+ (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))))
(define (eta-reduce conts kfun)
(let ((label-set (compute-eta-reductions conts kfun)))
- [Guile-commits] branch master updated (f541ee1 -> 6f4487f), Andy Wingo, 2015/06/04
- [Guile-commits] 01/10: Fix write beyond stack boundary in vm-engine.c, Andy Wingo, 2015/06/04
- [Guile-commits] 02/10: Fix slot allocation hinting for intervening terms that define dead values, Andy Wingo, 2015/06/04
- [Guile-commits] 03/10: Fix intmap-ref bug, Andy Wingo, 2015/06/04
- [Guile-commits] 04/10: Fix eta reduction on CPS2,
Andy Wingo <=
- [Guile-commits] 05/10: Port self-references pass to CPS2, Andy Wingo, 2015/06/04
- [Guile-commits] 09/10: Enable all CPS2 optimization passes, Andy Wingo, 2015/06/04
- [Guile-commits] 06/10: Refactor renumber.scm, Andy Wingo, 2015/06/04
- [Guile-commits] 08/10: Tweaks to bootstrap build order, Andy Wingo, 2015/06/04
- [Guile-commits] 10/10: Disable CPS optimization passes, Andy Wingo, 2015/06/04
- [Guile-commits] 07/10: Add CPS2 verification pass, Andy Wingo, 2015/06/04