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

Fix eta reduction on CPS2

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-06-04 13:44:57 +02:00
parent 1850497a5c
commit b0148e11db
1 changed files with 66 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

92
module/language/cps2/simplify.scm
View file

@ -63,8 +63,42 @@
conts conts
conts))) conts)))
;;; Continuations that simply forward their values to another may be (define (compute-singly-referenced-vars conts)
;;; elided via eta reduction over labels. (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 ;;; There is an exception however: we must exclude strongly-connected
;;; components (SCCs). The only kind of SCC we can build out of $values ;;; 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 ;;; 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)
(define (visit-fun kfun nested-funs eta) (let ((singly-used (compute-singly-referenced-vars conts)))
(let ((body (compute-function-body conts kfun))) (define (singly-used? vars)
(define (visit-cont label nested-funs eta) (match vars
(match (intmap-ref conts label) (() #t)
(($ $kargs names vars ($ $continue k src ($ $values vars))) ((var . vars)
(values nested-funs (and (intset-ref singly-used var) (singly-used? vars)))))
(intset-maybe-add! eta label (define (visit-fun kfun nested-funs eta)
(match (intmap-ref conts k) (let ((body (compute-function-body conts kfun)))
(($ $kargs) (define (visit-cont label nested-funs eta)
(and (not (eqv? label k)) ; A (match (intmap-ref conts label)
(not (intset-ref eta label)) ; B (($ $kargs names vars ($ $continue k src ($ $values vars)))
)) (values nested-funs
(_ #f))))) (intset-maybe-add! eta label
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) (match (intmap-ref conts k)
(values (intset-add! nested-funs kfun) eta)) (($ $kargs)
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...)))) (and (not (eqv? label k)) ; A
(values (intset-add*! nested-funs kfun) eta)) (not (intset-ref eta label)) ; B
(_ (singly-used? vars)))
(values nested-funs eta)))) (_ #f)))))
(intset-fold visit-cont body nested-funs eta))) (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
(define (visit-funs worklist eta) (values (intset-add! nested-funs kfun) eta))
(intset-fold visit-fun worklist empty-intset eta)) (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
(persistent-intset (values (intset-add*! nested-funs kfun) eta))
(worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))) (_
(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) (define (eta-reduce conts kfun)
(let ((label-set (compute-eta-reductions conts kfun))) (let ((label-set (compute-eta-reductions conts kfun)))