diff options
-rw-r--r-- | module/language/cps/dfg.scm | 86 |
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?)) |