guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 06/10: Refactor renumber.scm


From: Andy Wingo
Subject: [Guile-commits] 06/10: Refactor renumber.scm
Date: Thu, 04 Jun 2015 22:57:50 +0000

wingo pushed a commit to branch master
in repository guile.

commit b012248f0473dc594111151ddf9805d3f5cbdcd9
Author: Andy Wingo <address@hidden>
Date:   Thu Jun 4 10:27:41 2015 +0200

    Refactor renumber.scm
    
    * module/language/cps2/renumber.scm (sort-labels-locally): Rewrite to
      be functional.  Yay :)
---
 module/language/cps2/renumber.scm |  105 ++++++++++++++++---------------------
 1 files changed, 46 insertions(+), 59 deletions(-)

diff --git a/module/language/cps2/renumber.scm 
b/module/language/cps2/renumber.scm
index f7e9eb6..2c07e03 100644
--- a/module/language/cps2/renumber.scm
+++ b/module/language/cps2/renumber.scm
@@ -60,67 +60,54 @@
 ;; Topologically sort the continuation tree starting at k0, using
 ;; reverse post-order numbering.
 (define (sort-labels-locally conts k0 path-lengths)
+  (define (visit-kf-first? kf kt)
+    ;; Visit the successor of a branch with the shortest path length to
+    ;; the tail first, so that if the branches are unsorted, the longer
+    ;; path length will appear first.  This will move a loop exit out of
+    ;; a loop.
+    (let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
+          (kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
+      (if kt-len
+          (or (not kf-len) (< kf-len kt-len)
+              ;; If the path lengths are the same, preserve original
+              ;; order to avoid squirreliness.
+              (and (= kf-len kt-len) (< kt kf)))
+          (if kf-len #f (< kt kf)))))
   (let ((order '())
         (visited empty-intset))
-    (define (visit k)
-      (define (maybe-visit k)
-        (unless (intset-ref visited k)
-          (visit k)))
-      (define (visit-successors k)
-        (match (intmap-ref conts k)
-          (($ $kargs names syms ($ $continue k src exp))
-           (match exp
-             (($ $prompt escape? tag handler)
-              (maybe-visit handler)
-              (maybe-visit k))
-             (($ $branch kt)
-              ;; Visit the successor with the shortest path length
-              ;; to the tail first, so that if the branches are
-              ;; unsorted, the longer path length will appear
-              ;; first.  This will move a loop exit out of a loop.
-              (let ((k-len (intmap-ref path-lengths k
-                                       (lambda (_) #f)))
-                    (kt-len (intmap-ref path-lengths kt
-                                        (lambda (_) #f))))
-                (cond
-                 ((if kt-len
-                      (or (not k-len)
-                          (< k-len kt-len)
-                          ;; If the path lengths are the
-                          ;; same, preserve original order
-                          ;; to avoid squirreliness.
-                          (and (= k-len kt-len) (< kt k)))
-                      (if k-len #f (< kt k)))
-                  (maybe-visit k)
-                  (maybe-visit kt))
-                 (else
-                  (maybe-visit kt)
-                  (maybe-visit k)))))
-             (_
-              (maybe-visit k))))
-          (($ $kreceive arity k) (maybe-visit k))
-          (($ $kclause arity kbody kalt)
-           (when kalt (visit kalt))
-           (maybe-visit kbody))
-          (($ $kfun src meta self tail clause)
-           (visit tail)
-           (when clause (visit clause)))
-          (_ #f)))
-
-      ;; Mark this continuation as visited.
-      (set! visited (intset-add! visited k))
-
-      ;; Visit unvisited successors.
-      (visit-successors k)
-
-      ;; Add k to the reverse post-order.
-      (set! order (cons k order)))
-
-    ;; Recursively visit all continuations reachable from k0.
-    (visit k0)
-
-    ;; Return the sorted order.
-    order))
+    (let visit ((k k0) (order '()) (visited empty-intset))
+      (define (visit2 k0 k1 order visited)
+        (let-values (((order visited) (visit k0 order visited)))
+          (visit k1 order visited)))
+      (if (intset-ref visited k)
+          (values order visited)
+          (let ((visited (intset-add visited k)))
+            (call-with-values
+                (lambda ()
+                  (match (intmap-ref conts k)
+                    (($ $kargs names syms ($ $continue k src exp))
+                     (match exp
+                       (($ $prompt escape? tag handler)
+                        (visit2 k handler order visited))
+                       (($ $branch kt)
+                        (if (visit-kf-first? k kt)
+                            (visit2 k kt order visited)
+                            (visit2 kt k order visited)))
+                       (_
+                        (visit k order visited))))
+                    (($ $kreceive arity k) (visit k order visited))
+                    (($ $kclause arity kbody kalt)
+                     (if kalt
+                         (visit2 kalt kbody order visited)
+                         (visit kbody order visited)))
+                    (($ $kfun src meta self tail clause)
+                     (if clause
+                         (visit2 tail clause order visited)
+                         (visit tail order visited)))
+                    (($ $ktail) (values order visited))))
+              (lambda (order visited)
+                ;; Add k to the reverse post-order.
+                (values (cons k order) visited))))))))
 
 (define (compute-renaming conts kfun)
   ;; labels := old -> new



reply via email to

[Prev in Thread] Current Thread [Next in Thread]