summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-06-07 11:16:09 +0200
committerAndy Wingo <wingo@pobox.com>2015-06-07 11:16:09 +0200
commitdbe6247acfb40da8ca51f642aa6994ef36a56315 (patch)
treee1eb66476459ec71853f261a1e599a823492eb5c /module
parentf41823538a3a35c32bb0d4f23092e37f43d57f1f (diff)
downloadguile-dbe6247acfb40da8ca51f642aa6994ef36a56315.tar.gz
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.
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am1
-rw-r--r--module/language/cps2/optimize.scm4
-rw-r--r--module/language/cps2/split-rec.scm223
3 files changed, 227 insertions, 1 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 32c6a87c6..88b84a1a3 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 1aee16a69..3d4bb2753 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 000000000..763ede570
--- /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)))))