diff options
-rw-r--r-- | module/language/cps.scm | 62 | ||||
-rw-r--r-- | module/language/cps/cse.scm | 2 | ||||
-rw-r--r-- | module/language/cps/dce.scm | 2 | ||||
-rw-r--r-- | module/language/cps/dfg.scm | 9 |
4 files changed, 53 insertions, 22 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm index ddda6ff50..c685ddc93 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -136,7 +136,8 @@ ;; Misc. parse-cps unparse-cps - make-cont-folder fold-conts fold-local-conts + make-global-cont-folder make-local-cont-folder + fold-conts fold-local-conts visit-cont-successors)) ;; FIXME: Use SRFI-99, when Guile adds it. @@ -449,7 +450,7 @@ (_ (error "unexpected cps" exp)))) -(define-syntax-rule (make-cont-folder global? seed ...) +(define-syntax-rule (make-global-cont-folder seed ...) (lambda (proc cont seed ...) (define (fold-values proc in seed ...) (if (null? in) @@ -492,22 +493,55 @@ (($ $continue k src exp) (match exp - (($ $fun) - (if global? - (fun-folder exp seed ...) - (values seed ...))) + (($ $fun) (fun-folder exp seed ...)) (_ (values seed ...)))) (($ $letrec names syms funs body) (let-values (((seed ...) (term-folder body seed ...))) - (if global? - (fold-values fun-folder funs seed ...) - (values seed ...)))))) + (fold-values fun-folder funs seed ...))))) (cont-folder cont seed ...))) +(define-syntax-rule (make-local-cont-folder seed ...) + (lambda (proc cont seed ...) + (define (cont-folder cont seed ...) + (match cont + (($ $cont k (and cont ($ $kargs names syms body))) + (let-values (((seed ...) (proc k cont seed ...))) + (term-folder body seed ...))) + (($ $cont k cont) + (proc k cont seed ...)))) + (define (term-folder term seed ...) + (match term + (($ $letk conts body) + (let-values (((seed ...) (term-folder body seed ...))) + (let lp ((conts conts) (seed seed) ...) + (match conts + (() (values seed ...)) + ((cont) (cont-folder cont seed ...)) + ((cont . conts) + (let-values (((seed ...) (cont-folder cont seed ...))) + (lp conts seed ...))))))) + (($ $letrec names syms funs body) (term-folder body seed ...)) + (_ (values seed ...)))) + (define (clause-folder clause seed ...) + (match clause + (($ $cont k (and cont ($ $kclause arity body alternate))) + (let-values (((seed ...) (proc k cont seed ...))) + (if alternate + (let-values (((seed ...) (cont-folder body seed ...))) + (clause-folder alternate seed ...)) + (cont-folder body seed ...)))))) + (match cont + (($ $cont k (and cont ($ $kfun src meta self tail clause))) + (let*-values (((seed ...) (proc k cont seed ...)) + ((seed ...) (if clause + (clause-folder clause seed ...) + (values seed ...)))) + (cont-folder tail seed ...)))))) + (define (compute-max-label-and-var fun) - ((make-cont-folder #t max-label max-var) + ((make-global-cont-folder max-label max-var) (lambda (label cont max-label max-var) (values (max label max-label) (match cont @@ -521,15 +555,13 @@ (($ $kfun src meta self) (max self max-var)) (_ max-var)))) - fun - -1 - -1)) + fun -1 -1)) (define (fold-conts proc seed fun) - ((make-cont-folder #t seed) proc fun seed)) + ((make-global-cont-folder seed) proc fun seed)) (define (fold-local-conts proc seed fun) - ((make-cont-folder #f seed) proc fun seed)) + ((make-local-cont-folder seed) proc fun seed)) (define (visit-cont-successors proc cont) (match cont diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 2ecf40ca5..5ca0bb54c 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -230,7 +230,7 @@ be that both true and false proofs are available." (define (compute-label-and-var-ranges fun) (match fun (($ $cont kfun ($ $kfun src meta self)) - ((make-cont-folder #f min-label label-count min-var var-count) + ((make-local-cont-folder min-label label-count min-var var-count) (lambda (k cont min-label label-count min-var var-count) (let ((min-label (min k min-label)) (label-count (1+ label-count))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 9105c4eaa..9100b93d7 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -90,7 +90,7 @@ (define (ensure-fun-data fun) (or (hashq-ref fun-data-table fun) (call-with-values (lambda () - ((make-cont-folder #f label-count max-label) + ((make-local-cont-folder label-count max-label) (lambda (k cont label-count max-label) (values (1+ label-count) (max k max-label))) fun 0 -1)) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 5233719b1..efafd745d 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -735,9 +735,8 @@ body continuation in the prompt." (define (compute-label-and-var-ranges fun global?) (define (min* a b) (if b (min a b) a)) - (define-syntax-rule (do-fold global?) - ((make-cont-folder global? - min-label max-label label-count + (define-syntax-rule (do-fold make-cont-folder) + ((make-cont-folder min-label max-label label-count min-var max-var var-count) (lambda (label cont min-label max-label label-count @@ -778,8 +777,8 @@ body continuation in the prompt." fun #f -1 0 #f -1 0)) (if global? - (do-fold #t) - (do-fold #f))) + (do-fold make-global-cont-folder) + (do-fold make-local-cont-folder))) (define* (compute-dfg fun #:key (global? #t)) (call-with-values (lambda () (compute-label-and-var-ranges fun global?)) |