[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
- [Guile-commits] branch master updated (f541ee1 -> 6f4487f), Andy Wingo, 2015/06/04
- [Guile-commits] 01/10: Fix write beyond stack boundary in vm-engine.c, Andy Wingo, 2015/06/04
- [Guile-commits] 02/10: Fix slot allocation hinting for intervening terms that define dead values, Andy Wingo, 2015/06/04
- [Guile-commits] 03/10: Fix intmap-ref bug, Andy Wingo, 2015/06/04
- [Guile-commits] 04/10: Fix eta reduction on CPS2, Andy Wingo, 2015/06/04
- [Guile-commits] 05/10: Port self-references pass to CPS2, Andy Wingo, 2015/06/04
- [Guile-commits] 09/10: Enable all CPS2 optimization passes, Andy Wingo, 2015/06/04
- [Guile-commits] 06/10: Refactor renumber.scm,
Andy Wingo <=
- [Guile-commits] 08/10: Tweaks to bootstrap build order, Andy Wingo, 2015/06/04
- [Guile-commits] 10/10: Disable CPS optimization passes, Andy Wingo, 2015/06/04
- [Guile-commits] 07/10: Add CPS2 verification pass, Andy Wingo, 2015/06/04