From cc569cce64351b4c417bead188b9948a18d8010d Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sat, 4 Jul 2009 19:47:15 +0300
Subject: [PATCH] letrec optimization moved into its own file.

---
 scheme/Makefile.am                        |   4 +-
 scheme/Makefile.in                        |   4 +-
 scheme/ikarus.compiler.optimize-letrec.ss | 261 ++++++++++++++++++++++
 scheme/ikarus.compiler.ss                 | 260 +--------------------
 scheme/last-revision                      |   2 +-
 5 files changed, 272 insertions(+), 259 deletions(-)
 create mode 100644 scheme/ikarus.compiler.optimize-letrec.ss

diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index d33a86e..373f4a2 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -7,7 +7,9 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
   ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss \
   ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss \
   ikarus.compiler.altcogen.ss ikarus.compiler.ss \
-  ikarus.compiler.source-optimizer.ss ikarus.control.ss \
+  ikarus.compiler.source-optimizer.ss \
+  ikarus.compiler.optimize-letrec.ss \
+  ikarus.control.ss \
   ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss \
   ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss \
   ikarus.hash-tables.ss ikarus.intel-assembler.ss \
diff --git a/scheme/Makefile.in b/scheme/Makefile.in
index e23ec08..e707427 100644
--- a/scheme/Makefile.in
+++ b/scheme/Makefile.in
@@ -162,7 +162,9 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt last-revision \
   ikarus.cafe.ss ikarus.chars.ss ikarus.code-objects.ss \
   ikarus.codecs.ss ikarus.collect.ss ikarus.command-line.ss \
   ikarus.compiler.altcogen.ss ikarus.compiler.ss \
-  ikarus.compiler.source-optimizer.ss ikarus.control.ss \
+  ikarus.compiler.source-optimizer.ss \
+  ikarus.compiler.optimize-letrec.ss \
+  ikarus.control.ss \
   ikarus.date-string.ss ikarus.fasl.ss ikarus.fasl.write.ss \
   ikarus.fixnums.ss ikarus.guardians.ss ikarus.handlers.ss \
   ikarus.hash-tables.ss ikarus.intel-assembler.ss \
diff --git a/scheme/ikarus.compiler.optimize-letrec.ss b/scheme/ikarus.compiler.optimize-letrec.ss
new file mode 100644
index 0000000..aa6be2c
--- /dev/null
+++ b/scheme/ikarus.compiler.optimize-letrec.ss
@@ -0,0 +1,261 @@
+
+
+(module (debug-scc optimize-letrec)
+
+(define (optimize-letrec/scc x)
+  (define who 'optimize-letrec/scc)
+  (module (get-sccs-in-order)
+    (define-struct node (data link* lowlink root done collection))
+    (define (create-graph v* e** data*)
+      (define h (make-eq-hashtable))
+      (let ([v*
+             (let f ([v* v*] [data* data*])
+               (cond
+                 [(null? v*) '()]
+                 [else
+                  (let ([node (make-node (car data*) '() #f #f #f #f)])
+                    (hashtable-set! h (car v*) node) 
+                    (cons node (f (cdr v*) (cdr data*))))]))])
+        (for-each
+          (lambda (v e*)
+            (set-node-link*! v
+              (map (lambda (f) 
+                     (or (hashtable-ref h f #f)
+                         (error who "invalid node" f)))
+                   e*)))
+          v* e**)
+        v*))
+    (define (compute-sccs v*) ; Tarjan's algorithm
+      (define scc* '())
+      (define (compute-sccs v)
+        (define index 0)
+        (define stack '())
+        (define (tarjan v)
+          (let ([v-index index])
+            (set-node-root! v v-index)
+            (set! stack (cons v stack))
+            (set! index (fx+ index 1))
+            (for-each
+              (lambda (v^)
+                (unless (node-done v^)
+                  (unless (node-root v^) (tarjan v^))
+                  (set-node-root! v (fxmin (node-root v) (node-root v^)))))
+              (node-link* v))
+            (when (fx= (node-root v) v-index)
+              (set! scc*
+                (cons
+                  (let f ([ls stack])
+                    (let ([v^ (car ls)])
+                      (set-node-done! v^ #t)
+                      (cons v^ (if (eq? v^ v)
+                                   (begin (set! stack (cdr ls)) '())
+                                   (f (cdr ls))))))
+                  scc*)))))
+        (tarjan v))
+      (for-each (lambda (v) (unless (node-done v) (compute-sccs v))) v*)
+      (reverse scc*))
+    (define (get-sccs-in-order n* e** data*)
+      (let ([G (create-graph n* e** data*)])
+        (let ([sccs (compute-sccs G)])
+          (map (lambda (scc) (map node-data scc)) sccs)))))
+  (define (gen-letrecs scc* ordered? body) 
+    (define (mkfix b* body)
+      (if (null? b*) 
+          body
+          (make-fix (map binding-lhs b*) 
+                    (map binding-rhs b*) 
+                    body)))
+    (define (gen-letrec scc fix* body)
+      (define (mklet lhs* rhs* body)
+        (if (null? lhs*) 
+            body
+            (make-bind lhs* rhs* body)))
+      (define (lambda-binding? x)
+        (and (not (prelex-source-assigned? (binding-lhs x)))
+             (clambda? (binding-rhs x))))
+      (define (mkset!s b* body)
+        (cond
+          [(null? b*) body]
+          [else 
+           (let* ([b (car b*)]
+                  [lhs (binding-lhs b)])
+             (unless (prelex-source-assigned? lhs) 
+               (when (debug-scc)
+                 (printf "MADE COMPLEX ~s\n" (unparse lhs)))
+               (set-prelex-source-assigned?! lhs 
+                  (or (prelex-global-location lhs) #t)))
+             (make-seq
+               (make-assign lhs (binding-rhs b))
+               (mkset!s (cdr b*) body)))]))
+      (cond
+        [(null? (cdr scc)) 
+         (let ([b (car scc)])
+           (cond
+             [(lambda-binding? b)
+              (values (cons b fix*) body)]
+             [(not (memq b (binding-free* b)))
+              (values '()
+                (mklet (list (binding-lhs b))
+                       (list (binding-rhs b))
+                  (mkfix fix* body)))]
+             [else 
+              (values '()
+                (mklet (list (binding-lhs b)) 
+                       (list (make-funcall (make-primref 'void) '()))
+                  (mkset!s scc 
+                    (mkfix fix* body))))]))]
+        [else 
+         (let-values ([(lambda* complex*) 
+                       (partition lambda-binding? scc)])
+           (cond
+             [(null? complex*) 
+              (values (append lambda* fix*) body)]
+             [else
+              (let ([complex* 
+                     (if ordered? (sort-bindings complex*) complex*)])
+                (values '()
+                  (mklet (map binding-lhs complex*)
+                         (map (lambda (x)
+                                (make-funcall (make-primref 'void) '()))
+                               complex*)
+                     (mkfix (append lambda* fix*)
+                       (mkset!s complex* body)))))]))]))
+    (let-values ([(fix* body)
+                  (let f ([scc* scc*])
+                    (cond
+                      [(null? scc*) (values '() body)]
+                      [else 
+                       (let-values ([(fix* body) (f (cdr scc*))])
+                         (gen-letrec (car scc*) fix* body))]))])
+      (mkfix fix* body)))
+  (define (do-recbind lhs* rhs* body bc ordered?)
+    (define (make-bindings lhs* rhs* bc i)
+      (cond
+        [(null? lhs*) '()]
+        [else 
+         (let ([b (make-binding i (car lhs*) (car rhs*) #f bc '())])
+           (set-prelex-operand! (car lhs*) b)
+           (cons b (make-bindings (cdr lhs*) (cdr rhs*) bc (+ i 1))))]))
+    (define (complex? x) 
+      (or (binding-complex x) 
+          (prelex-source-assigned? (binding-lhs x))))
+    (define (insert-order-edges b*)
+      (define (mark pb b*)
+        (unless (null? b*)
+          (let ([b (car b*)])
+            (if (complex? b)
+                (let ([free* (binding-free* b)])
+                  (unless (memq pb free*)
+                    (set-binding-free*! b (cons pb free*)))
+                  (mark b (cdr b*)))
+                (mark pb (cdr b*))))))
+      (unless (null? b*)
+        (let ([b (car b*)])
+          (if (complex? b)
+              (mark b (cdr b*))
+              (insert-order-edges (cdr b*))))))
+    (let ([b* (make-bindings lhs* rhs* bc 0)])
+      (for-each (lambda (b) (set-binding-rhs! b (E (binding-rhs b) b))) b*)
+      (for-each (lambda (x) (set-prelex-operand! x #f)) lhs*)
+      (let ([body (E body bc)]) 
+        (when ordered? (insert-order-edges b*))
+        (let ([scc* (get-sccs-in-order b* (map binding-free* b*) b*)])
+          (when (debug-scc)
+            (printf "SCCS:\n")
+            (for-each 
+              (lambda (scc) 
+                (printf "  ~s\n" 
+                  (map unparse (map binding-lhs scc))))
+              scc*))
+          (gen-letrecs scc* ordered? body)))))
+  (define (sort-bindings ls)
+    (list-sort
+      (lambda (x y) (< (binding-serial x) (binding-serial y)))
+      ls))
+  (define-struct binding (serial lhs rhs complex prev free*))
+  (define (mark-complex bc)
+    (unless (binding-complex bc)
+      (set-binding-complex! bc #t)
+      (mark-complex (binding-prev bc))))
+  (define (mark-free var bc)
+    (let ([rb (prelex-operand var)])
+      (when rb
+        (let ([lb 
+               (let ([pr (binding-prev rb)])
+                 (let f ([bc bc])
+                   (let ([bcp (binding-prev bc)])
+                     (cond
+                       [(eq? bcp pr) bc]
+                       [else (f bcp)]))))])
+          (let ([free* (binding-free* lb)])
+            (unless (memq rb free*)
+              ;(printf "MARK FREE ~s in ~s\n" 
+              ;        (unparse (binding-lhs rb))
+              ;        (unparse (binding-lhs lb)))
+              (set-binding-free*! lb (cons rb free*))))))))
+  (define (E* x* bc)
+    (map (lambda (x) (E x bc)) x*))
+  (define (L x bc)
+    (struct-case x
+      [(clambda g cls* cp free name)
+       (let ([bc (make-binding #f #f #f #t bc '())])
+         (make-clambda g
+           (map (lambda (x)
+                  (struct-case x
+                    [(clambda-case info body)
+                     (make-clambda-case info (E body bc))]))
+                cls*)
+           cp free name))]))
+  (define (E x bc)
+    (struct-case x
+      [(constant) x]
+      [(prelex) 
+       (assert (prelex-source-referenced? x))
+       (mark-free x bc)
+       (when (prelex-source-assigned? x)
+         (mark-complex bc))
+       x]
+      [(assign lhs rhs)
+       (assert (prelex-source-assigned? lhs))
+       ;(set-prelex-source-assigned?! lhs #t)
+       (mark-free lhs bc)
+       (mark-complex bc)
+       (make-assign lhs (E rhs bc))]
+      [(primref) x]
+      [(bind lhs* rhs* body)
+       (if (null? lhs*)
+           (E body bc)
+           (make-bind lhs* (E* rhs* bc) (E body bc)))]
+      [(recbind lhs* rhs* body)
+       (if (null? lhs*)
+           (E body bc)
+           (do-recbind lhs* rhs* body bc #f))]
+      [(rec*bind lhs* rhs* body)
+       (if (null? lhs*)
+           (E body bc)
+           (do-recbind lhs* rhs* body bc #t))]
+      [(conditional e0 e1 e2)
+       (make-conditional (E e0 bc) (E e1 bc) (E e2 bc))]
+      [(seq e0 e1) (make-seq (E e0 bc) (E e1 bc))]
+      [(clambda g cls* cp free name)
+       (L x bc)]
+      [(funcall rator rand*)
+       (mark-complex bc)
+       (make-funcall (E rator bc) (E* rand* bc))]
+      [(mvcall p c)
+       (mark-complex bc)
+       (make-mvcall (E p bc) (E c bc))]
+      [(forcall rator rand*) 
+       (mark-complex bc)
+       (make-forcall rator (E* rand* bc))]
+      [else (error who "invalid expression" (unparse x))]))
+  ;(printf "===========================================\n")
+  (let ([x (E x (make-binding #f #f #f #t #t '()))])
+    ;(pretty-print (unparse x)) 
+    x))
+
+
+(define debug-scc (make-parameter #f))
+
+(define (optimize-letrec x)
+  (optimize-letrec/scc x)))
diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index 5e747f4..e71acf0 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -853,260 +853,8 @@
   body)
 |#
 
-(define debug-scc (make-parameter #f))
-
-(define (optimize-letrec/scc x)
-  (define who 'optimize-letrec/scc)
-  (module (get-sccs-in-order)
-    (define-struct node (data link* lowlink root done collection))
-    (define (create-graph v* e** data*)
-      (define h (make-eq-hashtable))
-      (let ([v*
-             (let f ([v* v*] [data* data*])
-               (cond
-                 [(null? v*) '()]
-                 [else
-                  (let ([node (make-node (car data*) '() #f #f #f #f)])
-                    (hashtable-set! h (car v*) node) 
-                    (cons node (f (cdr v*) (cdr data*))))]))])
-        (for-each
-          (lambda (v e*)
-            (set-node-link*! v
-              (map (lambda (f) 
-                     (or (hashtable-ref h f #f)
-                         (error who "invalid node" f)))
-                   e*)))
-          v* e**)
-        v*))
-    (define (compute-sccs v*) ; Tarjan's algorithm
-      (define scc* '())
-      (define (compute-sccs v)
-        (define index 0)
-        (define stack '())
-        (define (tarjan v)
-          (let ([v-index index])
-            (set-node-root! v v-index)
-            (set! stack (cons v stack))
-            (set! index (fx+ index 1))
-            (for-each
-              (lambda (v^)
-                (unless (node-done v^)
-                  (unless (node-root v^) (tarjan v^))
-                  (set-node-root! v (fxmin (node-root v) (node-root v^)))))
-              (node-link* v))
-            (when (fx= (node-root v) v-index)
-              (set! scc*
-                (cons
-                  (let f ([ls stack])
-                    (let ([v^ (car ls)])
-                      (set-node-done! v^ #t)
-                      (cons v^ (if (eq? v^ v)
-                                   (begin (set! stack (cdr ls)) '())
-                                   (f (cdr ls))))))
-                  scc*)))))
-        (tarjan v))
-      (for-each (lambda (v) (unless (node-done v) (compute-sccs v))) v*)
-      (reverse scc*))
-    (define (get-sccs-in-order n* e** data*)
-      (let ([G (create-graph n* e** data*)])
-        (let ([sccs (compute-sccs G)])
-          (map (lambda (scc) (map node-data scc)) sccs)))))
-  (define (gen-letrecs scc* ordered? body) 
-    (define (mkfix b* body)
-      (if (null? b*) 
-          body
-          (make-fix (map binding-lhs b*) 
-                    (map binding-rhs b*) 
-                    body)))
-    (define (gen-letrec scc fix* body)
-      (define (mklet lhs* rhs* body)
-        (if (null? lhs*) 
-            body
-            (make-bind lhs* rhs* body)))
-      (define (lambda-binding? x)
-        (and (not (prelex-source-assigned? (binding-lhs x)))
-             (clambda? (binding-rhs x))))
-      (define (mkset!s b* body)
-        (cond
-          [(null? b*) body]
-          [else 
-           (let* ([b (car b*)]
-                  [lhs (binding-lhs b)])
-             (unless (prelex-source-assigned? lhs) 
-               (when (debug-scc)
-                 (printf "MADE COMPLEX ~s\n" (unparse lhs)))
-               (set-prelex-source-assigned?! lhs 
-                  (or (prelex-global-location lhs) #t)))
-             (make-seq
-               (make-assign lhs (binding-rhs b))
-               (mkset!s (cdr b*) body)))]))
-      (cond
-        [(null? (cdr scc)) 
-         (let ([b (car scc)])
-           (cond
-             [(lambda-binding? b)
-              (values (cons b fix*) body)]
-             [(not (memq b (binding-free* b)))
-              (values '()
-                (mklet (list (binding-lhs b))
-                       (list (binding-rhs b))
-                  (mkfix fix* body)))]
-             [else 
-              (values '()
-                (mklet (list (binding-lhs b)) 
-                       (list (make-funcall (make-primref 'void) '()))
-                  (mkset!s scc 
-                    (mkfix fix* body))))]))]
-        [else 
-         (let-values ([(lambda* complex*) 
-                       (partition lambda-binding? scc)])
-           (cond
-             [(null? complex*) 
-              (values (append lambda* fix*) body)]
-             [else
-              (let ([complex* 
-                     (if ordered? (sort-bindings complex*) complex*)])
-                (values '()
-                  (mklet (map binding-lhs complex*)
-                         (map (lambda (x)
-                                (make-funcall (make-primref 'void) '()))
-                               complex*)
-                     (mkfix (append lambda* fix*)
-                       (mkset!s complex* body)))))]))]))
-    (let-values ([(fix* body)
-                  (let f ([scc* scc*])
-                    (cond
-                      [(null? scc*) (values '() body)]
-                      [else 
-                       (let-values ([(fix* body) (f (cdr scc*))])
-                         (gen-letrec (car scc*) fix* body))]))])
-      (mkfix fix* body)))
-  (define (do-recbind lhs* rhs* body bc ordered?)
-    (define (make-bindings lhs* rhs* bc i)
-      (cond
-        [(null? lhs*) '()]
-        [else 
-         (let ([b (make-binding i (car lhs*) (car rhs*) #f bc '())])
-           (set-prelex-operand! (car lhs*) b)
-           (cons b (make-bindings (cdr lhs*) (cdr rhs*) bc (+ i 1))))]))
-    (define (complex? x) 
-      (or (binding-complex x) 
-          (prelex-source-assigned? (binding-lhs x))))
-    (define (insert-order-edges b*)
-      (define (mark pb b*)
-        (unless (null? b*)
-          (let ([b (car b*)])
-            (if (complex? b)
-                (let ([free* (binding-free* b)])
-                  (unless (memq pb free*)
-                    (set-binding-free*! b (cons pb free*)))
-                  (mark b (cdr b*)))
-                (mark pb (cdr b*))))))
-      (unless (null? b*)
-        (let ([b (car b*)])
-          (if (complex? b)
-              (mark b (cdr b*))
-              (insert-order-edges (cdr b*))))))
-    (let ([b* (make-bindings lhs* rhs* bc 0)])
-      (for-each (lambda (b) (set-binding-rhs! b (E (binding-rhs b) b))) b*)
-      (for-each (lambda (x) (set-prelex-operand! x #f)) lhs*)
-      (let ([body (E body bc)]) 
-        (when ordered? (insert-order-edges b*))
-        (let ([scc* (get-sccs-in-order b* (map binding-free* b*) b*)])
-          (when (debug-scc)
-            (printf "SCCS:\n")
-            (for-each 
-              (lambda (scc) 
-                (printf "  ~s\n" 
-                  (map unparse (map binding-lhs scc))))
-              scc*))
-          (gen-letrecs scc* ordered? body)))))
-  (define (sort-bindings ls)
-    (list-sort
-      (lambda (x y) (< (binding-serial x) (binding-serial y)))
-      ls))
-  (define-struct binding (serial lhs rhs complex prev free*))
-  (define (mark-complex bc)
-    (unless (binding-complex bc)
-      (set-binding-complex! bc #t)
-      (mark-complex (binding-prev bc))))
-  (define (mark-free var bc)
-    (let ([rb (prelex-operand var)])
-      (when rb
-        (let ([lb 
-               (let ([pr (binding-prev rb)])
-                 (let f ([bc bc])
-                   (let ([bcp (binding-prev bc)])
-                     (cond
-                       [(eq? bcp pr) bc]
-                       [else (f bcp)]))))])
-          (let ([free* (binding-free* lb)])
-            (unless (memq rb free*)
-              ;(printf "MARK FREE ~s in ~s\n" 
-              ;        (unparse (binding-lhs rb))
-              ;        (unparse (binding-lhs lb)))
-              (set-binding-free*! lb (cons rb free*))))))))
-  (define (E* x* bc)
-    (map (lambda (x) (E x bc)) x*))
-  (define (L x bc)
-    (struct-case x
-      [(clambda g cls* cp free name)
-       (let ([bc (make-binding #f #f #f #t bc '())])
-         (make-clambda g
-           (map (lambda (x)
-                  (struct-case x
-                    [(clambda-case info body)
-                     (make-clambda-case info (E body bc))]))
-                cls*)
-           cp free name))]))
-  (define (E x bc)
-    (struct-case x
-      [(constant) x]
-      [(prelex) 
-       (assert (prelex-source-referenced? x))
-       (mark-free x bc)
-       (when (prelex-source-assigned? x)
-         (mark-complex bc))
-       x]
-      [(assign lhs rhs)
-       (assert (prelex-source-assigned? lhs))
-       ;(set-prelex-source-assigned?! lhs #t)
-       (mark-free lhs bc)
-       (mark-complex bc)
-       (make-assign lhs (E rhs bc))]
-      [(primref) x]
-      [(bind lhs* rhs* body)
-       (if (null? lhs*)
-           (E body bc)
-           (make-bind lhs* (E* rhs* bc) (E body bc)))]
-      [(recbind lhs* rhs* body)
-       (if (null? lhs*)
-           (E body bc)
-           (do-recbind lhs* rhs* body bc #f))]
-      [(rec*bind lhs* rhs* body)
-       (if (null? lhs*)
-           (E body bc)
-           (do-recbind lhs* rhs* body bc #t))]
-      [(conditional e0 e1 e2)
-       (make-conditional (E e0 bc) (E e1 bc) (E e2 bc))]
-      [(seq e0 e1) (make-seq (E e0 bc) (E e1 bc))]
-      [(clambda g cls* cp free name)
-       (L x bc)]
-      [(funcall rator rand*)
-       (mark-complex bc)
-       (make-funcall (E rator bc) (E* rand* bc))]
-      [(mvcall p c)
-       (mark-complex bc)
-       (make-mvcall (E p bc) (E c bc))]
-      [(forcall rator rand*) 
-       (mark-complex bc)
-       (make-forcall rator (E* rand* bc))]
-      [else (error who "invalid expression" (unparse x))]))
-  ;(printf "===========================================\n")
-  (let ([x (E x (make-binding #f #f #f #t #t '()))])
-    ;(pretty-print (unparse x)) 
-    x))
 
+(include "ikarus.compiler.optimize-letrec.ss")
 (include "ikarus.compiler.source-optimizer.ss")
 
 (define (rewrite-assignments x)
@@ -2424,7 +2172,7 @@
   (let* ([p (recordize p)]
          [p (parameterize ([open-mvcalls #f])
               (optimize-direct-calls p))]
-         [p (optimize-letrec/scc p)]
+         [p (optimize-letrec p)]
          [p (source-optimize p)]
          [dummy 
           (begin
@@ -2517,7 +2265,7 @@
             (optimize-direct-calls x)))
        (lambda (x)
          (parameterize ([debug-scc #t])
-            (optimize-letrec/scc x))))]))
+            (optimize-letrec x))))]))
 
 (define expand/optimize
   (case-lambda
@@ -2527,7 +2275,7 @@
        (lambda (x) 
          (parameterize ([open-mvcalls #f])
             (optimize-direct-calls x)))
-       optimize-letrec/scc
+       optimize-letrec
        source-optimize)]))
 
 (define expand
diff --git a/scheme/last-revision b/scheme/last-revision
index 622f2e6..e2241f0 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1820
+1821