mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 07:30:32 +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

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

@ -111,34 +111,34 @@
;;; 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) ((var . vars)
((var . vars) (and (intset-ref singly-used var) (singly-used? vars)))))
(and (intset-ref singly-used var) (singly-used? vars))))) (define (visit-fun kfun body eta)
(define (visit-fun kfun body eta) (define (visit-cont label eta)
(define (visit-cont label eta) (match (intmap-ref conts label)
(match (intmap-ref conts label) (($ $kargs names vars ($ $continue k src ($ $values vars)))
(($ $kargs names vars ($ $continue k src ($ $values vars))) (intset-maybe-add! eta label
(intset-maybe-add! eta label (match (intmap-ref conts k)
(match (intmap-ref conts k) (($ $kargs)
(($ $kargs) (and (not (eqv? label k)) ; A
(and (not (eqv? label k)) ; A (not (intset-ref eta label)) ; B
(not (intset-ref eta label)) ; B (singly-used? vars)))
(singly-used? vars))) (_ #f))))
(_ #f)))) (_
(_ eta)))
eta))) (intset-fold visit-cont body eta))
(intset-fold visit-cont body eta)) (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)))