mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Rotate comparisons down to loop back-edges
* module/language/cps/rotate-loops.scm: New pass. * module/Makefile.am: * module/language/cps/optimize.scm: Wire up the new pass.
This commit is contained in:
Andy Wingo
parent
bf6930b3f6
commit
ee85e2969f
3 changed files with 220 additions and 0 deletions
|
|
@ -136,6 +136,7 @@ CPS_LANG_SOURCES = \
|
|||
language/cps/prune-top-level-scopes.scm \
|
||||
language/cps/reify-primitives.scm \
|
||||
language/cps/renumber.scm \
|
||||
language/cps/rotate-loops.scm \
|
||||
language/cps/optimize.scm \
|
||||
language/cps/simplify.scm \
|
||||
language/cps/self-references.scm \
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@
|
|||
#:use-module (language cps licm)
|
||||
#:use-module (language cps prune-top-level-scopes)
|
||||
#:use-module (language cps prune-bailouts)
|
||||
#:use-module (language cps rotate-loops)
|
||||
#:use-module (language cps self-references)
|
||||
#:use-module (language cps simplify)
|
||||
#:use-module (language cps specialize-primcalls)
|
||||
|
|
@ -105,4 +106,5 @@
|
|||
|
||||
(define-optimizer optimize-first-order-cps
|
||||
(eliminate-dead-code #:eliminate-dead-code? #t)
|
||||
(rotate-loops #:rotate-loops? #t)
|
||||
(simplify #:simplify? #t))
|
||||
|
|
|
|||
217
module/language/cps/rotate-loops.scm
Normal file
217
module/language/cps/rotate-loops.scm
Normal file
|
|
@ -0,0 +1,217 @@
|
|||
;;; 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:
|
||||
;;;
|
||||
;;; Rotate loops so that they end with conditional jumps, if possible.
|
||||
;;; The result goes from:
|
||||
;;;
|
||||
;;; loop:
|
||||
;;; if x < 5 goto done;
|
||||
;;; x = x + 1;
|
||||
;;; goto loop;
|
||||
;;; done:
|
||||
;;;
|
||||
;;; if x < 5 goto done;
|
||||
;;; loop:
|
||||
;;; x = x + 1;
|
||||
;;; if x < 5 goto done;
|
||||
;;; done:
|
||||
;;;
|
||||
;;; It's more code but there are fewer instructions in the body. Note
|
||||
;;; that this transformation isn't guaranteed to produce a loop that
|
||||
;;; ends in a conditional jump, because usually your loop has some state
|
||||
;;; that it's shuffling around and for now that shuffle is reified with
|
||||
;;; the test, not the loop header. Alack.
|
||||
;;;
|
||||
;;; Implementation-wise, things are complicated by values flowing out of
|
||||
;;; the loop. We actually perform this transformation only on loops
|
||||
;;; that have a single exit continuation, so that we define values
|
||||
;;; flowing out in one place. We rename the loop variables in two
|
||||
;;; places internally: one for the peeled comparison, and another for
|
||||
;;; the body. The loop variables' original names are then bound in a
|
||||
;;; join continuation for use by successor code.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps rotate-loops)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module ((srfi srfi-1) #:select (filter-map))
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (language cps)
|
||||
#:use-module (language cps utils)
|
||||
#:use-module (language cps intmap)
|
||||
#:use-module (language cps intset)
|
||||
#:export (rotate-loops))
|
||||
|
||||
(define-record-type $loop
|
||||
(make-loop entry exits body)
|
||||
loop?
|
||||
(entry loop-entry)
|
||||
(exits loop-exits)
|
||||
(body loop-body))
|
||||
|
||||
(define (find-exits scc succs)
|
||||
(intset-fold (lambda (label exits)
|
||||
(if (eq? empty-intset
|
||||
(intset-subtract (intmap-ref succs label) scc))
|
||||
exits
|
||||
(intset-add exits label)))
|
||||
scc
|
||||
empty-intset))
|
||||
|
||||
(define (find-entry scc preds)
|
||||
(trivial-intset (find-exits scc preds)))
|
||||
|
||||
(define (rotate-loop cps entry-label body-labels succs preds back-edges)
|
||||
(match (intmap-ref cps entry-label)
|
||||
((and entry-cont
|
||||
($ $kargs entry-names entry-vars
|
||||
($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp))))
|
||||
(let* ((exit-if-true? (intset-ref body-labels entry-kf))
|
||||
(exit (if exit-if-true? entry-kt entry-kf))
|
||||
(new-entry-label (if exit-if-true? entry-kf entry-kt))
|
||||
(join-label (fresh-label))
|
||||
(join-cont (build-cont
|
||||
($kargs entry-names entry-vars
|
||||
($continue exit entry-src ($values ())))))
|
||||
(cps (intmap-add! cps join-label join-cont)))
|
||||
(define (make-fresh-vars)
|
||||
(map (lambda (_) (fresh-var)) entry-vars))
|
||||
(define (make-trampoline k src values)
|
||||
(build-cont ($kargs () () ($continue k src ($values values)))))
|
||||
(define (replace-exit k trampoline)
|
||||
(if (eqv? k exit) trampoline k))
|
||||
(define (rename-exp exp vars)
|
||||
(define (rename-var var)
|
||||
(match (list-index entry-vars var)
|
||||
(#f var)
|
||||
(idx (list-ref vars idx))))
|
||||
(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $closure)) ,exp)
|
||||
(($ $values args)
|
||||
($values ,(map rename-var args)))
|
||||
(($ $call proc args)
|
||||
($call (rename-var proc) ,(map rename-var args)))
|
||||
(($ $callk k proc args)
|
||||
($callk k (rename-var proc) ,(map rename-var args)))
|
||||
(($ $branch kt ($ $values (arg)))
|
||||
($branch kt ($values ((rename-var arg)))))
|
||||
(($ $branch kt ($ $primcall name args))
|
||||
($branch kt ($primcall name ,(map rename-var args))))
|
||||
(($ $primcall name args)
|
||||
($primcall name ,(map rename-var args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (rename-var tag) handler))))
|
||||
(define (attach-trampoline label src names vars args)
|
||||
(let* ((trampoline-out-label (fresh-label))
|
||||
(trampoline-out-cont
|
||||
(make-trampoline join-label src args))
|
||||
(trampoline-in-label (fresh-label))
|
||||
(trampoline-in-cont
|
||||
(make-trampoline new-entry-label src args))
|
||||
(kf (if exit-if-true? trampoline-in-label trampoline-out-label))
|
||||
(kt (if exit-if-true? trampoline-out-label trampoline-in-label))
|
||||
(cont (build-cont
|
||||
($kargs names vars
|
||||
($continue kf entry-src
|
||||
($branch kt ,(rename-exp entry-exp args))))))
|
||||
(cps (intmap-replace! cps label cont))
|
||||
(cps (intmap-add! cps trampoline-in-label trampoline-in-cont)))
|
||||
(intmap-add! cps trampoline-out-label trampoline-out-cont)))
|
||||
;; Rewrite the targets of the entry branch to go to
|
||||
;; trampolines. One will pass values out of the loop, and
|
||||
;; one will pass values into the loop.
|
||||
(let* ((pre-header-vars (make-fresh-vars))
|
||||
(body-vars (make-fresh-vars))
|
||||
(cps (attach-trampoline entry-label entry-src
|
||||
entry-names pre-header-vars
|
||||
pre-header-vars))
|
||||
(new-entry-cont (build-cont
|
||||
($kargs entry-names body-vars
|
||||
,(match (intmap-ref cps new-entry-label)
|
||||
(($ $kargs () () term) term)))))
|
||||
(cps (intmap-replace! cps new-entry-label new-entry-cont)))
|
||||
(intset-fold
|
||||
(lambda (label cps)
|
||||
(if (intset-ref back-edges label)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue _ src exp))
|
||||
(match (rename-exp exp body-vars)
|
||||
(($ $values args)
|
||||
(attach-trampoline label src names vars args))
|
||||
(exp
|
||||
(let* ((args (make-fresh-vars))
|
||||
(bind-label (fresh-label))
|
||||
(edge* (build-cont
|
||||
($kargs names vars
|
||||
($continue bind-label src ,exp))))
|
||||
(cps (intmap-replace! cps label edge*))
|
||||
;; attach-trampoline uses intmap-replace!.
|
||||
(cps (intmap-add! cps bind-label #f)))
|
||||
(attach-trampoline bind-label src
|
||||
entry-names args args))))))
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(let ((cont (build-cont
|
||||
($kargs names vars
|
||||
($continue k src
|
||||
,(rename-exp exp body-vars))))))
|
||||
(intmap-replace! cps label cont)))
|
||||
(($ $kreceive) cps))))
|
||||
(intset-remove body-labels entry-label)
|
||||
cps))))))
|
||||
|
||||
(define (rotate-loops-in-function kfun body cps)
|
||||
(define (can-rotate? edges)
|
||||
(intset-fold (lambda (label rotate?)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kreceive) #f)
|
||||
(($ $kargs _ _ ($ $continue _ _ exp))
|
||||
(match exp
|
||||
(($ $branch) #f)
|
||||
(_ rotate?)))))
|
||||
edges #t))
|
||||
(let* ((succs (compute-successors cps kfun))
|
||||
(preds (invert-graph succs)))
|
||||
(intmap-fold
|
||||
(lambda (id scc cps)
|
||||
(cond
|
||||
((trivial-intset scc) cps)
|
||||
((find-entry scc preds)
|
||||
=> (lambda (entry)
|
||||
(let ((back-edges (intset-intersect scc
|
||||
(intmap-ref preds entry))))
|
||||
(if (and (can-rotate? back-edges)
|
||||
(eqv? (trivial-intset (find-exits scc succs)) entry))
|
||||
;; Loop header is the only exit. It must be a
|
||||
;; conditional branch and only one successor is an
|
||||
;; exit. The values flowing out of the loop are the
|
||||
;; loop variables.
|
||||
(rotate-loop cps entry scc succs preds back-edges)
|
||||
cps))))
|
||||
(else cps)))
|
||||
(compute-strongly-connected-components succs kfun)
|
||||
cps)))
|
||||
|
||||
(define (rotate-loops cps)
|
||||
(persistent-intmap
|
||||
(with-fresh-name-state cps
|
||||
(intmap-fold rotate-loops-in-function
|
||||
(compute-reachable-functions cps)
|
||||
cps))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue