mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
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.
This commit is contained in:
Andy Wingo
parent
f41823538a
commit
dbe6247acf
3 changed files with 227 additions and 1 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
223
module/language/cps2/split-rec.scm
Normal file
223
module/language/cps2/split-rec.scm
Normal file
|
|
@ -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)))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue