summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/cps/dfg.scm86
1 files changed, 45 insertions, 41 deletions
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 89922ab5e..4f32fce54 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -881,47 +881,51 @@ BODY for each body continuation in the prompt."
(define (compute-label-and-var-ranges fun global?)
(define (min* a b)
(if b (min a b) a))
- ((make-cont-folder global?
- min-label max-label label-count
- min-var max-var var-count)
- (lambda (label cont
- min-label max-label label-count
- 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 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)))
- (_ (values min-label max-label (1+ label-count)
- min-var max-var var-count)))))
- fun
- #f -1 0 #f -1 0))
+ (define-syntax-rule (do-fold global?)
+ ((make-cont-folder global?
+ min-label max-label label-count
+ min-var max-var var-count)
+ (lambda (label cont
+ min-label max-label label-count
+ 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 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)))
+ (_ (values min-label max-label (1+ label-count)
+ min-var max-var var-count)))))
+ fun
+ #f -1 0 #f -1 0))
+ (if global?
+ (do-fold #t)
+ (do-fold #f)))
(define* (compute-dfg fun #:key (global? #t))
(call-with-values (lambda () (compute-label-and-var-ranges fun global?))