diff options
author | Andy Wingo <wingo@pobox.com> | 2014-04-11 18:01:23 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-04-11 18:32:54 +0200 |
commit | 405805fbc3abab129750dc2c0da7be9ea609c34a (patch) | |
tree | 8b86da711cef88badbdd706227bbe7697bf3fcb1 /module/language/cps.scm | |
parent | a0329d01095d6ddaa42449ec18a4fb2bc83db16e (diff) | |
download | guile-405805fbc3abab129750dc2c0da7be9ea609c34a.tar.gz |
Separate make-cont-folder into global and local variants
* module/language/cps.scm (make-global-cont-folder)
(make-local-cont-folder): Separate this macro in two. It's hot and
the difference can be important for perf.
* module/language/cps/dfg.scm (compute-label-and-var-ranges):
* module/language/cps/cse.scm (compute-label-and-var-ranges):
* module/language/cps/dce.scm (compute-live-code): Adapt.
Diffstat (limited to 'module/language/cps.scm')
-rw-r--r-- | module/language/cps.scm | 62 |
1 files changed, 47 insertions, 15 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 |