guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 01/01: Add split-rec pass


From: Andy Wingo
Subject: [Guile-commits] 01/01: Add split-rec pass
Date: Sun, 07 Jun 2015 09:52:51 +0000

wingo pushed a commit to branch master
in repository guile.

commit dbe6247acfb40da8ca51f642aa6994ef36a56315
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 7 11:16:09 2015 +0200

    Add split-rec pass
    
    * module/language/cps2/split-rec.scm: New pass.
    * module/language/cps2/optimize.scm: Run new pass.
    * module/Makefile.am: Add new pass to build.
---
 module/Makefile.am                 |    1 +
 module/language/cps2/optimize.scm  |    4 +-
 module/language/cps2/split-rec.scm |  223 ++++++++++++++++++++++++++++++++++++
 3 files changed, 227 insertions(+), 1 deletions(-)

diff --git a/module/Makefile.am b/module/Makefile.am
index 32c6a87..88b84a1 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -163,6 +163,7 @@ CPS2_LANG_SOURCES =                                         
\
   language/cps2/self-references.scm                            \
   language/cps2/spec.scm                                       \
   language/cps2/specialize-primcalls.scm                       \
+  language/cps2/split-rec.scm                                  \
   language/cps2/type-fold.scm                                  \
   language/cps2/types.scm                                      \
   language/cps2/utils.scm                                      \
diff --git a/module/language/cps2/optimize.scm 
b/module/language/cps2/optimize.scm
index 1aee16a..3d4bb27 100644
--- a/module/language/cps2/optimize.scm
+++ b/module/language/cps2/optimize.scm
@@ -34,6 +34,7 @@
   #:use-module (language cps2 self-references)
   #:use-module (language cps2 simplify)
   #:use-module (language cps2 specialize-primcalls)
+  #:use-module (language cps2 split-rec)
   #:use-module (language cps2 type-fold)
   #:use-module (language cps2 verify)
   #:export (optimize))
@@ -71,7 +72,8 @@
   ;; 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! split-rec #:split-rec? #t)
+  (run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
   (run-pass! prune-top-level-scopes #:prune-top-level-scopes? #t)
   (run-pass! simplify #:simplify? #t)
   (run-pass! contify #:contify? #t)
diff --git a/module/language/cps2/split-rec.scm 
b/module/language/cps2/split-rec.scm
new file mode 100644
index 0000000..763ede5
--- /dev/null
+++ b/module/language/cps2/split-rec.scm
@@ -0,0 +1,223 @@
+;;; 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:
+;;;
+;;; Split functions bound in $rec expressions into strongly-connected
+;;; components.  The result will be that each $rec binds a
+;;; strongly-connected component of mutually recursive functions.
+;;;
+;;; Code:
+
+(define-module (language cps2 split-rec)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (language cps2)
+  #:use-module (language cps2 utils)
+  #:use-module (language cps2 with-cps)
+  #:use-module (language cps intmap)
+  #:use-module (language cps intset)
+  #:export (split-rec))
+
+(define (compute-free-vars conts kfun)
+  "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
+references."
+  (define (add-def var defs) (intset-add! defs var))
+  (define (add-defs vars defs)
+    (match vars
+      (() defs)
+      ((var . vars) (add-defs vars (add-def var defs)))))
+  (define (add-use var uses) (intset-add! uses var))
+  (define (add-uses vars uses)
+    (match vars
+      (() uses)
+      ((var . vars) (add-uses vars (add-use var uses)))))
+  (define (visit-nested-funs body)
+    (intset-fold
+     (lambda (label out)
+       (match (intmap-ref conts label)
+         (($ $kargs _ _ ($ $continue _ _
+                           ($ $fun kfun)))
+          (intmap-union out (visit-fun kfun)))
+         (($ $kargs _ _ ($ $continue _ _
+                           ($ $rec _ _ (($ $fun kfun) ...))))
+          (fold (lambda (kfun out)
+                  (intmap-union out (visit-fun kfun)))
+                out kfun))
+         (_ out)))
+     body
+     empty-intmap))
+  (define (visit-fun kfun)
+    (let* ((body (compute-function-body conts kfun))
+           (free (visit-nested-funs body)))
+      (call-with-values
+          (lambda ()
+            (intset-fold
+             (lambda (label defs uses)
+               (match (intmap-ref conts label)
+                 (($ $kargs names vars ($ $continue k src exp))
+                  (values
+                   (add-defs vars defs)
+                   (match exp
+                     ((or ($ $const) ($ $prim)) uses)
+                     (($ $fun kfun)
+                      (intset-union (persistent-intset uses)
+                                    (intmap-ref free kfun)))
+                     (($ $rec names vars (($ $fun kfun) ...))
+                      (fold (lambda (kfun uses)
+                              (intset-union (persistent-intset uses)
+                                            (intmap-ref free kfun)))
+                            uses kfun))
+                     (($ $values args)
+                      (add-uses args uses))
+                     (($ $call proc args)
+                      (add-use proc (add-uses args uses)))
+                     (($ $branch kt ($ $values (arg)))
+                      (add-use arg uses))
+                     (($ $branch kt ($ $primcall name args))
+                      (add-uses args uses))
+                     (($ $primcall name args)
+                      (add-uses args uses))
+                     (($ $prompt escape? tag handler)
+                      (add-use tag uses)))))
+                 (($ $kfun src meta self)
+                  (values (add-def self defs) uses))
+                 (_ (values defs uses))))
+             body empty-intset empty-intset))
+        (lambda (defs uses)
+          (intmap-add free kfun (intset-subtract
+                                 (persistent-intset uses)
+                                 (persistent-intset defs)))))))
+  (visit-fun kfun))
+
+(define (intmap-keys map)
+  (persistent-intset
+   (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
+
+(define (compute-sorted-strongly-connected-components edges)
+  (define nodes
+    (intmap-keys edges))
+  ;; Add a "start" node that links to all nodes in the graph, and then
+  ;; remove it from the result.
+  (define components
+    (intmap-remove
+     (compute-strongly-connected-components (intmap-add edges 0 nodes) 0)
+     0))
+  (define node-components
+    (intmap-fold (lambda (id nodes out)
+                   (intset-fold (lambda (node out) (intmap-add out node id))
+                                nodes out))
+                 components
+                 empty-intmap))
+  (define (node-component node)
+    (intmap-ref node-components node))
+  (define (component-successors id nodes)
+    (intset-remove
+     (intset-fold (lambda (node out)
+                    (intset-fold
+                     (lambda (successor out)
+                       (intset-add out (node-component successor)))
+                     (intmap-ref edges node)
+                     out))
+                  nodes
+                  empty-intset)
+     id))
+  (define component-edges
+    (intmap-map component-successors components))
+  (define preds
+    (invert-graph component-edges))
+  (define roots
+    (intmap-fold (lambda (id succs out)
+                   (if (eq? empty-intset succs)
+                       (intset-add out id)
+                       out))
+                 component-edges
+                 empty-intset))
+  ;; As above, add a "start" node that links to the roots, and remove it
+  ;; from the result.
+  (match (compute-reverse-post-order (intmap-add preds 0 roots) 0)
+    ((0 . ids)
+     (map (lambda (id) (intmap-ref components id)) ids))))
+
+(define (compute-split fns free-vars)
+  (define (get-free kfun)
+    ;; It's possible for a fun to have been skipped by
+    ;; compute-free-vars, if the fun isn't reachable.  Fall back to
+    ;; empty-intset for the fun's free vars, in that case.
+    (intmap-ref free-vars kfun (lambda (_) empty-intset)))
+  (let* ((vars (intmap-keys fns))
+         (edges (intmap-map
+                 (lambda (var kfun)
+                   (intset-intersect (get-free kfun) vars))
+                 fns)))
+    (compute-sorted-strongly-connected-components edges)))
+
+(define (intmap-acons k v map)
+  (intmap-add map k v))
+
+(define (split-rec conts)
+  (let ((free (compute-free-vars conts 0)))
+    (with-fresh-name-state conts
+      (persistent-intmap
+       (intmap-fold
+        (lambda (label cont out)
+          (match cont
+            (($ $kargs cont-names cont-vars
+                ($ $continue k src ($ $rec names vars (($ $fun kfuns) ...))))
+             (let ((fns (fold intmap-acons empty-intmap vars kfuns))
+                   (fn-names (fold intmap-acons empty-intmap vars names)))
+               (match (compute-split fns free)
+                 (()
+                  ;; Remove trivial $rec.
+                  (with-cps out
+                    (setk label ($kargs cont-names cont-vars
+                                  ($continue k src ($values ()))))))
+                 ((_)
+                  ;; Bound functions already form a strongly-connected
+                  ;; component.
+                  out)
+                 (components
+                  ;; Multiple components.  Split them into separate $rec
+                  ;; expressions.
+                  (define (build-body out components)
+                    (match components
+                      (()
+                       (match (intmap-ref out k)
+                         (($ $kargs names vars term)
+                          (with-cps (intmap-remove out k)
+                            term))))
+                      ((vars . components)
+                       (match (intset-fold
+                               (lambda (var out)
+                                 (let ((name (intmap-ref fn-names var))
+                                       (fun (build-exp
+                                              ($fun (intmap-ref fns var)))))
+                                   (cons (list name var fun) out)))
+                               vars '())
+                         (((name var fun) ...)
+                          (with-cps out
+                            (let$ body (build-body components))
+                            (letk kbody ($kargs name var ,body))
+                            (build-term
+                              ($continue kbody src ($rec name var fun)))))))))
+                  (with-cps out
+                    (let$ body (build-body components))
+                    (setk label ($kargs cont-names cont-vars ,body)))))))
+             (_ out)))
+          conts
+          conts)))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]