summaryrefslogtreecommitdiff
path: root/module/language/cps/rotate-loops.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-01-03 14:15:35 +0100
committerAndy Wingo <wingo@pobox.com>2018-01-03 16:16:39 +0100
commitafb0a92d501af0c2ffa5428a35171ba40782f8ca (patch)
tree7e684269620519b7c77538c6f5795e0e1b9ef298 /module/language/cps/rotate-loops.scm
parent108ade6b0efe6e3f720e2c89731879d0d24632d1 (diff)
downloadguile-afb0a92d501af0c2ffa5428a35171ba40782f8ca.tar.gz
$branch is now a distinct CPS term type
* module/language/cps.scm ($branch): Refactor to be its own CPS term type, not relying on $continue to specify a continuation (which before was only for the false case) or a source location. Update allllllll callers.
Diffstat (limited to 'module/language/cps/rotate-loops.scm')
-rw-r--r--module/language/cps/rotate-loops.scm135
1 files changed, 65 insertions, 70 deletions
diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm
index 93ac0b3cc..dbc2f9e5e 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@@ -55,6 +55,7 @@
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
+ #:use-module (language cps with-cps)
#:export (rotate-loops))
(define (loop-successors scc succs)
@@ -79,7 +80,8 @@
(match (intmap-ref cps entry-label)
((and entry-cont
($ $kargs entry-names entry-vars
- ($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp))))
+ ($ $branch entry-kf entry-kt entry-src
+ entry-op entry-param entry-args)))
(let* ((exit-if-true? (intset-ref body-labels entry-kf))
(loop-exits (find-exits body-labels succs))
(exit (if exit-if-true? entry-kt entry-kf))
@@ -93,49 +95,50 @@
(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 ($ $primcall name param args))
- ($branch kt ($primcall name param ,(map rename-var args))))
- (($ $primcall name param args)
- ($primcall name param ,(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)))
+ (define (rename-var var replacements)
+ "If VAR refers to a member of ENTRY-VARS, replace with a
+corresponding var from REPLACEMENTS; otherwise return VAR."
+ (match (list-index entry-vars var)
+ (#f var)
+ (idx (list-ref replacements idx))))
+ (define (rename-vars vars replacements)
+ (map (lambda (var) (rename-var var replacements)) vars))
+ (define (rename-term term replacements)
+ (define (rename arg) (rename-var arg replacements))
+ (define (rename* arg) (rename-vars arg replacements))
+ (rewrite-term term
+ (($ $continue k src exp)
+ ($continue k src
+ ,(rewrite-exp exp
+ ((or ($ $const) ($ $prim) ($ $closure)) ,exp)
+ (($ $values args)
+ ($values ,(rename* args)))
+ (($ $call proc args)
+ ($call (rename proc) ,(rename* args)))
+ (($ $callk k proc args)
+ ($callk k (rename proc) ,(rename* args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(rename* args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (rename tag) handler)))))
+ (($ $branch kf kt src op param args)
+ ($branch kf kt src op param ,(rename* args)))))
+ (define (attach-trampoline cps label src names vars args)
+ (with-cps cps
+ (letk ktramp-out ,(make-trampoline join-label src args))
+ (letk ktramp-in ,(make-trampoline new-entry-label src args))
+ (setk label
+ ($kargs names vars
+ ($branch (if exit-if-true? ktramp-in ktramp-out)
+ (if exit-if-true? ktramp-out ktramp-in)
+ entry-src
+ entry-op entry-param ,(rename-vars entry-args args))))))
;; 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
+ (cps (attach-trampoline cps entry-label entry-src
entry-names pre-header-vars
pre-header-vars))
(new-entry-cont (build-cont
@@ -148,44 +151,38 @@
(cond
((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
+ (($ $kargs names vars term)
+ (match (rename-term term body-vars)
+ (($ $continue _ src ($ $values args))
+ (attach-trampoline cps label src names vars args))
+ (($ $continue _ src 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!.
+ ;; attach-trampoline uses setk.
(cps (intmap-add! cps bind-label #f)))
- (attach-trampoline bind-label src
+ (attach-trampoline cps bind-label src
entry-names args args)))))))
((intset-ref loop-exits label)
(match (intmap-ref cps label)
- (($ $kargs names vars
- ($ $continue kf src ($ $branch kt exp)))
- (let* ((trampoline-out-label (fresh-label))
- (trampoline-out-cont
- (make-trampoline join-label src body-vars))
- (kf (if (eqv? kf exit) trampoline-out-label kf))
- (kt (if (eqv? kt exit) trampoline-out-label kt))
- (cont (build-cont
- ($kargs names vars
- ($continue kf src
- ($branch kt ,(rename-exp exp body-vars))))))
- (cps (intmap-replace! cps label cont)))
- (intmap-add! cps trampoline-out-label trampoline-out-cont)))))
+ (($ $kargs names vars ($ $branch kf kt src op param args))
+ (with-cps cps
+ (letk ktramp-out ,(make-trampoline join-label src body-vars))
+ (setk label
+ ($kargs names vars
+ ($branch (if (eqv? kf exit) ktramp-out kf)
+ (if (eqv? kt exit) ktramp-out kt)
+ src
+ op param ,(rename-vars args body-vars))))))))
(else
(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)))
+ (($ $kargs names vars term)
+ (with-cps cps
+ (setk label ($kargs names vars
+ ,(rename-term term body-vars)))))
(($ $kreceive) cps)))))
(intset-remove body-labels entry-label)
cps))))))
@@ -195,10 +192,8 @@
(intset-fold (lambda (label rotate?)
(match (intmap-ref cps label)
(($ $kreceive) #f)
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- (($ $branch) #f)
- (_ rotate?)))))
+ (($ $kargs _ _ ($ $branch)) #f)
+ (($ $kargs _ _ ($ $continue)) rotate?)))
edges #t))
(let* ((succs (compute-successors cps kfun))
(preds (invert-graph succs)))