mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +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 (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?))