Move live variable computation routines to utils and graphs.

* module/language/cps/graphs.scm (rename-keys, rename-intset)
(rename-graph, compute-reverse-control-flow-order)
(compute-live-variables): Move here from slot-allocation.
* module/language/cps/utils.scm: Remove duplicate compute-idoms
definition.
(compute-defs-and-uses, compute-var-representations): Move here from
slot-allocation.
* module/language/cps/slot-allocation.scm: Move routines out to utils
and graphs.

3 files changed, 225 insertions, 248 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)))))))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index ff32e1ae1..253776769 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -30,6 +30,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (language cps)
+  #:use-module (language cps graphs)
   #:use-module (language cps utils)
   #:use-module (language cps intmap)
   #:use-module (language cps intset)
@@ -121,94 +122,6 @@
 (define (lookup-nlocals allocation)
   (allocation-frame-size allocation))
 
-(define-syntax-rule (persistent-intmap2 exp)
-  (call-with-values (lambda () exp)
-    (lambda (a b)
-      (values (persistent-intmap a) (persistent-intmap b)))))
-
-(define (compute-defs-and-uses cps)
-  "Return two LABEL->VAR... maps indicating values defined at and used
-by a label, respectively."
-  (define (vars->intset vars)
-    (fold (lambda (var set) (intset-add set var)) empty-intset vars))
-  (persistent-intmap2
-   (intmap-fold
-    (lambda (label cont defs uses)
-      (define (get-defs k)
-        (match (intmap-ref cps k)
-          (($ $kargs names vars) (vars->intset vars))
-          (_ empty-intset)))
-      (define (return d u)
-        (values (intmap-add! defs label d)
-                (intmap-add! uses label u)))
-      (match cont
-        (($ $kfun src meta self tail clause)
-         (return (intset-union
-                  (if clause (get-defs clause) empty-intset)
-                  (if self (intset self) empty-intset))
-                 empty-intset))
-        (($ $kargs _ _ ($ $continue k src exp))
-         (match exp
-           ((or ($ $const) ($ $const-fun) ($ $code))
-            (return (get-defs k) empty-intset))
-           (($ $call proc args)
-            (return (get-defs k) (intset-add (vars->intset args) proc)))
-           (($ $callk _ proc args)
-            (let ((args (vars->intset args)))
-              (return (get-defs k) (if proc (intset-add args proc) args))))
-           (($ $primcall name param args)
-            (return (get-defs k) (vars->intset args)))
-           (($ $values args)
-            (return (get-defs k) (vars->intset args)))))
-        (($ $kargs _ _ ($ $branch kf kt src op param args))
-         (return empty-intset (vars->intset args)))
-        (($ $kargs _ _ ($ $switch kf kt* src arg))
-         (return empty-intset (intset arg)))
-        (($ $kargs _ _ ($ $prompt k kh src escape? tag))
-         (return empty-intset (intset tag)))
-        (($ $kargs _ _ ($ $throw src op param args))
-         (return empty-intset (vars->intset args)))
-        (($ $kclause arity body alt)
-         (return (get-defs body) empty-intset))
-        (($ $kreceive arity kargs)
-         (return (get-defs kargs) empty-intset))
-        (($ $ktail)
-         (return empty-intset empty-intset))))
-    cps
-    empty-intmap
-    empty-intmap)))
-
-(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* (add-prompt-control-flow-edges conts succs #:key complete?)
   "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
 LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
@@ -272,51 +185,6 @@ body continuation in the prompt."
    conts
    succs))
 
-(define (rename-keys map 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)
-  (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old)))
-               set empty-intset))
-
-(define (rename-graph graph 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-live-variables cps 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* ((succs (add-prompt-control-flow-edges cps (compute-successors cps)))
-         (preds (invert-graph succs))
-         (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)))))))
-
 (define (compute-needs-slot cps defs uses)
   (define (get-defs k) (intmap-ref defs k))
   (define (get-uses label) (intmap-ref uses label))
@@ -746,84 +614,14 @@ are comparable with eqv?.  A tmp slot may be used."
   (persistent-intmap
    (intmap-fold-right allocate-lazy cps slots)))
 
-(define (compute-var-representations cps)
-  (define (get-defs k)
-    (match (intmap-ref cps k)
-      (($ $kargs names vars) vars)
-      (_ '())))
-  (intmap-fold
-   (lambda (label cont representations)
-     (match cont
-       (($ $kargs _ _ ($ $continue k _ exp))
-        (match (get-defs k)
-          (() representations)
-          ((var)
-           (match exp
-             (($ $values (arg))
-              (intmap-add representations var
-                          (intmap-ref representations arg)))
-             (($ $primcall (or 'scm->f64 'load-f64 's64->f64
-                               'f32-ref 'f64-ref
-                               'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs
-                               'ffloor 'fceiling
-                               'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2))
-              (intmap-add representations var 'f64))
-             (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
-                               's64->u64
-                               'assume-u64
-                               'uadd 'usub 'umul
-                               'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
-                               'uadd/immediate 'usub/immediate 'umul/immediate
-                               'ursh/immediate 'ulsh/immediate
-                               'u8-ref 'u16-ref 'u32-ref 'u64-ref
-                               'word-ref 'word-ref/immediate
-                               'untag-char))
-              (intmap-add representations var 'u64))
-             (($ $primcall (or 'untag-fixnum
-                               'assume-s64
-                               'scm->s64 'load-s64 'u64->s64
-                               'srsh 'srsh/immediate
-                               's8-ref 's16-ref 's32-ref 's64-ref))
-              (intmap-add representations var 's64))
-             (($ $primcall (or 'pointer-ref/immediate
-                               'tail-pointer-ref/immediate))
-              (intmap-add representations var 'ptr))
-             (($ $code)
-              (intmap-add representations var 'u64))
-             (_
-              (intmap-add representations var 'scm))))
-          (vars
-           (match exp
-             (($ $values args)
-              (fold (lambda (arg var representations)
-                      (intmap-add representations var
-                                  (intmap-ref representations arg)))
-                    representations args vars))))))
-       (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
-        representations)
-       (($ $kfun src meta self tail entry)
-        (let ((representations (if self
-                                   (intmap-add representations self 'scm)
-                                   representations)))
-          (fold1 (lambda (var representations)
-                   (intmap-add representations var 'scm))
-                 (get-defs entry) representations)))
-       (($ $kclause arity body alt)
-        (fold1 (lambda (var representations)
-                 (intmap-add representations var 'scm))
-               (get-defs body) representations))
-       (($ $kreceive arity kargs)
-        (fold1 (lambda (var representations)
-                 (intmap-add representations var 'scm))
-               (get-defs kargs) representations))
-       (($ $ktail) representations)))
-   cps
-   empty-intmap))
-
 (define* (allocate-slots cps #:key (precolor-calls? #t))
   (let*-values (((defs uses) (compute-defs-and-uses cps))
                 ((representations) (compute-var-representations cps))
-                ((live-in live-out) (compute-live-variables cps defs uses))
+                ((live-in live-out)
+                 (let* ((succs (compute-successors cps))
+                        (succs+ (add-prompt-control-flow-edges cps succs))
+                        (preds (invert-graph succs+)))
+                   (compute-live-variables preds defs uses)))
                 ((needs-slot) (compute-needs-slot cps defs uses))
                 ((lazy) (if precolor-calls?
                             (compute-lazy-vars cps live-in live-out defs
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index c72c04434..8f36e4d53 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 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
@@ -43,7 +43,9 @@
             compute-successors
             compute-predecessors
             compute-idoms
-            compute-dom-edges)
+            compute-dom-edges
+            compute-defs-and-uses
+            compute-var-representations)
   #:re-export (fold1 fold2
                trivial-intset
                intmap-map
@@ -302,42 +304,6 @@ intset."
                 (intmap-fold adjoin-idom preds-map idoms))
               empty-intmap)))
 
-;; Precondition: For each function in CONTS, the continuation names are
-;; topologically sorted.
-(define (compute-idoms conts kfun)
-  ;; This is the iterative O(n^2) fixpoint algorithm, originally from
-  ;; Allen and Cocke ("Graph-theoretic constructs for program flow
-  ;; analysis", 1972).  See the discussion in Cooper, Harvey, and
-  ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
-  (let ((preds-map (compute-predecessors conts kfun)))
-    (define (compute-idom idoms preds)
-      (define (idom-ref label)
-        (intmap-ref idoms label (lambda (_) #f)))
-      (match preds
-        (() -1)
-        ((pred) pred)                   ; Shortcut.
-        ((pred . preds)
-         (define (common-idom d0 d1)
-           ;; We exploit the fact that a reverse post-order is a
-           ;; topological sort, and so the idom of a node is always
-           ;; numerically less than the node itself.
-           (let lp ((d0 d0) (d1 d1))
-             (cond
-              ;; d0 or d1 can be false on the first iteration.
-              ((not d0) d1)
-              ((not d1) d0)
-              ((= d0 d1) d0)
-              ((< d0 d1) (lp d0 (idom-ref d1)))
-              (else (lp (idom-ref d0) d1)))))
-         (fold1 common-idom preds pred))))
-    (define (adjoin-idom label preds idoms)
-      (let ((idom (compute-idom idoms preds)))
-        ;; Don't use intmap-add! here.
-        (intmap-add idoms label idom (lambda (old new) new))))
-    (fixpoint (lambda (idoms)
-                (intmap-fold adjoin-idom preds-map idoms))
-              empty-intmap)))
-
 ;; Compute a vector containing, for each node, a list of the nodes that
 ;; it immediately dominates.  These are the "D" edges in the DJ tree.
 (define (compute-dom-edges idoms)
@@ -351,3 +317,132 @@ intset."
                 idoms
                 empty-intmap)))
 
+(define (compute-defs-and-uses cps)
+  "Return two LABEL->VAR... maps indicating values defined at and used
+by a label, respectively."
+  (define (vars->intset vars)
+    (fold (lambda (var set) (intset-add set var)) empty-intset vars))
+  (define-syntax-rule (persistent-intmap2 exp)
+    (call-with-values (lambda () exp)
+      (lambda (a b)
+        (values (persistent-intmap a) (persistent-intmap b)))))
+  (persistent-intmap2
+   (intmap-fold
+    (lambda (label cont defs uses)
+      (define (get-defs k)
+        (match (intmap-ref cps k)
+          (($ $kargs names vars) (vars->intset vars))
+          (_ empty-intset)))
+      (define (return d u)
+        (values (intmap-add! defs label d)
+                (intmap-add! uses label u)))
+      (match cont
+        (($ $kfun src meta self tail clause)
+         (return (intset-union
+                  (if clause (get-defs clause) empty-intset)
+                  (if self (intset self) empty-intset))
+                 empty-intset))
+        (($ $kargs _ _ ($ $continue k src exp))
+         (match exp
+           ((or ($ $const) ($ $const-fun) ($ $code))
+            (return (get-defs k) empty-intset))
+           (($ $call proc args)
+            (return (get-defs k) (intset-add (vars->intset args) proc)))
+           (($ $callk _ proc args)
+            (let ((args (vars->intset args)))
+              (return (get-defs k) (if proc (intset-add args proc) args))))
+           (($ $primcall name param args)
+            (return (get-defs k) (vars->intset args)))
+           (($ $values args)
+            (return (get-defs k) (vars->intset args)))))
+        (($ $kargs _ _ ($ $branch kf kt src op param args))
+         (return empty-intset (vars->intset args)))
+        (($ $kargs _ _ ($ $switch kf kt* src arg))
+         (return empty-intset (intset arg)))
+        (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+         (return empty-intset (intset tag)))
+        (($ $kargs _ _ ($ $throw src op param args))
+         (return empty-intset (vars->intset args)))
+        (($ $kclause arity body alt)
+         (return (get-defs body) empty-intset))
+        (($ $kreceive arity kargs)
+         (return (get-defs kargs) empty-intset))
+        (($ $ktail)
+         (return empty-intset empty-intset))))
+    cps
+    empty-intmap
+    empty-intmap)))
+
+(define (compute-var-representations cps)
+  (define (get-defs k)
+    (match (intmap-ref cps k)
+      (($ $kargs names vars) vars)
+      (_ '())))
+  (intmap-fold
+   (lambda (label cont representations)
+     (match cont
+       (($ $kargs _ _ ($ $continue k _ exp))
+        (match (get-defs k)
+          (() representations)
+          ((var)
+           (match exp
+             (($ $values (arg))
+              (intmap-add representations var
+                          (intmap-ref representations arg)))
+             (($ $primcall (or 'scm->f64 'load-f64 's64->f64
+                               'f32-ref 'f64-ref
+                               'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs
+                               'ffloor 'fceiling
+                               'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2))
+              (intmap-add representations var 'f64))
+             (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
+                               's64->u64
+                               'assume-u64
+                               'uadd 'usub 'umul
+                               'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
+                               'uadd/immediate 'usub/immediate 'umul/immediate
+                               'ursh/immediate 'ulsh/immediate
+                               'u8-ref 'u16-ref 'u32-ref 'u64-ref
+                               'word-ref 'word-ref/immediate
+                               'untag-char))
+              (intmap-add representations var 'u64))
+             (($ $primcall (or 'untag-fixnum
+                               'assume-s64
+                               'scm->s64 'load-s64 'u64->s64
+                               'srsh 'srsh/immediate
+                               's8-ref 's16-ref 's32-ref 's64-ref))
+              (intmap-add representations var 's64))
+             (($ $primcall (or 'pointer-ref/immediate
+                               'tail-pointer-ref/immediate))
+              (intmap-add representations var 'ptr))
+             (($ $code)
+              (intmap-add representations var 'u64))
+             (_
+              (intmap-add representations var 'scm))))
+          (vars
+           (match exp
+             (($ $values args)
+              (fold (lambda (arg var representations)
+                      (intmap-add representations var
+                                  (intmap-ref representations arg)))
+                    representations args vars))))))
+       (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
+        representations)
+       (($ $kfun src meta self tail entry)
+        (let ((representations (if self
+                                   (intmap-add representations self 'scm)
+                                   representations)))
+          (fold1 (lambda (var representations)
+                   (intmap-add representations var 'scm))
+                 (get-defs entry) representations)))
+       (($ $kclause arity body alt)
+        (fold1 (lambda (var representations)
+                 (intmap-add representations var 'scm))
+               (get-defs body) representations))
+       (($ $kreceive arity kargs)
+        (fold1 (lambda (var representations)
+                 (intmap-add representations var 'scm))
+               (get-defs kargs) representations))
+       (($ $ktail) representations)))
+   cps
+   empty-intmap))