[Guile-commits] 05/10: compute-reachable-functions refactor

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 1b95487501e2c55bc63b3f71931993cdb52f9ec8
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 16 07:22:59 2015 +0200

    compute-reachable-functions refactor
    
    * module/language/cps2/utils.scm (compute-reachable-functions): New
      function.
    
    * module/language/cps2/verify.scm (check-label-partition)
      (compute-reachable-labels): Use the new function.
    
    * module/language/cps2/simplify.scm (compute-singly-referenced-vars):
      Allow $closure.
      (compute-eta-reductions, compute-beta-reductions): Use
      compute-reachable-functions, which besides being a simplification also
      allows simplification to work on first-order CPS.
---
 module/language/cps2/simplify.scm |   74 +++++++++++++++---------------------
 module/language/cps2/utils.scm    |   39 +++++++++++++++++++
 module/language/cps2/verify.scm   |   46 +++-------------------
 3 files changed, 77 insertions(+), 82 deletions(-)

diff --git a/module/language/cps2/simplify.scm 
b/module/language/cps2/simplify.scm
index 685327a..b87b044 100644
--- a/module/language/cps2/simplify.scm
+++ b/module/language/cps2/simplify.scm
@@ -74,7 +74,7 @@
     (match cont
       (($ $kargs _ _ ($ $continue _ _ exp))
        (match exp
-         ((or ($ $const) ($ $prim) ($ $fun) ($ $rec))
+         ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
           (values single multiple))
          (($ $call proc args)
           (ref* (cons proc args)))
@@ -118,30 +118,24 @@
         (() #t)
         ((var . vars)
          (and (intset-ref singly-used var) (singly-used? vars)))))
-    (define (visit-fun kfun nested-funs eta)
-      (let ((body (compute-function-body conts kfun)))
-        (define (visit-cont label nested-funs eta)
-          (match (intmap-ref conts label)
-            (($ $kargs names vars ($ $continue k src ($ $values vars)))
-             (values nested-funs
-                     (intset-maybe-add! eta label
-                                        (match (intmap-ref conts k)
-                                          (($ $kargs)
-                                           (and (not (eqv? label k)) ; A
-                                                (not (intset-ref eta label)) ; 
B
-                                                (singly-used? vars)))
-                                          (_ #f)))))
-            (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
-             (values (intset-add! nested-funs kfun) eta))
-            (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
-             (values (intset-add*! nested-funs kfun) eta))
-            (_
-             (values nested-funs eta))))
-        (intset-fold visit-cont body nested-funs eta)))
-    (define (visit-funs worklist eta)
-      (intset-fold visit-fun worklist empty-intset eta))
+    (define (visit-fun kfun body eta)
+      (define (visit-cont label eta)
+        (match (intmap-ref conts label)
+          (($ $kargs names vars ($ $continue k src ($ $values vars)))
+           (intset-maybe-add! eta label
+                              (match (intmap-ref conts k)
+                                (($ $kargs)
+                                 (and (not (eqv? label k)) ; A
+                                      (not (intset-ref eta label)) ; B
+                                      (singly-used? vars)))
+                                (_ #f))))
+          (_
+           eta)))
+      (intset-fold visit-cont body eta))
     (persistent-intset
-     (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))))
+     (intmap-fold visit-fun
+                  (compute-reachable-functions conts kfun)
+                  empty-intset))))
 
 (define (eta-reduce conts kfun)
   (let ((label-set (compute-eta-reductions conts kfun)))
@@ -197,32 +191,26 @@
                      (persistent-intset multiple))))
 
 (define (compute-beta-reductions conts kfun)
-  (define (visit-fun kfun nested-funs beta)
-    (let* ((body (compute-function-body conts kfun))
-           (single (compute-singly-referenced-labels conts body)))
-      (define (visit-cont label nested-funs beta)
+  (define (visit-fun kfun body beta)
+    (let ((single (compute-singly-referenced-labels conts body)))
+      (define (visit-cont label beta)
         (match (intmap-ref conts label)
           ;; A continuation's body can be inlined in place of a $values
           ;; expression if the continuation is a $kargs.  It should only
           ;; be inlined if it is used only once, and not recursively.
           (($ $kargs _ _ ($ $continue k src ($ $values)))
-           (values nested-funs
-                   (intset-maybe-add! beta label
-                                      (and (intset-ref single k)
-                                           (match (intmap-ref conts k)
-                                             (($ $kargs) #t)
-                                             (_ #f))))))
-          (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
-           (values (intset-add nested-funs kfun) beta))
-          (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
-           (values (intset-add* nested-funs kfun) beta))
+           (intset-maybe-add! beta label
+                              (and (intset-ref single k)
+                                   (match (intmap-ref conts k)
+                                     (($ $kargs) #t)
+                                     (_ #f)))))
           (_
-           (values nested-funs beta))))
-      (intset-fold visit-cont body nested-funs beta)))
-  (define (visit-funs worklist beta)
-    (intset-fold visit-fun worklist empty-intset beta))
+           beta)))
+      (intset-fold visit-cont body beta)))
   (persistent-intset
-   (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))
+   (intmap-fold visit-fun
+                (compute-reachable-functions conts kfun)
+                empty-intset)))
 
 (define (compute-beta-var-substitutions conts label-set)
   (define (add-var-substs label var-map)
diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
index e4ed473..d96b776 100644
--- a/module/language/cps2/utils.scm
+++ b/module/language/cps2/utils.scm
@@ -48,6 +48,7 @@
             ;; Flow analysis.
             compute-constant-values
             compute-function-body
+            compute-reachable-functions
             compute-successors
             invert-graph
             compute-predecessors
@@ -231,6 +232,44 @@ disjoint, an error will be signalled."
                              (visit-cont k labels))
                             (_ labels)))))))))))
 
+(define (compute-reachable-functions conts kfun)
+  "Compute a mapping LABEL->LABEL..., where each key is a reachable
+$kfun and each associated value is the body of the function, as an
+intset."
+  (define (intset-cons i set) (intset-add set i))
+  (define (visit-fun kfun body to-visit)
+    (intset-fold
+     (lambda (label to-visit)
+       (define (return kfun*) (fold intset-cons to-visit kfun*))
+       (define (return1 kfun) (intset-add to-visit kfun))
+       (define (return0) to-visit)
+       (match (intmap-ref conts label)
+         (($ $kargs _ _ ($ $continue _ _ exp))
+          (match exp
+            (($ $fun label) (return1 label))
+            (($ $rec _ _ (($ $fun labels) ...)) (return labels))
+            (($ $closure label nfree) (return1 label))
+            (($ $callk label) (return1 label))
+            (_ (return0))))
+         (_ (return0))))
+     body
+     to-visit))
+  (let lp ((to-visit (intset kfun)) (visited empty-intmap))
+    (let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
+      (if (eq? to-visit empty-intset)
+          visited
+          (call-with-values
+              (lambda ()
+                (intset-fold
+                 (lambda (kfun to-visit visited)
+                   (let ((body (compute-function-body conts kfun)))
+                     (values (visit-fun kfun body to-visit)
+                             (intmap-add visited kfun body))))
+                 to-visit
+                 empty-intset
+                 visited))
+            lp)))))
+
 (define (compute-successors conts kfun)
   (define (visit label succs)
     (let visit ((label kfun) (succs empty-intmap))
diff --git a/module/language/cps2/verify.scm b/module/language/cps2/verify.scm
index c833d0d..79b43f4 100644
--- a/module/language/cps2/verify.scm
+++ b/module/language/cps2/verify.scm
@@ -182,56 +182,24 @@ definitions that are available at LABEL."
      (compute-available-definitions conts kfun)
      first-order)))
 
-(define (reachable-functions conts kfun)
-  (worklist-fold*
-   (lambda (kfun kfuns)
-     ;(pk 'verify kfun kfuns)
-     (let ((kfuns (intset-add kfuns kfun)))
-       (values (intset-fold
-                (lambda (label nested)
-                  (define (return kfun*)
-                    ;(pk 'return label kfuns kfun* nested)
-                    (append (filter (lambda (kfun)
-                                      (not (intset-ref kfuns kfun)))
-                                    kfun*)
-                            nested))
-                  (define (return1 kfun) (return (list kfun)))
-                  (define (return0) (return '()))
-                  (match (intmap-ref conts label)
-                    (($ $kargs _ _ ($ $continue _ _ exp))
-                     (match exp
-                       (($ $fun label) (return1 label))
-                       (($ $rec _ _ (($ $fun labels) ...)) (return labels))
-                       (($ $closure label nfree) (return1 label))
-                       (($ $callk label) (return1 label))
-                       (_ (return0))))
-                    (_ (return0))))
-                (compute-function-body conts kfun)
-                '())
-               kfuns)))
-   (intset kfun)
-   empty-intset))
-
 (define (check-label-partition conts kfun)
   ;; A continuation can only belong to one function.
-  (intset-fold
-   (lambda (kfun seen)
+  (intmap-fold
+   (lambda (kfun body seen)
      (intset-fold
       (lambda (label seen)
         (intmap-add seen label kfun
                     (lambda (old new)
                       (error "label used by two functions" label old new))))
-      (compute-function-body conts kfun)
+      body
       seen))
-   (reachable-functions conts kfun)
+   (compute-reachable-functions conts kfun)
    empty-intmap))
 
 (define (compute-reachable-labels conts kfun)
-  (intset-fold
-   (lambda (kfun seen)
-     (intset-union seen (compute-function-body conts kfun)))
-   (reachable-functions conts kfun)
-   empty-intset))
+  (intmap-fold (lambda (kfun body seen) (intset-union seen body))
+               (compute-reachable-functions conts kfun)
+               empty-intset))
 
 (define (check-arities conts kfun)
   (define (check-arity exp cont)