;; 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 _) #f)))
- (define (visit-term term term-k term-args)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body term-k term-args))
- (($ $letrec names syms funs body)
- (for-each visit-fun funs)
- (visit-term body term-k term-args))
- (($ $continue k src ($ $values 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))
- (($ $continue k src _)
- #f)))
- (define (visit-fun fun)
- (match fun
- (($ $fun src meta free body)
- (visit-cont body))))
- (visit-fun fun)
- table))
-
-(define (locally-prune-continuations fun dfg)
+(define* (prune-continuations fun #:optional (dfg (compute-dfg fun)))
(let ((cfa (analyze-control-flow fun dfg)))
(define (must-visit-cont cont)
(or (visit-cont cont)
(conts (build-cps-term ($letk ,conts ,body))))))
(($ $letrec names syms funs body)
(build-cps-term
- ($letrec names syms funs ,(visit-term body))))
+ ($letrec names syms (map (cut prune-continuations <> dfg) funs)
+ ,(visit-term body))))
+ (($ $continue k src (and fun ($ $fun)))
+ (build-cps-term
+ ($continue k src ,(prune-continuations fun dfg))))
(($ $continue k src exp)
term)))
(rewrite-cps-exp fun
(($ $fun src meta free body)
($fun src meta free ,(must-visit-cont body))))))
+(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 _) #f)))
+ (define (visit-term term term-k term-args)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body term-k term-args))
+ (($ $letrec names syms funs body)
+ (for-each visit-fun funs)
+ (visit-term body term-k term-args))
+ (($ $continue k src ($ $values 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))
+ (($ $continue k src _)
+ #f)))
+ (define (visit-fun fun)
+ (match fun
+ (($ $fun src meta free body)
+ (visit-cont body))))
+ (visit-fun fun)
+ table))
+
(define (eta-reduce fun)
(let ((table (compute-eta-reductions fun))
(dfg (compute-dfg fun)))
(($ $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))
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body #f)))))
(visit-fun fun)))
(define (compute-beta-reductions fun)
(visit-fun fun)))
(define (simplify fun)
- (eta-reduce (beta-reduce fun)))
+ (prune-continuations (eta-reduce (beta-reduce fun))))