Fixes bug 205427 in letrec*.

scheme/ikarus.compiler.ss

@@ -745,6 +745,7 @@
   body)
 |#
 
+
 (define scc-letrec (make-parameter #t))
 
 (define (optimize-letrec/scc x)
@@ -770,35 +771,38 @@
                    e*)))
           v* e**)
         v*))
-    (define (compute-sccs! v*)
+    (define (compute-sccs v*) ; Tarjan's algorithm
-      (define all-sccs '())
+      (define scc* '())
-      (define (visit v i) 
+      (define (compute-sccs v)
-        (set-node-lowlink! v i)
+        (define index 0)
-        (set-node-root! v v)
+        (define stack '())
-        (set-node-collection! v '())
+        (define (tarjan v)
-        (for-each 
+          (let ([v-index index])
-          (lambda (v^)
+            (set-node-root! v v-index)
-            (unless (node-done v^)
+            (set! stack (cons v stack))
-              (unless (node-lowlink v^)
+            (set! index (fx+ index 1))
-                (visit v^ (+ i 1)))
+            (for-each
-              (when (< (node-lowlink v^) (node-lowlink v))
+              (lambda (v^)
-                (set-node-lowlink! v (node-lowlink v^))
+                (unless (node-done v^)
-                (set-node-root! v (node-root v^)))))
+                  (unless (node-root v^) (tarjan v^))
-          (node-link* v))
+                  (set-node-root! v (fxmin (node-root v) (node-root v^)))))
-        (let ([root (node-root v)])
+              (node-link* v))
-          (let ([nodes (cons v (node-collection root))])
+            (when (fx= (node-root v) v-index)
-            (cond
+              (set! scc*
-              [(eq? v root)
+                (cons
-               (set! all-sccs (cons nodes all-sccs))
+                  (let f ([ls stack])
-               (for-each (lambda (x) (set-node-done! x #t)) nodes)]
+                    (let ([v^ (car ls)])
-              [else
+                      (set-node-done! v^ #t)
-               (set-node-collection! root 
+                      (cons v^ (if (eq? v^ v)
-                 (append (node-collection v) nodes))]))))
+                                   (begin (set! stack (cdr ls)) '())
-      (for-each (lambda (v) (unless (node-done v) (visit v 0))) v*)
+                                   (f (cdr ls))))))
-      (reverse all-sccs))
+                  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)])
+        (let ([sccs (compute-sccs G)])
           (map (lambda (scc) (map node-data scc)) sccs)))))
   (define (gen-letrecs scc* ordered? body) 
     (define (mkfix b* body)
@@ -950,6 +954,8 @@
       [(constant) x]
       [(var) 
        (mark-free x bc)
+       (when (var-assigned x) 
+         (mark-complex bc))
        x]
       [(assign lhs rhs)
        (set-var-assigned! lhs #t)

scheme/last-revision

@@ -1 +1 @@
-1422
+1423