[Guile-commits] 01/02: Fix tailify bugs

[Andy Wingo]

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

commit 9b3424acbf193b2fc62b6231d57a54e8411c65b2
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jun 17 22:23:55 2021 +0200

    Fix tailify bugs
---
 module/language/cps/tailify.scm | 15 ++++++++-------
 1 file changed, 8 insertions(+), 7 deletions(-)

diff --git a/module/language/cps/tailify.scm b/module/language/cps/tailify.scm
index b5a7477..66dc24c 100644
--- a/module/language/cps/tailify.scm
+++ b/module/language/cps/tailify.scm
@@ -91,7 +91,7 @@
 
 (define (live-constants live-in constants head)
   (intmap-select constants
-                 (intmap-intersect (intmap-ref live-in head)
+                 (intset-intersect (intmap-ref live-in head)
                                    (intmap-keys constants))))
 (define (live-vars live-in constants head)
   (intset-subtract (intmap-ref live-in head)
@@ -108,8 +108,8 @@
 
 (define (compute-saved-vars* fresh-names live-in constants reprs k)
   (intset-fold-right
-   (lambda (var reprs vars)
-     (values (cons (intmap-ref reprs var) reprs)
+   (lambda (var reprs* vars)
+     (values (cons (intmap-ref reprs var) reprs*)
              (cons (rename-var* fresh-names var) vars)))
    (live-vars live-in constants k) '() '()))
 
@@ -253,7 +253,7 @@ be rewritten to continue to the tail's ktail."
       (($ $branch kf kt src op param args)
        (with-cps cps
          (let$ kf (rewrite-branch-target src kf))
-         (let$ kt (rewrite-branch-target src kf))
+         (let$ kt (rewrite-branch-target src kt))
          (build-term
            ($branch kf kt src op param ,(rename-vars args)))))
       (($ $switch kf kt* src arg)
@@ -404,14 +404,14 @@ REPRS holds the representation of each var."
               (let$ term (restore-saved term))
               (letk krestore ($kargs names vars' ,term))
               (letk kclause ($kclause (req '() rest '() #f) krestore #f))
-              (letk kfun ($kfun src #f #f ktail kclause))
+              (letk kfun ($kfun src '() #f ktail kclause))
               (intmap-add entries head kfun))))))
       (($ $kargs names vars term)
        ;; A join point.
        (call-with-values (lambda () (compute-saved-vars head))
          (lambda (reprs vars')
            (define names'
-             (let ((names (map acons vars names)))
+             (let ((names (map cons vars names)))
                (map (lambda (var) (assq-ref names var))
                     vars')))
            (define meta `((arg-representations . ,reprs)))
@@ -606,7 +606,8 @@ to tail-call the saved continuation."
                        ($continue k src ($calli args ret))))
          (setk label ($kargs names vars
                        ($continue kcall src
-                         ($primcall 'restore1 'ptr ()))))))))
+                         ($primcall 'restore1 'ptr ()))))))
+      (_ cps)))
   (intset-fold rewrite-return-to-pop-and-calli body cps))
 
 (define (tailify-function kfun body cps)