[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/06: Port CSE to CPS2
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/06: Port CSE to CPS2 |
Date: |
Wed, 03 Jun 2015 14:49:55 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit c3bc1f8e93a20158f24cfaf895ee34e68a6395dd
Author: Andy Wingo <address@hidden>
Date: Wed Jun 3 12:59:51 2015 +0200
Port CSE to CPS2
* module/language/cps2/cse.scm: New file, ported from CPS.
* module/language/cps2/optimize.scm: Wire up CSE.
* module/Makefile.am: Add language/cps2/cse.scm.
* module/language/cps/compile-bytecode.scm (optimize): Disable
prune-top-level-scopes on old CPS. It seems to not work if CSE has
run beforehand.
---
module/Makefile.am | 1 +
module/language/cps/compile-bytecode.scm | 5 +-
module/language/cps2/cse.scm | 449 ++++++++++++++++++++++++++++++
module/language/cps2/optimize.scm | 3 +-
4 files changed, 456 insertions(+), 2 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index d144b79..e6e3046 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -148,6 +148,7 @@ CPS_LANG_SOURCES =
\
CPS2_LANG_SOURCES = \
language/cps2.scm \
+ language/cps2/cse.scm \
language/cps2/compile-cps.scm \
language/cps2/constructors.scm \
language/cps2/contification.scm \
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 2248c26..039aa5b 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -78,7 +78,10 @@
;; analysis on the box created for the set!.
(run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
- (run-pass! prune-top-level-scopes #:prune-top-level-scopes? #t)
+ ;; The prune-top-level-scopes pass doesn't work if CSE has run
+ ;; beforehand. Since hopefully we will be able to just remove all the
+ ;; old CPS stuff, let's just disable the pass for now.
+ ;; (run-pass! prune-top-level-scopes #:prune-top-level-scopes? #t)
(run-pass! simplify #:simplify? #t)
(run-pass! contify #:contify? #t)
(run-pass! inline-constructors #:inline-constructors? #t)
diff --git a/module/language/cps2/cse.scm b/module/language/cps2/cse.scm
new file mode 100644
index 0000000..b5ac14d
--- /dev/null
+++ b/module/language/cps2/cse.scm
@@ -0,0 +1,449 @@
+;;; 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:
+;;;
+;;; Common subexpression elimination for CPS.
+;;;
+;;; Code:
+
+(define-module (language cps2 cse)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps2)
+ #:use-module (language cps2 utils)
+ #:use-module (language cps2 effects-analysis)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:export (eliminate-common-subexpressions))
+
+(define (intset-pop set)
+ (match (intset-next set)
+ (#f (values set #f))
+ (i (values (intset-remove set i) i))))
+
+(define-syntax-rule (make-worklist-folder* seed ...)
+ (lambda (f worklist seed ...)
+ (let lp ((worklist worklist) (seed seed) ...)
+ (call-with-values (lambda () (intset-pop worklist))
+ (lambda (worklist i)
+ (if i
+ (call-with-values (lambda () (f i seed ...))
+ (lambda (i* seed ...)
+ (let add ((i* i*) (worklist worklist))
+ (match i*
+ (() (lp worklist seed ...))
+ ((i . i*) (add i* (intset-add worklist i)))))))
+ (values seed ...)))))))
+
+(define worklist-fold*
+ (case-lambda
+ ((f worklist seed)
+ ((make-worklist-folder* seed) f worklist seed))))
+
+(define (compute-available-expressions conts kfun effects)
+ "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
+an intset containing ancestor labels whose value is available at LABEL."
+ (define (propagate avail succ out)
+ (let* ((in (intmap-ref avail succ (lambda (_) #f)))
+ (in* (if in (intset-intersect in out) out)))
+ (if (eq? in in*)
+ (values '() avail)
+ (values (list succ)
+ (intmap-add avail succ in* (lambda (old new) new))))))
+
+ (define (clobber label in)
+ (let ((fx (intmap-ref effects label)))
+ (cond
+ ((not (causes-effect? fx &write))
+ ;; Fast-path if this expression clobbers nothing.
+ in)
+ (else
+ ;; Kill clobbered expressions. FIXME: there is no need to check
+ ;; on any label before than the last dominating label that
+ ;; clobbered everything. Another way to speed things up would
+ ;; be to compute a clobber set per-effect, which we could
+ ;; subtract from "in".
+ (let lp ((label 0) (in in))
+ (cond
+ ((intset-next in label)
+ => (lambda (label)
+ (if (effect-clobbers? fx (intmap-ref effects label))
+ (lp (1+ label) (intset-remove in label))
+ (lp (1+ label) in))))
+ (else in)))))))
+
+ (define (visit-cont label avail)
+ (let* ((in (intmap-ref avail label))
+ (out (intset-add (clobber label in) label)))
+ (define (propagate0)
+ (values '() avail))
+ (define (propagate1 succ)
+ (propagate avail succ out))
+ (define (propagate2 succ0 succ1)
+ (let*-values (((changed0 avail) (propagate avail succ0 out))
+ ((changed1 avail) (propagate avail succ1 out)))
+ (values (append changed0 changed1) avail)))
+
+ (match (intmap-ref conts label)
+ (($ $kargs names vars ($ $continue k src exp))
+ (match exp
+ (($ $branch kt) (propagate2 k kt))
+ (($ $prompt escape? tag handler) (propagate2 k handler))
+ (_ (propagate1 k))))
+ (($ $kreceive arity k)
+ (propagate1 k))
+ (($ $kfun src meta self tail clause)
+ (if clause
+ (propagate1 clause)
+ (propagate0)))
+ (($ $kclause arity kbody kalt)
+ (if kalt
+ (propagate2 kbody kalt)
+ (propagate1 kbody)))
+ (($ $ktail) (propagate0)))))
+
+ (worklist-fold* visit-cont
+ (intset kfun)
+ (intmap-add empty-intmap kfun empty-intset)))
+
+(define (compute-truthy-expressions conts kfun boolv)
+ "Compute a \"truth map\", indicating which expressions can be shown to
+be true and/or false at each label in the function starting at KFUN..
+Returns an intmap of intsets. The even elements of the intset indicate
+labels that may be true, and the odd ones indicate those that may be
+false. It could be that both true and false proofs are available."
+ (define (true-idx label) (ash label 1))
+ (define (false-idx label) (1+ (ash label 1)))
+
+ (define (propagate boolv succ out)
+ (let* ((in (intmap-ref boolv succ (lambda (_) #f)))
+ (in* (if in (intset-intersect in out) out)))
+ (if (eq? in in*)
+ (values '() boolv)
+ (values (list succ)
+ (intmap-add boolv succ in* (lambda (old new) new))))))
+
+ (define (visit-cont label boolv)
+ (let ((in (intmap-ref boolv label)))
+ (define (propagate0)
+ (values '() boolv))
+ (define (propagate1 succ)
+ (propagate boolv succ in))
+ (define (propagate2 succ0 succ1)
+ (let*-values (((changed0 boolv) (propagate boolv succ0 in))
+ ((changed1 boolv) (propagate boolv succ1 in)))
+ (values (append changed0 changed1) boolv)))
+ (define (propagate-branch succ0 succ1)
+ (let*-values (((changed0 boolv)
+ (propagate boolv succ0
+ (intset-add in (false-idx label))))
+ ((changed1 boolv)
+ (propagate boolv succ1
+ (intset-add in (true-idx label)))))
+ (values (append changed0 changed1) boolv)))
+
+ (match (intmap-ref conts label)
+ (($ $kargs names vars ($ $continue k src exp))
+ (match exp
+ (($ $branch kt) (propagate-branch k kt))
+ (($ $prompt escape? tag handler) (propagate2 k handler))
+ (_ (propagate1 k))))
+ (($ $kreceive arity k)
+ (propagate1 k))
+ (($ $kfun src meta self tail clause)
+ (if clause
+ (propagate1 clause)
+ (propagate0)))
+ (($ $kclause arity kbody kalt)
+ (if kalt
+ (propagate2 kbody kalt)
+ (propagate1 kbody)))
+ (($ $ktail) (propagate0)))))
+
+ (let ((boolv (worklist-fold* visit-cont
+ (intset kfun)
+ (intmap-add boolv kfun empty-intset))))
+ ;; Now visit nested functions. We don't do this in the worklist
+ ;; folder because that would be exponential.
+ (define (recurse kfun boolv)
+ (compute-truthy-expressions conts kfun boolv))
+ (intset-fold
+ (lambda (label boolv)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue _ _ exp))
+ (match exp
+ (($ $fun kfun) (recurse kfun boolv))
+ (($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun))
+ (_ boolv)))
+ (_ boolv)))
+ (compute-function-body conts kfun)
+ boolv)))
+
+(define (intset-map f set)
+ (persistent-intmap
+ (intset-fold (lambda (i out) (intmap-add! out i (f i)))
+ set
+ empty-intmap)))
+
+;; Returns a map of label-idx -> (var-idx ...) indicating the variables
+;; defined by a given labelled expression.
+(define (compute-defs conts kfun)
+ (intset-map (lambda (label)
+ (match (intmap-ref conts label)
+ (($ $kfun src meta self tail clause)
+ (list self))
+ (($ $kclause arity body alt)
+ (match (intmap-ref conts body)
+ (($ $kargs names vars) vars)))
+ (($ $kreceive arity kargs)
+ (match (intmap-ref conts kargs)
+ (($ $kargs names vars) vars)))
+ (($ $ktail)
+ '())
+ (($ $kargs names vars ($ $continue k))
+ (match (intmap-ref conts k)
+ (($ $kargs names vars) vars)
+ (_ #f)))))
+ (compute-function-body conts kfun)))
+
+(define (compute-singly-referenced succs)
+ (define (visit label succs single multiple)
+ (intset-fold (lambda (label single multiple)
+ (if (intset-ref single label)
+ (values single (intset-add! multiple label))
+ (values (intset-add! single label) multiple)))
+ succs single multiple))
+ (call-with-values (lambda ()
+ (intmap-fold visit succs empty-intset empty-intset))
+ (lambda (single multiple)
+ (intset-subtract (persistent-intset single)
+ (persistent-intset multiple)))))
+
+(define (compute-equivalent-subexpressions conts kfun effects
+ equiv-labels var-substs)
+ (let* ((succs (compute-successors conts kfun))
+ (singly-referenced (compute-singly-referenced succs))
+ (avail (compute-available-expressions conts kfun effects))
+ (defs (compute-defs conts kfun))
+ (equiv-set (make-hash-table)))
+ (define (subst-var var-substs var)
+ (intmap-ref var-substs var (lambda (var) var)))
+ (define (subst-vars var-substs vars)
+ (let lp ((vars vars))
+ (match vars
+ (() '())
+ ((var . vars) (cons (subst-var var-substs var) (lp vars))))))
+
+ (define (compute-exp-key var-substs exp)
+ (match exp
+ (($ $const val) (cons 'const val))
+ (($ $prim name) (cons 'prim name))
+ (($ $fun body) #f)
+ (($ $rec names syms funs) #f)
+ (($ $call proc args) #f)
+ (($ $callk k proc args) #f)
+ (($ $primcall name args)
+ (cons* 'primcall name (subst-vars var-substs args)))
+ (($ $branch _ ($ $primcall name args))
+ (cons* 'primcall name (subst-vars var-substs args)))
+ (($ $branch) #f)
+ (($ $values args) #f)
+ (($ $prompt escape? tag handler) #f)))
+
+ (define (add-auxiliary-definitions! label var-substs exp-key)
+ (define (subst var)
+ (subst-var var-substs var))
+ (let ((defs (intmap-ref defs label)))
+ (define (add-def! aux-key var)
+ (let ((equiv (hash-ref equiv-set aux-key '())))
+ (hash-set! equiv-set aux-key
+ (acons label (list var) equiv))))
+ (match exp-key
+ (('primcall 'box val)
+ (match defs
+ ((box)
+ (add-def! `(primcall box-ref ,(subst box)) val))))
+ (('primcall 'box-set! box val)
+ (add-def! `(primcall box-ref ,box) val))
+ (('primcall 'cons car cdr)
+ (match defs
+ ((pair)
+ (add-def! `(primcall car ,(subst pair)) car)
+ (add-def! `(primcall cdr ,(subst pair)) cdr))))
+ (('primcall 'set-car! pair car)
+ (add-def! `(primcall car ,pair) car))
+ (('primcall 'set-cdr! pair cdr)
+ (add-def! `(primcall cdr ,pair) cdr))
+ (('primcall (or 'make-vector 'make-vector/immediate) len fill)
+ (match defs
+ ((vec)
+ (add-def! `(primcall vector-length ,(subst vec)) len))))
+ (('primcall 'vector-set! vec idx val)
+ (add-def! `(primcall vector-ref ,vec ,idx) val))
+ (('primcall 'vector-set!/immediate vec idx val)
+ (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
+ (('primcall (or 'allocate-struct 'allocate-struct/immediate)
+ vtable size)
+ (match defs
+ ((struct)
+ (add-def! `(primcall struct-vtable ,(subst struct))
+ vtable))))
+ (('primcall 'struct-set! struct n val)
+ (add-def! `(primcall struct-ref ,struct ,n) val))
+ (('primcall 'struct-set!/immediate struct n val)
+ (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
+ (_ #t))))
+
+ (define (visit-label label equiv-labels var-substs)
+ (match (intmap-ref conts label)
+ (($ $kargs names vars ($ $continue k src exp))
+ (let* ((exp-key (compute-exp-key var-substs exp))
+ (equiv (hash-ref equiv-set exp-key '()))
+ (fx (intmap-ref effects label))
+ (avail (intmap-ref avail label)))
+ (define (finish equiv-labels var-substs)
+ (define (recurse kfun equiv-labels var-substs)
+ (compute-equivalent-subexpressions conts kfun effects
+ equiv-labels var-substs))
+ ;; If this expression defines auxiliary definitions,
+ ;; as `cons' does for the results of `car' and `cdr',
+ ;; define those. Do so after finding equivalent
+ ;; expressions, so that we can take advantage of
+ ;; subst'd output vars.
+ (add-auxiliary-definitions! label var-substs exp-key)
+ (match exp
+ ;; If we see a $fun, recurse to add to the result.
+ (($ $fun kfun)
+ (recurse kfun equiv-labels var-substs))
+ (($ $rec names vars (($ $fun kfun) ...))
+ (fold2 recurse kfun equiv-labels var-substs))
+ (_
+ (values equiv-labels var-substs))))
+ (let lp ((candidates equiv))
+ (match candidates
+ (()
+ ;; No matching expressions. Add our expression
+ ;; to the equivalence set, if appropriate. Note
+ ;; that expressions that allocate a fresh object
+ ;; or change the current fluid environment can't
+ ;; be eliminated by CSE (though DCE might do it
+ ;; if the value proves to be unused, in the
+ ;; allocation case).
+ (when (and exp-key
+ (not (causes-effect? fx &allocation))
+ (not (effect-clobbers? fx (&read-object &fluid))))
+ (let ((defs (and (intset-ref singly-referenced k)
+ (intmap-ref defs label))))
+ (when defs
+ (hash-set! equiv-set exp-key
+ (acons label defs equiv)))))
+ (finish equiv-labels var-substs))
+ (((and head (candidate . vars)) . candidates)
+ (cond
+ ((not (intset-ref avail candidate))
+ ;; This expression isn't available here; try
+ ;; the next one.
+ (lp candidates))
+ (else
+ ;; Yay, a match. Mark expression as equivalent. If
+ ;; we provide the definitions for the successor, mark
+ ;; the vars for substitution.
+ (finish (intmap-add equiv-labels label head)
+ (let ((defs (and (intset-ref singly-referenced k)
+ (intmap-ref defs label))))
+ (if defs
+ (fold (lambda (def var var-substs)
+ (intmap-add var-substs def var))
+ var-substs defs vars)
+ var-substs))))))))))
+ (_ (values equiv-labels var-substs))))
+
+ ;; Traverse the labels in fun in reverse post-order, which will
+ ;; visit definitions before uses first.
+ (fold2 visit-label
+ (compute-reverse-post-order succs kfun)
+ equiv-labels
+ var-substs)))
+
+(define (apply-cse conts equiv-labels var-substs truthy-labels)
+ (define (true-idx idx) (ash idx 1))
+ (define (false-idx idx) (1+ (ash idx 1)))
+
+ (define (subst-var var)
+ (intmap-ref var-substs var (lambda (var) var)))
+
+ (define (visit-exp exp)
+ (rewrite-exp exp
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp)
+ (($ $call proc args)
+ ($call (subst-var proc) ,(map subst-var args)))
+ (($ $callk k proc args)
+ ($callk k (subst-var proc) ,(map subst-var args)))
+ (($ $primcall name args)
+ ($primcall name ,(map subst-var args)))
+ (($ $branch k exp)
+ ($branch k ,(visit-exp exp)))
+ (($ $values args)
+ ($values ,(map subst-var args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst-var tag) handler))))
+
+ (intmap-map
+ (lambda (label cont)
+ (match cont
+ (($ $kargs names vars ($ $continue k src exp))
+ (build-cont
+ ($kargs names vars
+ ,(match (intmap-ref equiv-labels label (lambda (_) #f))
+ ((equiv . vars)
+ (match exp
+ (($ $branch kt exp)
+ (let* ((bool (intmap-ref truthy-labels label))
+ (t (intset-ref bool (true-idx equiv)))
+ (f (intset-ref bool (false-idx equiv))))
+ (if (eqv? t f)
+ (build-term
+ ($continue k src
+ ($branch kt ,(visit-exp exp))))
+ (build-term
+ ($continue (if t kt k) src ($values ()))))))
+ (_
+ ;; For better or for worse, we only replace primcalls
+ ;; if they have an associated VM op, which allows
+ ;; them to continue to $kargs and thus we know their
+ ;; defs and can use a $values expression instead of a
+ ;; values primcall.
+ (build-term
+ ($continue k src ($values vars))))))
+ (#f
+ (build-term
+ ($continue k src ,(visit-exp exp))))))))
+ (_ cont)))
+ conts))
+
+(define (eliminate-common-subexpressions conts)
+ (call-with-values
+ (lambda ()
+ (let ((effects (synthesize-definition-effects (compute-effects
conts))))
+ (compute-equivalent-subexpressions conts 0 effects
+ empty-intmap empty-intmap)))
+ (lambda (equiv-labels var-substs)
+ (let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap)))
+ (apply-cse conts equiv-labels var-substs truthy-labels)))))
diff --git a/module/language/cps2/optimize.scm
b/module/language/cps2/optimize.scm
index adae8bb..26a1d57 100644
--- a/module/language/cps2/optimize.scm
+++ b/module/language/cps2/optimize.scm
@@ -26,6 +26,7 @@
#:use-module (ice-9 match)
#:use-module (language cps2 constructors)
#:use-module (language cps2 contification)
+ #:use-module (language cps2 cse)
#:use-module (language cps2 dce)
#:use-module (language cps2 elide-values)
#:use-module (language cps2 prune-top-level-scopes)
@@ -66,7 +67,7 @@
(run-pass! specialize-primcalls #:specialize-primcalls? #t)
(run-pass! elide-values #:elide-values? #t)
(run-pass! prune-bailouts #:prune-bailouts? #t)
- ;; (run-pass! eliminate-common-subexpressions #:cse? #t)
+ (run-pass! eliminate-common-subexpressions #:cse? #t)
;; (run-pass! type-fold #:type-fold? #t)
;; (run-pass! resolve-self-references #:resolve-self-references? #t)
;; (run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
- [Guile-commits] branch master updated (726558f -> f541ee1), Andy Wingo, 2015/06/03
- [Guile-commits] 05/06: Add setk clause to with-cps, Andy Wingo, 2015/06/03
- [Guile-commits] 01/06: Port prune-bailouts pass to CPS2, Andy Wingo, 2015/06/03
- [Guile-commits] 02/06: Move some graph utilities from contification.scm to utils.scm, Andy Wingo, 2015/06/03
- [Guile-commits] 03/06: Fix some cps2 utils bugs, Andy Wingo, 2015/06/03
- [Guile-commits] 06/06: Port type-fold to CPS2, Andy Wingo, 2015/06/03
- [Guile-commits] 04/06: Port CSE to CPS2,
Andy Wingo <=