From 0912202a51d8312c103fc0a43c29a8fdbaf7de00 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 1 Apr 2014 18:16:00 +0200
Subject: [PATCH] Fix compute-label-and-var-ranges for global DFG computation

* module/language/cps/dfg.scm (compute-label-and-var-ranges): Fix to
  work with global DFGs -- it wasn't taking $letrec into account for var
  ranges.

* module/language/cps/dce.scm (compute-live-code): Use bitvectors to
  represent the live var set.
---
 module/language/cps/dce.scm | 18 ++++++++++--------
 module/language/cps/dfg.scm | 32 +++++++++++++++++++++++++-------
 2 files changed, 35 insertions(+), 15 deletions(-)

diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index da19b9318..eae551aab 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -79,15 +79,15 @@
 
 (define (compute-live-code fun)
   (let* ((fun-data-table (make-hash-table))
-         (live-vars (make-hash-table))
          (dfg (compute-dfg fun #:global? #t))
+         (live-vars (make-bitvector (dfg-var-count dfg) #f))
          (changed? #f))
-    (define (mark-live! sym)
-      (unless (value-live? sym)
+    (define (mark-live! var)
+      (unless (value-live? var)
         (set! changed? #t)
-        (hashq-set! live-vars sym #t)))
-    (define (value-live? sym)
-      (hashq-ref live-vars sym))
+        (bitvector-set! live-vars var #t)))
+    (define (value-live? var)
+      (bitvector-ref live-vars var))
     (define (ensure-fun-data fun)
       (or (hashq-ref fun-data-table fun)
           (call-with-values (lambda ()
@@ -168,6 +168,8 @@
                   (mark-live! self))
                  (($ $ktail) #f))
                (lp (1- n))))))))
+    (unless (= (dfg-var-count dfg) (var-counter))
+      (error "internal error" (dfg-var-count dfg) (var-counter)))
     (let lp ()
       (set! changed? #f)
       (visit-fun fun)
@@ -175,8 +177,8 @@
     (values fun-data-table live-vars)))
 
 (define (process-eliminations fun fun-data-table live-vars)
-  (define (value-live? sym)
-    (hashq-ref live-vars sym))
+  (define (value-live? var)
+    (bitvector-ref live-vars var))
   (define (make-adaptor name k defs)
     (let* ((names (map (lambda (_) 'tmp) defs))
            (syms (map (lambda (_) (fresh-var)) defs))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 08086a87e..89922ab5e 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -889,14 +889,32 @@ BODY for each body continuation in the prompt."
                   min-var max-var var-count)
      (let ((min-label (min* label min-label))
            (max-label (max label max-label)))
+       (define (visit-letrec body min-var max-var var-count)
+         (match body
+           (($ $letk conts body)
+            (visit-letrec body min-var max-var var-count))
+           (($ $letrec names vars funs body)
+            (visit-letrec body
+                          (cond (min-var (fold min min-var vars))
+                                ((pair? vars) (fold min (car vars) (cdr vars)))
+                                (else min-var))
+                          (fold max max-var vars)
+                          (+ var-count (length vars))))
+           (($ $continue) (values min-var max-var var-count))))
        (match cont
-         (($ $kargs names vars)
-          (values min-label max-label (1+ label-count)
-                  (cond (min-var (fold min min-var vars))
-                        ((pair? vars) (fold min (car vars) (cdr vars)))
-                        (else min-var))
-                  (fold max max-var vars)
-                  (+ var-count (length vars))))
+         (($ $kargs names vars body)
+          (call-with-values
+              (lambda ()
+                (if global?
+                    (visit-letrec body min-var max-var var-count)
+                    (values min-var max-var var-count)))
+            (lambda (min-var max-var var-count)
+              (values min-label max-label (1+ label-count)
+                      (cond (min-var (fold min min-var vars))
+                            ((pair? vars) (fold min (car vars) (cdr vars)))
+                            (else min-var))
+                      (fold max max-var vars)
+                      (+ var-count (length vars))))))
          (($ $kentry self)
           (values min-label max-label (1+ label-count)
                   (min* self min-var) (max self max-var) (1+ var-count)))