mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

Eta-reduce branches

Browse source 
* module/language/cps/simplify.scm (compute-eta-reductions): Eta-reduce
  branches as well, so that passing a constant to a branch will fold to
  the true or false branch, provided that the test variable was just
  used in the branch.
This commit is contained in:
Andy Wingo 2016-01-03 16:16:54 +01:00
parent 5d171d998c
commit 39002f251e
1 changed files with 39 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

21
module/language/cps/simplify.scm
View file

@ -111,8 +111,7 @@
;;; as candidates. This prevents back-edges and so breaks SCCs, and is ;;; as candidates. This prevents back-edges and so breaks SCCs, and is
;;; optimal if labels are sorted. If the labels aren't sorted it's ;;; optimal if labels are sorted. If the labels aren't sorted it's
;;; suboptimal but cheap. ;;; suboptimal but cheap.
(define (compute-eta-reductions conts kfun) (define (compute-eta-reductions conts kfun singly-used)
(let ((singly-used (compute-singly-referenced-vars conts)))
(define (singly-used? vars) (define (singly-used? vars)
(match vars (match vars
(() #t) (() #t)
@ -135,10 +134,11 @@
(persistent-intset (persistent-intset
(intmap-fold visit-fun (intmap-fold visit-fun
(compute-reachable-functions conts kfun) (compute-reachable-functions conts kfun)
empty-intset)))) empty-intset)))
(define (eta-reduce conts kfun) (define (eta-reduce conts kfun)
(let ((label-set (compute-eta-reductions conts kfun))) (let* ((singly-used (compute-singly-referenced-vars conts))
(label-set (compute-eta-reductions conts kfun singly-used)))
;; Replace any continuation to a label in LABEL-SET with the label's ;; Replace any continuation to a label in LABEL-SET with the label's
;; continuation. The label will denote a $kargs continuation, so ;; continuation. The label will denote a $kargs continuation, so
;; only terms that can continue to $kargs need be taken into ;; only terms that can continue to $kargs need be taken into
@ -155,6 +155,19 @@
(($ $kargs names syms ($ $continue kf src ($ $branch kt exp))) (($ $kargs names syms ($ $continue kf src ($ $branch kt exp)))
($kargs names syms ($kargs names syms
($continue (subst kf) src ($branch (subst kt) ,exp)))) ($continue (subst kf) src ($branch (subst kt) ,exp))))
(($ $kargs names syms ($ $continue k src ($ $const val)))
,(match (intmap-ref conts k)
(($ $kargs (_)
((? (lambda (var) (intset-ref singly-used var))
var))
($ $continue kf _ ($ $branch kt ($ $values (var)))))
(build-cont
($kargs names syms
($continue (subst (if val kt kf)) src ($values ())))))
(_
(build-cont
($kargs names syms
($continue (subst k) src ($const val)))))))
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms ($ $continue k src exp))
($kargs names syms ($kargs names syms
($continue (subst k) src ,exp))) ($continue (subst k) src ,exp)))