summaryrefslogtreecommitdiff
path: root/module/language/cps/graphs.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/graphs.scm')
-rw-r--r--module/language/cps/graphs.scm88
1 files changed, 86 insertions, 2 deletions
diff --git a/module/language/cps/graphs.scm b/module/language/cps/graphs.scm
index 8be36c84d..abdca76c9 100644
--- a/module/language/cps/graphs.scm
+++ b/module/language/cps/graphs.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015, 2017-2021 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
@@ -23,6 +23,7 @@
;;; Code:
(define-module (language cps graphs)
+ #:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps intset)
@@ -33,6 +34,7 @@
intmap-map
intmap-keys
invert-bijection invert-partition
+ rename-keys rename-intset rename-graph
intset->intmap
intmap-select
worklist-fold
@@ -43,7 +45,9 @@
compute-reverse-post-order
compute-strongly-connected-components
compute-sorted-strongly-connected-components
- solve-flow-equations))
+ compute-reverse-control-flow-order
+ solve-flow-equations
+ compute-live-variables))
(define-inlinable (fold1 f l s0)
(let lp ((l l) (s0 s0))
@@ -162,6 +166,32 @@ intset of successors, return a graph SUCC->PRED...."
succs
(intmap-map (lambda (label _) empty-intset) succs)))
+(define (rename-keys map old->new)
+ "Return a fresh intmap containing F(K) -> V for K and V in MAP, where
+F is looking up K in the intmap OLD->NEW."
+ (persistent-intmap
+ (intmap-fold (lambda (k v out)
+ (intmap-add! out (intmap-ref old->new k) v))
+ map
+ empty-intmap)))
+
+(define (rename-intset set old->new)
+ "Return a fresh intset of F(K) for K in SET, where F is looking up K
+in the intmap OLD->NEW."
+ (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old)))
+ set empty-intset))
+
+(define (rename-graph graph old->new)
+ "Return a fresh intmap containing F(K) -> intset(F(V)...) for K and
+intset(V...) in GRAPH, where F is looking up K in the intmap OLD->NEW."
+ (persistent-intmap
+ (intmap-fold (lambda (pred succs out)
+ (intmap-add! out
+ (intmap-ref old->new pred)
+ (rename-intset succs old->new)))
+ graph
+ empty-intmap)))
+
(define (compute-strongly-connected-components succs start)
"Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
partitioning the labels into strongly connected components (SCCs)."
@@ -232,6 +262,37 @@ connected components in sorted order."
(((? (lambda (id) (eqv? id start))) . ids)
(map (lambda (id) (intmap-ref components id)) ids))))
+(define (compute-reverse-control-flow-order preds)
+ "Return a LABEL->ORDER bijection where ORDER is a contiguous set of
+integers starting from 0 and incrementing in sort order. There is a
+precondition that labels in PREDS are already renumbered in reverse post
+order."
+ (define (has-back-edge? preds)
+ (let/ec return
+ (intmap-fold (lambda (label labels)
+ (intset-fold (lambda (pred)
+ (if (<= label pred)
+ (return #t)
+ (values)))
+ labels)
+ (values))
+ preds)
+ #f))
+ (if (has-back-edge? preds)
+ ;; This is more involved than forward control flow because not all
+ ;; live labels are reachable from the tail.
+ (persistent-intmap
+ (fold2 (lambda (component order n)
+ (intset-fold (lambda (label order n)
+ (values (intmap-add! order label n)
+ (1+ n)))
+ component order n))
+ (reverse (compute-sorted-strongly-connected-components preds))
+ empty-intmap 0))
+ ;; Just reverse forward control flow.
+ (let ((max (intmap-prev preds)))
+ (intmap-map (lambda (label labels) (- max label)) preds))))
+
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
@@ -274,3 +335,26 @@ SUBTRACT, ADD, and MEET operates on that state."
(run (intset-union worklist changed) in out)))
(values (persistent-intmap in)
(persistent-intmap out)))))))
+
+(define (compute-live-variables preds defs uses)
+ "Compute and return two values mapping LABEL->VAR..., where VAR... are
+the definitions that are live before and after LABEL, as intsets."
+ (let* ((old->new (compute-reverse-control-flow-order preds))
+ (init (persistent-intmap (intmap-fold
+ (lambda (old new init)
+ (intmap-add! init new empty-intset))
+ old->new empty-intmap))))
+ (call-with-values
+ (lambda ()
+ (solve-flow-equations (rename-graph preds old->new)
+ init init
+ (rename-keys defs old->new)
+ (rename-keys uses old->new)
+ intset-subtract intset-union intset-union))
+ (lambda (in out)
+ ;; As a reverse control-flow problem, the values flowing into a
+ ;; node are actually the live values after the node executes.
+ ;; Funny, innit? So we return them in the reverse order.
+ (let ((new->old (invert-bijection old->new)))
+ (values (rename-keys out new->old)
+ (rename-keys in new->old)))))))