;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define-module (language cps simplify)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
+ #:use-module (language cps renumber)
#:export (simplify))
-;; Currently we just try to bypass all $values nodes that we can. This
-;; is eta-reduction on continuations. Then we prune unused
-;; continuations. Note that this pruning is just a quick clean-up; for
-;; a real fixed-point pass that can eliminate unused loops, the
-;; dead-code elimination pass is there for you. But DCE introduces new
-;; nullary $values nodes (as replacements for expressions whose values
-;; aren't used), making it useful for this pass to include its own
-;; little pruner.
-
(define (compute-eta-reductions fun)
(let ((table (make-hash-table)))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body sym syms))
- (($ $cont sym ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont sym ($ $kclause arity body))
- (visit-cont body))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
(($ $cont sym _) #f)))
(define (visit-term term term-k term-args)
(match term
(for-each visit-fun funs)
(visit-term body term-k term-args))
(($ $continue k src ($ $values args))
- (when (equal? term-args args)
+ (when (and (equal? term-args args) (not (eq? k term-k)))
(hashq-set! table term-k k)))
(($ $continue k src (and fun ($ $fun)))
(visit-fun fun))
#f)))
(define (visit-fun fun)
(match fun
- (($ $fun src meta free body)
+ (($ $fun free body)
(visit-cont body))))
- (visit-fun fun)
+ (visit-cont fun)
table))
-(define (locally-prune-continuations fun dfg)
- (let ((cfa (analyze-control-flow fun dfg)))
- (define (must-visit-cont cont)
- (or (visit-cont cont)
- (error "cont must be reachable" cont)))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym cont)
- (and (cfa-k-idx cfa sym #:default (lambda (k) #f))
- (rewrite-cps-cont cont
- (($ $kargs names syms body)
- (sym ($kargs names syms ,(visit-term body))))
- (($ $kentry self tail clauses)
- (sym ($kentry self ,tail ,(visit-conts clauses))))
- (($ $kclause arity body)
- (sym ($kclause ,arity ,(must-visit-cont body))))
- ((or ($ $kreceive) ($ $kif))
- (sym ,cont)))))))
- (define (visit-conts conts)
- (filter-map visit-cont conts))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (let ((body (visit-term body)))
- (match (visit-conts conts)
- (() body)
- (conts (build-cps-term ($letk ,conts ,body))))))
- (($ $letrec names syms funs body)
- (build-cps-term
- ($letrec names syms funs ,(visit-term body))))
- (($ $continue k src exp)
- term)))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(must-visit-cont body))))))
-
(define (eta-reduce fun)
(let ((table (compute-eta-reductions fun))
(dfg (compute-dfg fun)))
(k*
(if (and (continuation-bound-in? k* scope dfg)
(or values?
- (match (lookup-cont k* (dfg-cont-table dfg))
+ (match (lookup-cont k* dfg)
(($ $kargs) #t)
(_ #f))))
(reduce* k* scope values?)
(reduce* k scope #f))
(define (reduce-values k scope)
(reduce* k scope #t))
+ (define (reduce-const k src scope const)
+ (let lp ((k k) (seen '()) (const const))
+ (match (lookup-cont k dfg)
+ (($ $kargs (_) (arg) term)
+ (match (find-call term)
+ (($ $continue k* src* ($ $values (arg*)))
+ (and (eqv? arg arg*)
+ (not (memq k* seen))
+ (lp k* (cons k seen) const)))
+ (($ $continue k* src* ($ $primcall 'not (arg*)))
+ (and (eqv? arg arg*)
+ (not (memq k* seen))
+ (lp k* (cons k seen) (not const))))
+ (($ $continue k* src* ($ $branch kt ($ $values (arg*))))
+ (and (eqv? arg arg*)
+ (let ((k* (if const kt k*)))
+ (and (continuation-bound-in? k* scope dfg)
+ (build-cps-term
+ ($continue k* src ($values ())))))))
+ (_
+ (and (continuation-bound-in? k scope dfg)
+ (build-cps-term
+ ($continue k src ($const const)))))))
+ (_ #f))))
(define (visit-cont cont scope)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map (cut visit-cont <> sym) clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body sym))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause sym)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body sym)
+ ,(and alternate (visit-cont alternate sym)))))
(($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
- (sym ($kreceive req rest (reduce kargs scope))))
- (($ $cont sym ($ $kif kt kf))
- (sym ($kif (reduce kt scope) (reduce kf scope))))))
+ (sym ($kreceive req rest (reduce kargs scope))))))
(define (visit-term term scope)
(rewrite-cps-term term
(($ $letk conts body)
,(visit-term body scope)))
(($ $letrec names syms funs body)
($letrec names syms (map visit-fun funs)
- ,(visit-term body scope)))
+ ,(visit-term body scope)))
(($ $continue k src ($ $values args))
($continue (reduce-values k scope) src ($values args)))
(($ $continue k src (and fun ($ $fun)))
($continue (reduce k scope) src ,(visit-fun fun)))
+ (($ $continue k src ($ $const const))
+ ,(let ((k (reduce k scope)))
+ (or (reduce-const k src scope const)
+ (build-cps-term ($continue k src ($const const))))))
(($ $continue k src exp)
($continue (reduce k scope) src ,exp))))
(define (visit-fun fun)
- (locally-prune-continuations
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body #f))))
- dfg))
- (visit-fun fun)))
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(visit-cont body #f)))))
+ (visit-cont fun #f)))
(define (compute-beta-reductions fun)
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only be
;; inlined if it is used only once, and not recursively.
- (let ((table (make-hash-table))
+ (let ((var-table (make-hash-table))
+ (k-table (make-hash-table))
(dfg (compute-dfg fun)))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body))
- (($ $cont sym ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont sym ($ $kclause arity body))
- (visit-cont body))
- (($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif)))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
+ (($ $cont sym (or ($ $ktail) ($ $kreceive)))
#f)))
(define (visit-term term)
(match term
(for-each visit-fun funs)
(visit-term body))
(($ $continue k src ($ $values args))
- (match (lookup-cont k (dfg-cont-table dfg))
+ (match (lookup-cont k dfg)
(($ $kargs names syms body)
(match (lookup-predecessors k dfg)
((_)
;; -> body mapping in the table. Also store the
;; substitutions for the variables bound by the inlined
;; continuation.
- (for-each (cut hashq-set! table <> <>) syms args)
- (hashq-set! table k body))
+ (for-each (cut hashq-set! var-table <> <>) syms args)
+ (hashq-set! k-table k body))
(_ #f)))
(_ #f)))
(($ $continue k src (and fun ($ $fun)))
#f)))
(define (visit-fun fun)
(match fun
- (($ $fun src meta free body)
+ (($ $fun free body)
(visit-cont body))))
- (visit-fun fun)
- table))
+ (visit-cont fun)
+ (values var-table k-table)))
(define (beta-reduce fun)
- (let ((table (compute-beta-reductions fun)))
+ (let-values (((var-table k-table) (compute-beta-reductions fun)))
(define (subst var)
- (cond ((hashq-ref table var) => subst)
+ (cond ((hashq-ref var-table var) => subst)
(else var)))
(define (must-visit-cont cont)
(or (visit-cont cont)
(define (visit-cont cont)
(match cont
(($ $cont sym cont)
- (and (not (hashq-ref table sym))
+ (and (not (hashq-ref k-table sym))
(rewrite-cps-cont cont
(($ $kargs names syms body)
(sym ($kargs names syms ,(visit-term body))))
- (($ $kentry self tail clauses)
- (sym ($kentry self ,tail ,(map must-visit-cont clauses))))
- (($ $kclause arity body)
- (sym ($kclause ,arity ,(must-visit-cont body))))
- ((or ($ $kreceive) ($ $kif))
+ (($ $kfun src meta self tail clause)
+ (sym ($kfun src meta self ,tail
+ ,(and clause (must-visit-cont clause)))))
+ (($ $kclause arity body alternate)
+ (sym ($kclause ,arity ,(must-visit-cont body)
+ ,(and alternate (must-visit-cont alternate)))))
+ (($ $kreceive)
(sym ,cont)))))))
(define (visit-term term)
(match term
,(visit-term body))))
(($ $continue k src exp)
(cond
- ((hashq-ref table k) => visit-term)
+ ((hashq-ref k-table k) => visit-term)
(else
- (build-cps-term
- ($continue k src
- ,(match exp
- ((or ($ $void) ($ $const) ($ $prim)) exp)
- (($ $fun) (visit-fun exp))
- (($ $call proc args)
- (let ((args (map subst args)))
- (build-cps-exp ($call (subst proc) args))))
- (($ $callk k proc args)
- (let ((args (map subst args)))
- (build-cps-exp ($callk k (subst proc) args))))
- (($ $primcall name args)
- (let ((args (map subst args)))
- (build-cps-exp ($primcall name args))))
- (($ $values args)
- (let ((args (map subst args)))
- (build-cps-exp ($values args))))
- (($ $prompt escape? tag handler)
- (build-cps-exp ($prompt escape? (subst tag) handler)))))))))))
+ (build-cps-term ($continue k src ,(visit-exp exp))))))))
+ (define (visit-exp exp)
+ (match exp
+ ((or ($ $const) ($ $prim)) exp)
+ (($ $fun) (visit-fun exp))
+ (($ $call proc args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($call (subst proc) args))))
+ (($ $callk k proc args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($callk k (subst proc) args))))
+ (($ $primcall name args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($primcall name args))))
+ (($ $values args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($values args))))
+ (($ $branch kt exp)
+ (build-cps-exp ($branch kt ,(visit-exp exp))))
+ (($ $prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? (subst tag) handler)))))
(define (visit-fun fun)
(rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta (map subst free) ,(must-visit-cont body)))))
- (visit-fun fun)))
+ (($ $fun free body)
+ ($fun (map subst free) ,(must-visit-cont body)))))
+ (must-visit-cont fun)))
+
+;; Rewrite the scope tree to reflect the dominator tree. Precondition:
+;; the fun has been renumbered, its min-label is 0, and its labels are
+;; packed.
+(define (redominate fun)
+ (let* ((dfg (compute-dfg fun))
+ (idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
+ (doms (compute-dom-edges idoms 0)))
+ (define (visit-fun-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-fun-cont clause)))))
+ (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
+ (label ($kclause ,arity ,(visit-cont kbody body)
+ ,(and alternate (visit-fun-cont alternate)))))))
+
+ (define (visit-cont label cont)
+ (rewrite-cps-cont cont
+ (($ $kargs names vars body)
+ (label ($kargs names vars ,(visit-term body label))))
+ (_ (label ,cont))))
+
+ (define (visit-exp k src exp)
+ (rewrite-cps-term exp
+ (($ $fun free body)
+ ($continue k src ($fun free ,(visit-fun-cont body))))
+ (_
+ ($continue k src ,exp))))
+
+ (define (visit-term term label)
+ (define (visit-dom-conts label)
+ (let ((cont (lookup-cont label dfg)))
+ (match cont
+ (($ $ktail) '())
+ (($ $kargs) (list (visit-cont label cont)))
+ (else
+ (cons (visit-cont label cont)
+ (visit-dom-conts* (vector-ref doms label)))))))
+
+ (define (visit-dom-conts* labels)
+ (match labels
+ (() '())
+ ((label . labels)
+ (append (visit-dom-conts label)
+ (visit-dom-conts* labels)))))
+
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ,(visit-term body label))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (let lp ((funs funs))
+ (match funs
+ (() '())
+ ((($ $fun free body) . funs)
+ (cons (build-cps-exp
+ ($fun free ,(visit-fun-cont body)))
+ (lp funs)))))
+ ,(visit-term body label)))
+ (($ $continue k src exp)
+ ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
+ (if (null? conts)
+ (visit-exp k src exp)
+ (build-cps-term
+ ($letk ,conts ,(visit-exp k src exp))))))))
+
+ (visit-fun-cont fun)))
(define (simplify fun)
- (eta-reduce (beta-reduce fun)))
+ ;; Renumbering prunes continuations that are made unreachable by
+ ;; eta/beta reductions.
+ (redominate (renumber (eta-reduce (beta-reduce fun)))))
HCoop / bpt / guile.git / blobdiff