[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 11/11: Port dead code elimination (DCE) pass to CPS2
From: |
Andy Wingo |
Subject: |
[Guile-commits] 11/11: Port dead code elimination (DCE) pass to CPS2 |
Date: |
Wed, 20 May 2015 17:33:01 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 48b2f190b2661c329ec95dee83b8eb08f605f25e
Author: Andy Wingo <address@hidden>
Date: Wed May 20 11:36:57 2015 +0200
Port dead code elimination (DCE) pass to CPS2
* module/language/cps2/dce.scm: New file.
* module/language/cps2/optimize.scm: Enable CPS2 DCE pass.
* module/Makefile.am: Add language/cps2/dce.scm.
---
module/Makefile.am | 1 +
module/language/cps2/dce.scm | 403 +++++++++++++++++++++++++++++++++++++
module/language/cps2/optimize.scm | 2 +
3 files changed, 406 insertions(+), 0 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index 6c6830f..fe49d17 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -149,6 +149,7 @@ CPS_LANG_SOURCES =
\
CPS2_LANG_SOURCES = \
language/cps2.scm \
language/cps2/compile-cps.scm \
+ language/cps2/dce.scm \
language/cps2/effects-analysis.scm \
language/cps2/renumber.scm \
language/cps2/optimize.scm \
diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm
new file mode 100644
index 0000000..1f7086a
--- /dev/null
+++ b/module/language/cps2/dce.scm
@@ -0,0 +1,403 @@
+;;; 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 cps2 dce)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps2)
+ #:use-module (language cps2 effects-analysis)
+ #:use-module (language cps2 renumber)
+ ;; #:use-module (language cps2 types)
+ #:use-module (language cps2 utils)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:export (eliminate-dead-code))
+
+(define (elide-type-checks conts effects)
+ "Given CONTS, an intmap of the conts in one local function, remove any
+&type-check effect from EFFECTS where we can prove that no assertion
+will be raised at run-time."
+ #;
+ (let ((types (infer-types conts)))
+ (define (visit-primcall effects fx label name args)
+ (if (primcall-types-check? types label name args)
+ (intmap-add! effects label (logand fx (lognot &type-check))
+ (lambda (old new) new))
+ effects))
+ (persistent-intmap
+ (intmap-fold (lambda (label cont effects)
+ (let ((fx (intmap-ref effects label)))
+ (cond
+ ((causes-all-effects? fx) effects)
+ ((causes-effect? fx &type-check)
+ (match cont
+ (($ $kargs _ _ exp)
+ (match exp
+ (($ $continue k src ($ $primcall name args))
+ (visit-primcall effects fx label name args))
+ (($ $continue k src ($ $branch _ ($primcall name
args)))
+ (visit-primcall effects fx label name args))
+ (_ effects)))
+ (_ effects)))
+ (else effects))))
+ conts
+ effects)))
+ effects)
+
+(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 (fold-nested-functions proc conts seed)
+ "Given the renumbered program CONTS, fold PROC over subsets of
+CONTS that correspond to each function in the program."
+ (define (visit-fun label seed)
+ (call-with-values
+ (lambda ()
+ (postorder-fold-local-conts2
+ (lambda (label cont body nested)
+ (values (intmap-add! body label cont)
+ (match cont
+ (($ $kargs names vars ($ $continue k src exp))
+ (match exp
+ (($ $fun kfun)
+ (intset-add! nested kfun))
+ (($ $rec names vars (($ $fun kfun) ...))
+ (fold1 (lambda (kfun nested)
+ (intset-add! nested kfun))
+ kfun
+ nested))
+ (_ nested)))
+ (_ nested))))
+ conts label empty-intmap empty-intset))
+ (lambda (body nested)
+ (intset-fold visit-fun
+ nested
+ (proc (persistent-intmap body) seed)))))
+ (visit-fun 0 seed))
+
+(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 (fold-nested-functions elide-type-checks
+ conts
+ (compute-effects 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-exps live-vars)
+ (match exp
+ ((or ($ $const) ($ $prim))
+ (values live-exps live-vars))
+ (($ $fun body)
+ (visit-fun body live-exps live-vars))
+ (($ $rec names vars (($ $fun kfuns) ...))
+ (let lp ((vars vars) (kfuns kfuns)
+ (live-exps live-exps) (live-vars live-vars))
+ (match (vector vars kfuns)
+ (#(() ()) (values live-exps live-vars))
+ (#((var . vars) (kfun . kfuns))
+ (if (var-live? var live-vars)
+ (call-with-values (lambda ()
+ (visit-fun kfun live-exps live-vars))
+ (lambda (live-exps live-vars)
+ (lp vars kfuns live-exps live-vars)))
+ (lp vars kfuns live-exps live-vars))))))
+ (($ $prompt escape? tag handler)
+ (values live-exps (adjoin-var tag live-vars)))
+ (($ $call proc args)
+ (values live-exps (adjoin-vars args (adjoin-var proc live-vars))))
+ (($ $callk k proc args)
+ (values live-exps (adjoin-vars args (adjoin-var proc live-vars))))
+ (($ $primcall name args)
+ (values live-exps (adjoin-vars args live-vars)))
+ (($ $branch k ($ $primcall name args))
+ (values live-exps (adjoin-vars args live-vars)))
+ (($ $branch k ($ $values (arg)))
+ (values live-exps (adjoin-var arg live-vars)))
+ (($ $values args)
+ (values live-exps
+ (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-exps live-vars)
+ (cond
+ ((intset-ref live-exps label)
+ ;; Expression live already.
+ (visit-live-exp label k exp live-exps 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-exps label) live-vars))
+ (else
+ ;; Still dead.
+ (values live-exps live-vars))))
+
+ (define (visit-fun label live-exps live-vars)
+ ;; Visit uses before definitions.
+ (postorder-fold-local-conts2
+ (lambda (label cont live-exps live-vars)
+ (match cont
+ (($ $kargs _ _ ($ $continue k src exp))
+ (visit-exp label k exp live-exps live-vars))
+ (($ $kreceive arity kargs)
+ (values live-exps live-vars))
+ (($ $kclause arity kargs kalt)
+ (values live-exps (adjoin-vars (cont-defs kargs) live-vars)))
+ (($ $kfun src meta self)
+ (values live-exps (adjoin-var self live-vars)))
+ (($ $ktail)
+ (values live-exps live-vars))))
+ conts label live-exps live-vars))
+
+ (fixpoint (lambda (live-exps live-vars)
+ (visit-fun 0 live-exps live-vars))
+ empty-intset
+ 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-exps live-vars)
+ (define (exp-live? label)
+ (intset-ref live-exps 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 (exp-live? label)
+ (match exp
+ (($ $fun body)
+ (values (visit-fun body 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 (fold1 (lambda (fun cps)
+ (match fun
+ (($ $fun kfun)
+ (visit-fun kfun cps))))
+ funs 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)))))
+ (define (visit-fun kfun cps)
+ (fold-local-conts visit-cont conts kfun cps))
+ (with-fresh-name-state conts
+ (persistent-intmap (visit-fun 0 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-exps live-vars)
+ (process-eliminations conts live-exps live-vars)))))
+
+;;; Local Variables:
+;;; eval: (put 'adjoin-conts 'scheme-indent-function 1)
+;;; End:
diff --git a/module/language/cps2/optimize.scm
b/module/language/cps2/optimize.scm
index 2ccd3b1..d5fb329 100644
--- a/module/language/cps2/optimize.scm
+++ b/module/language/cps2/optimize.scm
@@ -24,6 +24,7 @@
(define-module (language cps2 optimize)
#:use-module (ice-9 match)
+ #:use-module (language cps2 dce)
#:use-module (language cps2 simplify)
#:export (optimize))
@@ -51,6 +52,7 @@
;; any case, though currently it does not because it doesn't do escape
;; analysis on the box created for the set!.
+ (run-pass! eliminate-dead-code #:dce2? #t)
(run-pass! simplify #:simplify? #t)
program)
- [Guile-commits] 04/11: Add two-argument fixpoint arity, (continued)
- [Guile-commits] 04/11: Add two-argument fixpoint arity, Andy Wingo, 2015/05/20
- [Guile-commits] 02/11: Fix fixpoint, Andy Wingo, 2015/05/20
- [Guile-commits] 01/11: Fix sub/- primcall bug, Andy Wingo, 2015/05/20
- [Guile-commits] 03/11: Fix bug compiling fixpoint combinator, Andy Wingo, 2015/05/20
- [Guile-commits] 07/11: Add arity to worklist-fold, Andy Wingo, 2015/05/20
- [Guile-commits] 06/11: Variadic intset-fold, intmap-fold, Andy Wingo, 2015/05/20
- [Guile-commits] 08/11: intmaps and intsets print with abbreviated key ranges, Andy Wingo, 2015/05/20
- [Guile-commits] 09/11: Fix bug in CPS2 simplify's "transform-conts", Andy Wingo, 2015/05/20
- [Guile-commits] 05/11: Intmaps do not treat #f specially as a value, Andy Wingo, 2015/05/20
- [Guile-commits] 10/11: Port effects analysis to CPS2, Andy Wingo, 2015/05/20
- [Guile-commits] 11/11: Port dead code elimination (DCE) pass to CPS2,
Andy Wingo <=