mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Speed up compute-label-and-var-ranges

Browse source 
* module/language/cps/dfg.scm (compute-label-and-var-ranges): Duplicate
  the cont-folder cases in the global/not-global cases.  Lets the
  optimizer DTRT.
This commit is contained in:
Andy Wingo 2014-04-01 18:20:02 +02:00
parent 0912202a51
commit 545274a035
1 changed files with 45 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

86
module/language/cps/dfg.scm
View file

@ -881,47 +881,51 @@ BODY for each body continuation in the prompt."
(define (compute-label-and-var-ranges fun global?) (define (compute-label-and-var-ranges fun global?)
(define (min* a b) (define (min* a b)
(if b (min a b) a)) (if b (min a b) a))
((make-cont-folder global? (define-syntax-rule (do-fold global?)
min-label max-label label-count ((make-cont-folder global?
min-var max-var var-count) min-label max-label label-count
(lambda (label cont min-var max-var var-count)
min-label max-label label-count (lambda (label cont
min-var max-var var-count) min-label max-label label-count
(let ((min-label (min* label min-label)) min-var max-var var-count)
(max-label (max label max-label))) (let ((min-label (min* label min-label))
(define (visit-letrec body min-var max-var var-count) (max-label (max label max-label)))
(match body (define (visit-letrec body min-var max-var var-count)
(($ $letk conts body) (match body
(visit-letrec body min-var max-var var-count)) (($ $letk conts body)
(($ $letrec names vars funs body) (visit-letrec body min-var max-var var-count))
(visit-letrec body (($ $letrec names vars funs body)
(cond (min-var (fold min min-var vars)) (visit-letrec body
((pair? vars) (fold min (car vars) (cdr vars))) (cond (min-var (fold min min-var vars))
(else min-var)) ((pair? vars) (fold min (car vars) (cdr vars)))
(fold max max-var vars) (else min-var))
(+ var-count (length vars)))) (fold max max-var vars)
(($ $continue) (values min-var max-var var-count)))) (+ var-count (length vars))))
(match cont (($ $continue) (values min-var max-var var-count))))
(($ $kargs names vars body) (match cont
(call-with-values (($ $kargs names vars body)
(lambda () (call-with-values
(if global? (lambda ()
(visit-letrec body min-var max-var var-count) (if global?
(values min-var max-var var-count))) (visit-letrec body min-var max-var var-count)
(lambda (min-var max-var var-count) (values min-var max-var var-count)))
(values min-label max-label (1+ label-count) (lambda (min-var max-var var-count)
(cond (min-var (fold min min-var vars)) (values min-label max-label (1+ label-count)
((pair? vars) (fold min (car vars) (cdr vars))) (cond (min-var (fold min min-var vars))
(else min-var)) ((pair? vars) (fold min (car vars) (cdr vars)))
(fold max max-var vars) (else min-var))
(+ var-count (length vars)))))) (fold max max-var vars)
(($ $kentry self) (+ var-count (length vars))))))
(values min-label max-label (1+ label-count) (($ $kentry self)
(min* self min-var) (max self max-var) (1+ var-count))) (values min-label max-label (1+ label-count)
(_ (values min-label max-label (1+ label-count) (min* self min-var) (max self max-var) (1+ var-count)))
min-var max-var var-count))))) (_ (values min-label max-label (1+ label-count)
fun min-var max-var var-count)))))
#f -1 0 #f -1 0)) fun
#f -1 0 #f -1 0))
(if global?
(do-fold #t)
(do-fold #f)))
(define* (compute-dfg fun #:key (global? #t)) (define* (compute-dfg fun #:key (global? #t))
(call-with-values (lambda () (compute-label-and-var-ranges fun global?)) (call-with-values (lambda () (compute-label-and-var-ranges fun global?))