diff options
author | Andy Wingo <wingo@pobox.com> | 2015-06-07 11:16:09 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-06-07 11:16:09 +0200 |
commit | dbe6247acfb40da8ca51f642aa6994ef36a56315 (patch) | |
tree | e1eb66476459ec71853f261a1e599a823492eb5c /module | |
parent | f41823538a3a35c32bb0d4f23092e37f43d57f1f (diff) | |
download | guile-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.am | 1 | ||||
-rw-r--r-- | module/language/cps2/optimize.scm | 4 | ||||
-rw-r--r-- | 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 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))))) |