Split graph utilities out of (language cps utils)

* module/language/cps/graphs.scm: New file.
* module/language/cps/utils.scm: Re-export functions from graphs.scm.
* am/bootstrap.am:
* module/Makefile.am: Add to build.

am/bootstrap.am

@@ -56,7 +56,7 @@ SOURCES =					\
   ice-9/psyntax-pp.scm				\
   language/cps/intmap.scm			\
   language/cps/intset.scm			\
-  language/cps/utils.scm			\
+  language/cps/graphs.scm			\
   ice-9/vlist.scm				\
   srfi/srfi-1.scm				\
 						\
@@ -99,6 +99,7 @@ SOURCES =					\
   language/cps/type-checks.scm			\
   language/cps/type-fold.scm			\
   language/cps/types.scm			\
+  language/cps/utils.scm			\
   language/cps/verify.scm			\
   language/cps/with-cps.scm			\
 						\

module/Makefile.am

@@ -1,7 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-##  	Copyright (C) 2009, 2010, 2011, 2012, 2013,
+##   Copyright (C) 2009-2019 Free Software Foundation, Inc.
-##        2014, 2015, 2017, 2018 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -136,6 +135,7 @@ SOURCES =					\
   language/cps/dce.scm				\
   language/cps/devirtualize-integers.scm	\
   language/cps/effects-analysis.scm		\
+  language/cps/graphs.scm			\
   language/cps/intmap.scm			\
   language/cps/intset.scm			\
   language/cps/licm.scm				\

module/language/cps/graphs.scm

@@ -0,0 +1,268 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013-2015, 2017-2019 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:
+;;;
+;;; Helper facilities for working with graphs over intsets and intmaps.
+;;;
+;;; Code:
+
+(define-module (language cps graphs)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (language cps intset)
+  #:use-module (language cps intmap)
+  #:export (;; Various utilities.
+            fold1 fold2
+            trivial-intset
+            intmap-map
+            intmap-keys
+            invert-bijection invert-partition
+            intset->intmap
+            worklist-fold
+            fixpoint
+
+            ;; Flow analysis.
+            invert-graph
+            compute-reverse-post-order
+            compute-strongly-connected-components
+            compute-sorted-strongly-connected-components
+            solve-flow-equations))
+
+(define-inlinable (fold1 f l s0)
+  (let lp ((l l) (s0 s0))
+    (match l
+      (() s0)
+      ((elt . l) (lp l (f elt s0))))))
+
+(define-inlinable (fold2 f l s0 s1)
+  (let lp ((l l) (s0 s0) (s1 s1))
+    (match l
+      (() (values s0 s1))
+      ((elt . l)
+       (call-with-values (lambda () (f elt s0 s1))
+         (lambda (s0 s1)
+           (lp l s0 s1)))))))
+
+(define (trivial-intset set)
+  "Returns the sole member of @var{set}, if @var{set} has exactly one
+member, or @code{#f} otherwise."
+  (let ((first (intset-next set)))
+    (and first
+         (not (intset-next set (1+ first)))
+         first)))
+
+(define (intmap-map proc map)
+  (persistent-intmap
+   (intmap-fold (lambda (k v out) (intmap-add! out k (proc k v)))
+                map
+                empty-intmap)))
+
+(define (intmap-keys map)
+  "Return an intset of the keys in @var{map}."
+  (persistent-intset
+   (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
+
+(define (invert-bijection map)
+  "Assuming the values of @var{map} are integers and are unique, compute
+a map in which each value maps to its key.  If the values are not
+unique, an error will be signalled."
+  (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap))
+
+(define (invert-partition map)
+  "Assuming the values of @var{map} are disjoint intsets, compute a map
+in which each member of each set maps to its key.  If the values are not
+disjoint, an error will be signalled."
+  (intmap-fold (lambda (k v* out)
+                 (intset-fold (lambda (v out) (intmap-add out v k)) v* out))
+               map empty-intmap))
+
+(define (intset->intmap f set)
+  (persistent-intmap
+   (intset-fold (lambda (label preds)
+                  (intmap-add! preds label (f label)))
+                set empty-intmap)))
+
+(define worklist-fold
+  (case-lambda
+    ((f in out)
+     (let lp ((in in) (out out))
+       (if (eq? in empty-intset)
+           out
+           (call-with-values (lambda () (f in out)) lp))))
+    ((f in out0 out1)
+     (let lp ((in in) (out0 out0) (out1 out1))
+       (if (eq? in empty-intset)
+           (values out0 out1)
+           (call-with-values (lambda () (f in out0 out1)) lp))))))
+
+(define fixpoint
+  (case-lambda
+    ((f x)
+     (let lp ((x x))
+       (let ((x* (f x)))
+         (if (eq? x x*) x* (lp x*)))))
+    ((f x0 x1)
+     (let lp ((x0 x0) (x1 x1))
+       (call-with-values (lambda () (f x0 x1))
+         (lambda (x0* x1*)
+           (if (and (eq? x0 x0*) (eq? x1 x1*))
+               (values x0* x1*)
+               (lp x0* x1*))))))))
+
+(define (compute-reverse-post-order succs start)
+  "Compute a reverse post-order numbering for a depth-first walk over
+nodes reachable from the start node."
+  (let visit ((label start) (order '()) (visited empty-intset))
+    (call-with-values
+        (lambda ()
+          (intset-fold (lambda (succ order visited)
+                         (if (intset-ref visited succ)
+                             (values order visited)
+                             (visit succ order visited)))
+                       (intmap-ref succs label)
+                       order
+                       (intset-add! visited label)))
+      (lambda (order visited)
+        ;; After visiting successors, add label to the reverse post-order.
+        (values (cons label order) visited)))))
+
+(define (invert-graph succs)
+  "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an
+intset of successors, return a graph SUCC->PRED...."
+  (intmap-fold (lambda (pred succs preds)
+                 (intset-fold
+                  (lambda (succ preds)
+                    (intmap-add preds succ pred intset-add))
+                  succs
+                  preds))
+               succs
+               (intmap-map (lambda (label _) empty-intset) succs)))
+
+(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)."
+  (let ((preds (invert-graph succs)))
+    (define (visit-scc scc sccs-by-label)
+      (let visit ((label scc) (sccs-by-label sccs-by-label))
+        (if (intmap-ref sccs-by-label label (lambda (_) #f))
+            sccs-by-label
+            (intset-fold visit
+                         (intmap-ref preds label)
+                         (intmap-add sccs-by-label label scc)))))
+    (intmap-fold
+     (lambda (label scc sccs)
+       (let ((labels (intset-add empty-intset label)))
+         (intmap-add sccs scc labels intset-union)))
+     (fold visit-scc empty-intmap (compute-reverse-post-order succs start))
+     empty-intmap)))
+
+(define (compute-sorted-strongly-connected-components edges)
+  "Given a LABEL->SUCCESSOR... graph, return a list of strongly
+connected components in sorted order."
+  (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 start
+    (if (eq? nodes empty-intset)
+        0
+        (1+ (intset-prev nodes))))
+  (define components
+    (intmap-remove
+     (compute-strongly-connected-components (intmap-add edges start nodes)
+                                            start)
+     start))
+  (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 start roots) start)
+    (((? (lambda (id) (eqv? id start))) . ids)
+     (map (lambda (id) (intmap-ref components id)) ids))))
+
+(define (intset-pop set)
+  (match (intset-next set)
+    (#f (values set #f))
+    (i (values (intset-remove set i) i))))
+
+(define* (solve-flow-equations succs in out kill gen subtract add meet
+                               #:optional (worklist (intmap-keys succs)))
+  "Find a fixed point for flow equations for SUCCS, where INIT is the
+initial state at each node in SUCCS.  KILL and GEN are intmaps
+indicating the state that is killed or defined at every node, and
+SUBTRACT, ADD, and MEET operates on that state."
+  (define (visit label in out)
+    (let* ((in-1 (intmap-ref in label))
+           (kill-1 (intmap-ref kill label))
+           (gen-1 (intmap-ref gen label))
+           (out-1 (intmap-ref out label))
+           (out-1* (add (subtract in-1 kill-1) gen-1)))
+      (if (eq? out-1 out-1*)
+          (values empty-intset in out)
+          (let ((out (intmap-replace! out label out-1*)))
+            (call-with-values
+                (lambda ()
+                  (intset-fold (lambda (succ in changed)
+                                 (let* ((in-1 (intmap-ref in succ))
+                                        (in-1* (meet in-1 out-1*)))
+                                   (if (eq? in-1 in-1*)
+                                       (values in changed)
+                                       (values (intmap-replace! in succ in-1*)
+                                               (intset-add changed succ)))))
+                               (intmap-ref succs label) in empty-intset))
+              (lambda (in changed)
+                (values changed in out)))))))
+
+  (let run ((worklist worklist) (in in) (out out))
+    (call-with-values (lambda () (intset-pop worklist))
+      (lambda (worklist popped)
+        (if popped
+            (call-with-values (lambda () (visit popped in out))
+              (lambda (changed in out)
+                (run (intset-union worklist changed) in out)))
+            (values (persistent-intmap in)
+                    (persistent-intmap out)))))))

module/language/cps/utils.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019 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
@@ -25,39 +25,38 @@
 (define-module (language cps utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (language cps)
   #:use-module (language cps intset)
   #:use-module (language cps intmap)
+  #:use-module (language cps graphs)
   #:export (;; Fresh names.
             label-counter var-counter
             fresh-label fresh-var
             with-fresh-name-state compute-max-label-and-var
             let-fresh
 
-            ;; Various utilities.
+            ;; Graphs.
-            fold1 fold2
-            trivial-intset
-            intmap-map
-            intmap-keys
-            invert-bijection invert-partition
-            intset->intmap
-            worklist-fold
-            fixpoint
-
-            ;; Flow analysis.
             compute-function-body
             compute-reachable-functions
             compute-successors
-            invert-graph
             compute-predecessors
-            compute-reverse-post-order
-            compute-strongly-connected-components
-            compute-sorted-strongly-connected-components
             compute-idoms
-            compute-dom-edges
+            compute-dom-edges)
-            solve-flow-equations
+  #:re-export (fold1 fold2
-            ))
+               trivial-intset
+               intmap-map
+               intmap-keys
+               invert-bijection invert-partition
+               intset->intmap
+               worklist-fold
+               fixpoint
+
+               ;; Flow analysis.
+               invert-graph
+               compute-reverse-post-order
+               compute-strongly-connected-components
+               compute-sorted-strongly-connected-components
+               solve-flow-equations))
 
 (define label-counter (make-parameter #f))
 (define var-counter (make-parameter #f))
@@ -98,87 +97,6 @@
                        conts
                        -1)))
 
-(define-inlinable (fold1 f l s0)
-  (let lp ((l l) (s0 s0))
-    (match l
-      (() s0)
-      ((elt . l) (lp l (f elt s0))))))
-
-(define-inlinable (fold2 f l s0 s1)
-  (let lp ((l l) (s0 s0) (s1 s1))
-    (match l
-      (() (values s0 s1))
-      ((elt . l)
-       (call-with-values (lambda () (f elt s0 s1))
-         (lambda (s0 s1)
-           (lp l s0 s1)))))))
-
-(define (trivial-intset set)
-  "Returns the sole member of @var{set}, if @var{set} has exactly one
-member, or @code{#f} otherwise."
-  (let ((first (intset-next set)))
-    (and first
-         (not (intset-next set (1+ first)))
-         first)))
-
-(define (intmap-map proc map)
-  (persistent-intmap
-   (intmap-fold (lambda (k v out) (intmap-add! out k (proc k v)))
-                map
-                empty-intmap)))
-
-(define (intmap-keys map)
-  "Return an intset of the keys in @var{map}."
-  (persistent-intset
-   (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
-
-(define (invert-bijection map)
-  "Assuming the values of @var{map} are integers and are unique, compute
-a map in which each value maps to its key.  If the values are not
-unique, an error will be signalled."
-  (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap))
-
-(define (invert-partition map)
-  "Assuming the values of @var{map} are disjoint intsets, compute a map
-in which each member of each set maps to its key.  If the values are not
-disjoint, an error will be signalled."
-  (intmap-fold (lambda (k v* out)
-                 (intset-fold (lambda (v out) (intmap-add out v k)) v* out))
-               map empty-intmap))
-
-(define (intset->intmap f set)
-  (persistent-intmap
-   (intset-fold (lambda (label preds)
-                  (intmap-add! preds label (f label)))
-                set empty-intmap)))
-
-(define worklist-fold
-  (case-lambda
-    ((f in out)
-     (let lp ((in in) (out out))
-       (if (eq? in empty-intset)
-           out
-           (call-with-values (lambda () (f in out)) lp))))
-    ((f in out0 out1)
-     (let lp ((in in) (out0 out0) (out1 out1))
-       (if (eq? in empty-intset)
-           (values out0 out1)
-           (call-with-values (lambda () (f in out0 out1)) lp))))))
-
-(define fixpoint
-  (case-lambda
-    ((f x)
-     (let lp ((x x))
-       (let ((x* (f x)))
-         (if (eq? x x*) x* (lp x*)))))
-    ((f x0 x1)
-     (let lp ((x0 x0) (x1 x1))
-       (call-with-values (lambda () (f x0 x1))
-         (lambda (x0* x1*)
-           (if (and (eq? x0 x0*) (eq? x1 x1*))
-               (values x0* x1*)
-               (lp x0* x1*))))))))
-
 (define (compute-function-body conts kfun)
   (persistent-intset
    (let visit-cont ((label kfun) (labels empty-intset))
@@ -306,104 +224,41 @@ intset."
    (intset-fold add-preds labels
                 (intset->intmap (lambda (label) '()) labels))))
 
-(define (compute-reverse-post-order succs start)
+;; Precondition: For each function in CONTS, the continuation names are
-  "Compute a reverse post-order numbering for a depth-first walk over
+;; topologically sorted.
-nodes reachable from the start node."
+(define (compute-idoms conts kfun)
-  (let visit ((label start) (order '()) (visited empty-intset))
+  ;; This is the iterative O(n^2) fixpoint algorithm, originally from
-    (call-with-values
+  ;; Allen and Cocke ("Graph-theoretic constructs for program flow
-        (lambda ()
+  ;; analysis", 1972).  See the discussion in Cooper, Harvey, and
-          (intset-fold (lambda (succ order visited)
+  ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
-                         (if (intset-ref visited succ)
+  (let ((preds-map (compute-predecessors conts kfun)))
-                             (values order visited)
+    (define (compute-idom idoms preds)
-                             (visit succ order visited)))
+      (define (idom-ref label)
-                       (intmap-ref succs label)
+        (intmap-ref idoms label (lambda (_) #f)))
-                       order
+      (match preds
-                       (intset-add! visited label)))
+        (() -1)
-      (lambda (order visited)
+        ((pred) pred)                   ; Shortcut.
-        ;; After visiting successors, add label to the reverse post-order.
+        ((pred . preds)
-        (values (cons label order) visited)))))
+         (define (common-idom d0 d1)
-
+           ;; We exploit the fact that a reverse post-order is a
-(define (invert-graph succs)
+           ;; topological sort, and so the idom of a node is always
-  "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an
+           ;; numerically less than the node itself.
-intset of successors, return a graph SUCC->PRED...."
+           (let lp ((d0 d0) (d1 d1))
-  (intmap-fold (lambda (pred succs preds)
+             (cond
-                 (intset-fold
+              ;; d0 or d1 can be false on the first iteration.
-                  (lambda (succ preds)
+              ((not d0) d1)
-                    (intmap-add preds succ pred intset-add))
+              ((not d1) d0)
-                  succs
+              ((= d0 d1) d0)
-                  preds))
+              ((< d0 d1) (lp d0 (idom-ref d1)))
-               succs
+              (else (lp (idom-ref d0) d1)))))
-               (intmap-map (lambda (label _) empty-intset) succs)))
+         (fold1 common-idom preds pred))))
-
+    (define (adjoin-idom label preds idoms)
-(define (compute-strongly-connected-components succs start)
+      (let ((idom (compute-idom idoms preds)))
-  "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
+        ;; Don't use intmap-add! here.
-partitioning the labels into strongly connected components (SCCs)."
+        (intmap-add idoms label idom (lambda (old new) new))))
-  (let ((preds (invert-graph succs)))
+    (fixpoint (lambda (idoms)
-    (define (visit-scc scc sccs-by-label)
+                (intmap-fold adjoin-idom preds-map idoms))
-      (let visit ((label scc) (sccs-by-label sccs-by-label))
+              empty-intmap)))
-        (if (intmap-ref sccs-by-label label (lambda (_) #f))
-            sccs-by-label
-            (intset-fold visit
-                         (intmap-ref preds label)
-                         (intmap-add sccs-by-label label scc)))))
-    (intmap-fold
-     (lambda (label scc sccs)
-       (let ((labels (intset-add empty-intset label)))
-         (intmap-add sccs scc labels intset-union)))
-     (fold visit-scc empty-intmap (compute-reverse-post-order succs start))
-     empty-intmap)))
-
-(define (compute-sorted-strongly-connected-components edges)
-  "Given a LABEL->SUCCESSOR... graph, return a list of strongly
-connected components in sorted order."
-  (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 start
-    (if (eq? nodes empty-intset)
-        0
-        (1+ (intset-prev nodes))))
-  (define components
-    (intmap-remove
-     (compute-strongly-connected-components (intmap-add edges start nodes)
-                                            start)
-     start))
-  (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 start roots) start)
-    (((? (lambda (id) (eqv? id start))) . ids)
-     (map (lambda (id) (intmap-ref components id)) ids))))
 
 ;; Precondition: For each function in CONTS, the continuation names are
 ;; topologically sorted.
@@ -454,45 +309,3 @@ connected components in sorted order."
                 idoms
                 empty-intmap)))
 
-(define (intset-pop set)
-  (match (intset-next set)
-    (#f (values set #f))
-    (i (values (intset-remove set i) i))))
-
-(define* (solve-flow-equations succs in out kill gen subtract add meet
-                               #:optional (worklist (intmap-keys succs)))
-  "Find a fixed point for flow equations for SUCCS, where INIT is the
-initial state at each node in SUCCS.  KILL and GEN are intmaps
-indicating the state that is killed or defined at every node, and
-SUBTRACT, ADD, and MEET operates on that state."
-  (define (visit label in out)
-    (let* ((in-1 (intmap-ref in label))
-           (kill-1 (intmap-ref kill label))
-           (gen-1 (intmap-ref gen label))
-           (out-1 (intmap-ref out label))
-           (out-1* (add (subtract in-1 kill-1) gen-1)))
-      (if (eq? out-1 out-1*)
-          (values empty-intset in out)
-          (let ((out (intmap-replace! out label out-1*)))
-            (call-with-values
-                (lambda ()
-                  (intset-fold (lambda (succ in changed)
-                                 (let* ((in-1 (intmap-ref in succ))
-                                        (in-1* (meet in-1 out-1*)))
-                                   (if (eq? in-1 in-1*)
-                                       (values in changed)
-                                       (values (intmap-replace! in succ in-1*)
-                                               (intset-add changed succ)))))
-                               (intmap-ref succs label) in empty-intset))
-              (lambda (in changed)
-                (values changed in out)))))))
-
-  (let run ((worklist worklist) (in in) (out out))
-    (call-with-values (lambda () (intset-pop worklist))
-      (lambda (worklist popped)
-        (if popped
-            (call-with-values (lambda () (visit popped in out))
-              (lambda (changed in out)
-                (run (intset-union worklist changed) in out)))
-            (values (persistent-intmap in)
-                    (persistent-intmap out)))))))