[Guile-commits] 04/06: Port CSE to CPS2

[Andy Wingo]

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)