summaryrefslogtreecommitdiff
path: root/module/language/cps/dce.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/dce.scm')
-rw-r--r--module/language/cps/dce.scm408
1 files changed, 408 insertions, 0 deletions
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
new file mode 100644
index 000000000..6fc885e7f
--- /dev/null
+++ b/module/language/cps/dce.scm
@@ -0,0 +1,408 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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)))))
+ (($ $kargs _ _ (or ($ $branch) ($ $prompt) ($ $throw)))
+ ;; Branches and prompts pass no values to
+ ;; their continuations, and throw terms don't
+ ;; continue at all.
+ (values known unknown))
+ (($ $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))
+ (($ $const-fun body)
+ (values (intset-add live-labels body) live-vars))
+ (($ $code 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)))))
+ (($ $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 param args)
+ (values live-labels (adjoin-vars args 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)
+ ;; 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 'scm-set! 'scm-set!/tag 'scm-set!/immediate
+ 'word-set! 'word-set!/immediate) _
+ (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-branch label kf kt args live-labels live-vars)
+ (define (next-live-term k)
+ ;; FIXME: For a chain of dead branches, this is quadratic.
+ (let lp ((seen empty-intset) (k k))
+ (cond
+ ((intset-ref live-labels k) k)
+ ((intset-ref seen k) k)
+ (else
+ (match (intmap-ref conts k)
+ (($ $kargs _ _ ($ $continue k*))
+ (lp (intset-add seen k) k*))
+ (_ k))))))
+ (cond
+ ((intset-ref live-labels label)
+ ;; Branch live already.
+ (values live-labels (adjoin-vars args live-vars)))
+ ((or (causes-effect? (intmap-ref effects label) &type-check)
+ (not (eqv? (next-live-term kf) (next-live-term kt))))
+ ;; The branch is live if its continuations are not the same, or
+ ;; if the branch itself causes type checks.
+ (values (intset-add live-labels label)
+ (adjoin-vars args 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))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (visit-branch label kf kt args live-labels live-vars))
+ (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+ ;; Prompts need special elision passes that would contify
+ ;; aborts and remove corresponding "unwind" primcalls.
+ (values (intset-add live-labels label)
+ (adjoin-var tag live-vars)))
+ (($ $kargs _ _ ($ $throw src op param args))
+ ;; A reachable "throw" is always live.
+ (values (intset-add live-labels label)
+ (adjoin-vars args 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))
+ (($ $const-fun body)
+ (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 ()))))))
+ (($ $branch kf kt src op param args)
+ (if (label-live? label)
+ (values cps term)
+ ;; Dead branches continue to the same continuation
+ ;; (eventually).
+ (values cps (build-term ($continue kf src ($values ()))))))
+ (($ $prompt)
+ (values cps term))
+ (($ $throw)
+ (values cps term))))
+ (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: