[Guile-commits] 02/02: More tailify bugsquashing

[Andy Wingo]

wingo pushed a commit to branch wip-tailify
in repository guile.

commit 525a69a063b12e53c59703ad1bc660cc03b21e68
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sat Jun 19 15:32:38 2021 +0200

    More tailify bugsquashing
---
 module/language/cps/tailify.scm | 149 +++++++++++++++++++++++++---------------
 1 file changed, 92 insertions(+), 57 deletions(-)

diff --git a/module/language/cps/tailify.scm b/module/language/cps/tailify.scm
index 66dc24c..f9ebb63 100644
--- a/module/language/cps/tailify.scm
+++ b/module/language/cps/tailify.scm
@@ -74,6 +74,7 @@
 
 (define-module (language cps tailify)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (ice-9 match)
   #:use-module (language cps)
   #:use-module (language cps intmap)
@@ -129,23 +130,26 @@ be rewritten to continue to the tail's ktail."
   ;; HEAD will have been given a corresponding entry $kfun by
   ;; tailify-tails.  Here we find the tail-label for the current tail.
   (define local-ktail
-    (match (intmap-ref cps (intmap-ref entries head))
+    (match (intmap-ref cps head)
       (($ $kfun src meta self ktail kentry)
        ktail)))
 
+  (pk 'tailify-tail head body fresh-names original-ktail local-ktail)
+
   (define (rename-var var)   (rename-var* fresh-names var))
   (define (rename-vars vars) (rename-vars* fresh-names vars))
   (define (rename-exp exp)
-    (rewrite-exp exp
-      ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code)) ,exp)
-      (($ $call proc args)
-       ($call (rename-var proc) ,(rename-vars args)))
-      (($ $callk k proc args)
-       ($callk k (and proc (rename-var proc)) ,(rename-vars args)))
-      (($ $primcall name param args)
-       ($primcall name param ,(rename-vars args)))
-      (($ $values args)
-       ($values ,(rename-vars args)))))
+    (pk 'rename exp
+     (rewrite-exp exp
+       ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code)) ,exp)
+       (($ $call proc args)
+        ($call (rename-var proc) ,(rename-vars args)))
+       (($ $callk k proc args)
+        ($callk k (and proc (rename-var proc)) ,(rename-vars args)))
+       (($ $primcall name param args)
+        ($primcall name param ,(rename-vars args)))
+       (($ $values args)
+        ($values ,(rename-vars args))))))
 
   (define (compute-saved-vars fresh-names k)
     (compute-saved-vars* fresh-names live-in constants reprs k))
@@ -197,6 +201,7 @@ be rewritten to continue to the tail's ktail."
        (let ((exp (rename-exp exp)))
          (cond
           ((eqv? k original-ktail)
+           (pk 'original-tail-call k exp)
            (match exp
              (($ $values args)
               ;; The original term is a $values in tail position.
@@ -222,11 +227,13 @@ be rewritten to continue to the tail's ktail."
              (($ $kreceive)
               ;; A non-tail-call: push the pending continuation and tail
               ;; call instead.
+              (pk 'non-tail-call head k exp)
               (match exp
                 ((or ($ $call) ($ $callk) ($ $calli))
                  (call-with-values (lambda ()
                                      (compute-saved-vars fresh-names k))
                    (lambda (reprs vars)
+                     (pk 'saved-vars reprs vars)
                      (with-cps cps
                        (letk kexp ($kargs () ()
                                     ($continue local-ktail src ,exp)))
@@ -307,14 +314,13 @@ be rewritten to continue to the tail's ktail."
   ;; we just rewrite all the body conts.
   (intset-fold
    (lambda (label cps)
-     (match (intmap-ref cps label)
+     (match (pk 'tailify-tail1 head label (intmap-ref cps label))
        ((or ($ $kfun) ($ $kclause) ($ $ktail)) cps) ;; Unchanged.
-       (($ $kreceive) cps)                          ;; Dead.
        (($ $kargs names vals term)
         (with-cps cps
           (let$ term (rewrite-term term))
           (let$ term (maybe-unwind-prompt label term))
-          (setk label ($kargs names vals ,term))))))
+          (setk label ($kargs names vals ,(pk 'setting label term)))))))
    body cps))
 
 (define (tailify-tails cps winds live-in constants reprs tails)
@@ -348,7 +354,8 @@ REPRS holds the representation of each var."
   (define fresh-names-per-tail
     (intmap-map (lambda (head body)
                   (intset-fold (lambda (var fresh)
-                                 (intmap-add fresh var (fresh-var)))
+                                 (intmap-add fresh var (pk 'live-in head var
+                                                           (fresh-var))))
                                (intmap-ref live-in head)
                                empty-intmap))
                 tails))
@@ -364,48 +371,61 @@ REPRS holds the representation of each var."
   ;; the live vars are restored from the stack.  In all cases, adjoin a
   ;; HEAD->ENTRY mapping to ENTRIES, where ENTRY is the $kfun label for
   ;; the tail.
-  (define (add-entry head cps entries)
+  (define (add-entry head body cps entries tails)
     (define fresh-names (intmap-ref fresh-names-per-tail head))
     ;; Constants don't need to be passed from tail to tail; rather they
     ;; are rebound locally.
-    (define (restore-constants cps term)
-      (intmap-fold (lambda (var exp cps term)
+    (define (restore-constants cps body term)
+      (intmap-fold (lambda (var exp cps body term)
                      (define var' (intmap-ref fresh-names var))
                      (with-cps cps
                        (letk k ($kargs ('const) (var') ,term))
-                       (build-term ($continue k #f ,exp))))
+                       ($ (values (intset-add body k)
+                                  (build-term ($continue k #f ,exp))))))
                    (live-constants live-in constants head)
-                   cps term))
-    (define (restore-saved cps term)
+                   cps body term))
+    (define (restore-saved cps body term)
       (call-with-values (lambda () (compute-saved-vars head))
         (lambda (reprs vars)
+          (pk 'restoring head reprs vars)
           (define names (map (lambda (_) 'restored) vars))
           (if (null? names)
-              (with-cps cps term)
+              (with-cps cps ($ (values body term)))
               (with-cps cps
                 (letk krestore ($kargs names vars ,term))
-                (build-term ($continue krestore #f
-                              ($primcall 'restore reprs ()))))))))
+                ($ (values (intset-add body krestore)
+                           (build-term ($continue krestore #f
+                                         ($primcall 'restore reprs ()))))))))))
     (match (intmap-ref cps head)
       (($ $kfun)
        ;; The main entry.
-       (values cps (intmap-add entries head head)))
+       (values cps (intmap-add entries head head) tails))
       (($ $kreceive ($ $arity req () rest () #f) kargs)
        ;; The continuation of a non-tail call, or a prompt handler.
        (match (intmap-ref cps kargs)
          (($ $kargs names vars)
           (let ((vars' (map (lambda (_) (fresh-var)) vars))
                 (src (cont-source kargs)))
-            (with-cps cps
-              (letk ktail ($ktail))
-              (let$ term (restore-constants
-                          (build-term
-                            ($continue kargs src ($values vars')))))
-              (let$ term (restore-saved term))
-              (letk krestore ($kargs names vars' ,term))
-              (letk kclause ($kclause (req '() rest '() #f) krestore #f))
-              (letk kfun ($kfun src '() #f ktail kclause))
-              (intmap-add entries head kfun))))))
+            (let*-values (((cps body term)
+                           (restore-constants
+                            cps
+                            body
+                            (build-term
+                              ($continue kargs src ($values vars')))))
+                          ((cps body term) (restore-saved cps body term)))
+              (with-cps cps
+                (letk ktail ($ktail))
+                (letk krestore ($kargs names vars' ,term))
+                (letk kclause ($kclause (req '() rest '() #f) krestore #f))
+                (letk kfun ($kfun src '() #f ktail kclause))
+                ($ (values
+                    (intmap-add entries head kfun)
+                    (let ((added (intset kfun kclause krestore ktail))
+                          (removed (intset head)))
+                      (intmap-add (intmap-remove tails head)
+                                  kfun
+                                  (intset-subtract (intset-union body added)
+                                                   removed)))))))))))
       (($ $kargs names vars term)
        ;; A join point.
        (call-with-values (lambda () (compute-saved-vars head))
@@ -415,28 +435,37 @@ REPRS holds the representation of each var."
                (map (lambda (var) (assq-ref names var))
                     vars')))
            (define meta `((arg-representations . ,reprs)))
-           (with-cps cps
-             (letk ktail ($ktail))
-             (let$ term (restore-constants term))
-             (letk kargs ($kargs names' vars' ,term))
-             (letk kfun ($kfun (cont-source head) meta #f ktail kargs))
-             (intmap-add entries head kfun)))))))
+           (let*-values (((cps body term)
+                          (restore-constants cps body term)))
+             (with-cps cps
+               (letk ktail ($ktail))
+               (letk kargs ($kargs names' vars' ,term))
+               (letk kfun ($kfun (cont-source head) meta #f ktail kargs))
+               ($ (values
+                   (intmap-add entries head kfun)
+                   (let ((added (intset kfun kargs ktail))
+                         (removed (intset head)))
+                     (intmap-add (intmap-remove tails head)
+                                 kfun
+                                 (intset-subtract (intset-union body added)
+                                                  removed))))))))))))
 
   (define original-ktail
     (match (intmap-ref cps (intmap-next tails))
       (($ $kfun src meta self ktail kentry)
        ktail)))
   (call-with-values (lambda ()
-                      (intmap-fold (lambda (head body cps entries)
-                                     (add-entry head cps entries))
-                                   tails cps empty-intmap))
-    (lambda (cps entries)
+                      (intmap-fold (lambda (head body cps entries tails)
+                                     (add-entry head body cps entries tails))
+                                   tails cps empty-intmap tails))
+    (lambda (cps entries tails)
       (intmap-fold
-       (lambda (head body cps)
-         (define fresh-names (intmap-ref fresh-names-per-tail head))
+       (lambda (old-head head cps)
+         (define fresh-names (intmap-ref fresh-names-per-tail old-head))
+         (define body (intmap-ref tails head))
          (tailify-tail cps head body fresh-names winds live-in constants
                        reprs entries original-ktail))
-       tails cps))))
+       entries cps))))
 
 (define (compute-tails kfun body preds cps)
   "Compute the set of tails in the function with entry KFUN and body
@@ -469,21 +498,22 @@ body, as an intset."
      (else
       (match (intset-fold
               (lambda (pred pred-splits)
-                (define pred-split
+                (define split
                   (intmap-ref splits pred (lambda (_) #f)))
-                (match pred-split
-                  (#f pred-splits)
-                  (split (cons split pred-splits))))
+                (if (and split (not (memv split pred-splits)))
+                    (cons split pred-splits)
+                    pred-splits))
               (intmap-ref preds label) '())
         ((split)
          ;; If all predecessors in same split, label is too.
          (intmap-add splits label split (lambda (old new) new)))
         ((_ _ . _)
          ;; Otherwise this is a new split.
+         (pk 'join-split label)
          (intmap-add splits label label (lambda (old new) new)))))))
   ;; label -> split head
   (define initial-splits
-    (intset-fold initial-split body empty-intmap))
+    (pk (intset-fold initial-split body empty-intmap)))
   (cond
    ((trivial-intmap initial-splits)
     ;; There's only one split head, so only one tail.
@@ -493,6 +523,7 @@ body, as an intset."
     ;; head, then collect the tails by split head.
     (let ((splits (fixpoint
                    (lambda (splits)
+                     (pk 'fixpoint splits)
                      (intset-fold compute-split body splits))
                    initial-splits)))
       (intmap-fold
@@ -616,7 +647,7 @@ tails in such a way that they enter via a $kfun and leave 
only via tail
 calls."
   (define succs (compute-successors cps kfun))
   (define preds (invert-graph succs))
-  (define tails (compute-tails kfun body preds cps))
+  (define tails (pk 'tails (compute-tails kfun body preds cps)))
   (cond
    ((trivial-intmap tails)
     (tailify-trivial-tail body cps))
@@ -628,10 +659,14 @@ calls."
           (reprs (compute-var-representations cps)))
       (tailify-tails cps winds live-in constants reprs tails)))))
 
+(define (dump* map)
+  (intmap-fold (lambda (label cont) (pk label cont) (values)) map)
+  map)
+
 (define (tailify cps)
   ;; Renumber so that label order is topological order.
   (let ((cps (renumber cps)))
     (with-fresh-name-state cps
-      (intmap-fold tailify-function
-                   (compute-reachable-functions cps)
-                   cps))))
+      (dump* (intmap-fold tailify-function
+                          (compute-reachable-functions cps)
+                          cps)))))