;;; Continuation-passing style (CPS) intermediate language (IL)
;; 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; This pass kills dead expressions: code that has no side effects, and
;;; whose value is unused. It does so by marking all live values, and
;;; then discarding other values as dead. This happens recursively
;;; through procedures, so it should be possible to elide dead
;;; procedures as well.
;;;
;;; Code:
(define-module (language cps dce)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps)
#:use-module (language cps effects-analysis)
#:use-module (language cps renumber)
#:use-module (language cps type-checks)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (eliminate-dead-code))
(define (fold-local-conts proc conts label seed)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let lp ((label label) (seed seed))
(if (<= label tail)
(lp (1+ label) (proc label (intmap-ref conts label) seed))
seed)))))
(define (postorder-fold-local-conts2 proc conts label seed0 seed1)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let ((start label))
(let lp ((label tail) (seed0 seed0) (seed1 seed1))
(if (<= start label)
(let ((cont (intmap-ref conts label)))
(call-with-values (lambda () (proc label cont seed0 seed1))
(lambda (seed0 seed1)
(lp (1- label) seed0 seed1))))
(values seed0 seed1)))))))
(define (compute-known-allocations conts effects)
"Compute the variables bound in CONTS that have known allocation
sites."
;; Compute the set of conts that are called with freshly allocated
;; values, and subtract from that set the conts that might be called
;; with values with unknown allocation sites. Then convert that set
;; of conts into a set of bound variables.
(call-with-values
(lambda ()
(intmap-fold (lambda (label cont known unknown)
;; Note that we only need to add labels to the
;; known/unknown sets if the labels can bind
;; values. So there's no need to add tail,
;; clause, branch alternate, or prompt handler
;; labels, as they bind no values.
(match cont
(($ $kargs _ _ ($ $continue k))
(let ((fx (intmap-ref effects label)))
(if (and (not (causes-all-effects? fx))
(causes-effect? fx &allocation))
(values (intset-add! known k) unknown)
(values known (intset-add! unknown k)))))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause)
(values known unknown))
(($ $kclause arity body alt)
(values known (intset-add! unknown body)))
(($ $ktail)
(values known unknown))))
conts
empty-intset
empty-intset))
(lambda (known unknown)
(persistent-intset
(intset-fold (lambda (label vars)
(match (intmap-ref conts label)
(($ $kargs (_) (var)) (intset-add! vars var))
(_ vars)))
(intset-subtract (persistent-intset known)
(persistent-intset unknown))
empty-intset)))))
(define (compute-live-code conts)
(let* ((effects (compute-effects/elide-type-checks conts))
(known-allocations (compute-known-allocations conts effects)))
(define (adjoin-var var set)
(intset-add set var))
(define (adjoin-vars vars set)
(match vars
(() set)
((var . vars) (adjoin-vars vars (adjoin-var var set)))))
(define (var-live? var live-vars)
(intset-ref live-vars var))
(define (any-var-live? vars live-vars)
(match vars
(() #f)
((var . vars)
(or (var-live? var live-vars)
(any-var-live? vars live-vars)))))
(define (cont-defs k)
(match (intmap-ref conts k)
(($ $kargs _ vars) vars)
(_ #f)))
(define (visit-live-exp label k exp live-labels live-vars)
(match exp
((or ($ $const) ($ $prim))
(values live-labels live-vars))
(($ $fun body)
(values (intset-add live-labels body) live-vars))
(($ $closure body)
(values (intset-add live-labels body) live-vars))
(($ $rec names vars (($ $fun kfuns) ...))
(let lp ((vars vars) (kfuns kfuns)
(live-labels live-labels) (live-vars live-vars))
(match (vector vars kfuns)
(#(() ()) (values live-labels live-vars))
(#((var . vars) (kfun . kfuns))
(lp vars kfuns
(if (var-live? var live-vars)
(intset-add live-labels kfun)
live-labels)
live-vars)))))
(($ $prompt escape? tag handler)
(values live-labels (adjoin-var tag live-vars)))
(($ $call proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk kfun proc args)
(values (intset-add live-labels kfun)
(adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args)
(values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args))
(values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $values (arg)))
(values live-labels (adjoin-var arg live-vars)))
(($ $values args)
(values live-labels
(match (cont-defs k)
(#f (adjoin-vars args live-vars))
(defs (fold (lambda (use def live-vars)
(if (var-live? def live-vars)
(adjoin-var use live-vars)
live-vars))
live-vars args defs)))))))
(define (visit-exp label k exp live-labels live-vars)
(cond
((intset-ref live-labels label)
;; Expression live already.
(visit-live-exp label k exp live-labels live-vars))
((let ((defs (cont-defs k))
(fx (intmap-ref effects label)))
(or
;; No defs; perhaps continuation is $ktail.
(not defs)
;; We don't remove branches.
(match exp (($ $branch) #t) (_ #f))
;; Do we have a live def?
(any-var-live? defs live-vars)
;; Does this expression cause all effects? If so, it's
;; definitely live.
(causes-all-effects? fx)
;; Does it cause a type check, but we weren't able to prove
;; that the types check?
(causes-effect? fx &type-check)
;; We might have a setter. If the object being assigned to
;; is live or was not created by us, then this expression is
;; live. Otherwise the value is still dead.
(and (causes-effect? fx &write)
(match exp
(($ $primcall
(or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr!
'box-set!)
(obj . _))
(or (var-live? obj live-vars)
(not (intset-ref known-allocations obj))))
(_ #t)))))
;; Mark expression as live and visit.
(visit-live-exp label k exp (intset-add live-labels label) live-vars))
(else
;; Still dead.
(values live-labels live-vars))))
(define (visit-fun label live-labels live-vars)
;; Visit uses before definitions.
(postorder-fold-local-conts2
(lambda (label cont live-labels live-vars)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(visit-exp label k exp live-labels live-vars))
(($ $kreceive arity kargs)
(values live-labels live-vars))
(($ $kclause arity kargs kalt)
(values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
(($ $kfun src meta self)
(values live-labels (adjoin-var self live-vars)))
(($ $ktail)
(values live-labels live-vars))))
conts label live-labels live-vars))
(fixpoint (lambda (live-labels live-vars)
(let lp ((label 0)
(live-labels live-labels)
(live-vars live-vars))
(match (intset-next live-labels label)
(#f (values live-labels live-vars))
(label
(call-with-values
(lambda ()
(match (intmap-ref conts label)
(($ $kfun)
(visit-fun label live-labels live-vars))
(_ (values live-labels live-vars))))
(lambda (live-labels live-vars)
(lp (1+ label) live-labels live-vars)))))))
(intset 0)
empty-intset)))
(define-syntax adjoin-conts
(syntax-rules ()
((_ (exp ...) clause ...)
(let ((cps (exp ...)))
(adjoin-conts cps clause ...)))
((_ cps (label cont) clause ...)
(adjoin-conts (intmap-add! cps label (build-cont cont))
clause ...))
((_ cps)
cps)))
(define (process-eliminations conts live-labels live-vars)
(define (label-live? label)
(intset-ref live-labels label))
(define (value-live? var)
(intset-ref live-vars var))
(define (make-adaptor k src defs)
(let* ((names (map (lambda (_) 'tmp) defs))
(vars (map (lambda (_) (fresh-var)) defs))
(live (filter-map (lambda (def var)
(and (value-live? def) var))
defs vars)))
(build-cont
($kargs names vars
($continue k src ($values live))))))
(define (visit-term label term cps)
(match term
(($ $continue k src exp)
(if (label-live? label)
(match exp
(($ $fun body)
(values cps
term))
(($ $closure body nfree)
(values cps
term))
(($ $rec names vars funs)
(match (filter-map (lambda (name var fun)
(and (value-live? var)
(list name var fun)))
names vars funs)
(()
(values cps
(build-term ($continue k src ($values ())))))
(((names vars funs) ...)
(values cps
(build-term ($continue k src
($rec names vars funs)))))))
(_
(match (intmap-ref conts k)
(($ $kargs ())
(values cps term))
(($ $kargs names ((? value-live?) ...))
(values cps term))
(($ $kargs names vars)
(match exp
(($ $values args)
(let ((args (filter-map (lambda (use def)
(and (value-live? def) use))
args vars)))
(values cps
(build-term
($continue k src ($values args))))))
(_
(let-fresh (adapt) ()
(values (adjoin-conts cps
(adapt ,(make-adaptor k src vars)))
(build-term
($continue adapt src ,exp)))))))
(_
(values cps term)))))
(values cps
(build-term
($continue k src ($values ()))))))))
(define (visit-cont label cont cps)
(match cont
(($ $kargs names vars term)
(match (filter-map (lambda (name var)
(and (value-live? var)
(cons name var)))
names vars)
(((names . vars) ...)
(call-with-values (lambda () (visit-term label term cps))
(lambda (cps term)
(adjoin-conts cps
(label ($kargs names vars ,term))))))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(let ((defs (match (intmap-ref conts kargs)
(($ $kargs names vars) vars))))
(if (and-map value-live? defs)
(adjoin-conts cps (label ,cont))
(let-fresh (adapt) ()
(adjoin-conts cps
(adapt ,(make-adaptor kargs #f defs))
(label ($kreceive req rest adapt)))))))
(_
(adjoin-conts cps (label ,cont)))))
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold (lambda (label cont cps)
(match cont
(($ $kfun)
(if (label-live? label)
(fold-local-conts visit-cont conts label cps)
cps))
(_ cps)))
conts
empty-intmap))))
(define (eliminate-dead-code conts)
;; We work on a renumbered program so that we can easily visit uses
;; before definitions just by visiting higher-numbered labels before
;; lower-numbered labels. Renumbering is also a precondition for type
;; inference.
(let ((conts (renumber conts)))
(call-with-values (lambda () (compute-live-code conts))
(lambda (live-labels live-vars)
(process-eliminations conts live-labels live-vars)))))
;;; Local Variables:
;;; eval: (put 'adjoin-conts 'scheme-indent-function 1)
;;; End: