mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 20:40:29 +02:00
Code Activity

Fix compute-label-and-var-ranges for global DFG computation

Browse source 
* module/language/cps/dfg.scm (compute-label-and-var-ranges): Fix to
  work with global DFGs -- it wasn't taking $letrec into account for var
  ranges.

* module/language/cps/dce.scm (compute-live-code): Use bitvectors to
  represent the live var set.
This commit is contained in:
Andy Wingo 2014-04-01 18:16:00 +02:00
parent f9bceb770b
commit 0912202a51
2 changed files with 35 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

18
module/language/cps/dce.scm
View file

@ -79,15 +79,15 @@
(define (compute-live-code fun)
(let* ((fun-data-table (make-hash-table))
(live-vars (make-hash-table))
(dfg (compute-dfg fun #:global? #t))
(live-vars (make-bitvector (dfg-var-count dfg) #f))
(changed? #f))
(define (mark-live! sym)
(unless (value-live? sym)
(define (mark-live! var)
(unless (value-live? var)
(set! changed? #t)
(hashq-set! live-vars sym #t)))
(define (value-live? sym)
(hashq-ref live-vars sym))
(bitvector-set! live-vars var #t)))
(define (value-live? var)
(bitvector-ref live-vars var))
(define (ensure-fun-data fun)
(or (hashq-ref fun-data-table fun)
(call-with-values (lambda ()
@ -168,6 +168,8 @@
(mark-live! self))
(($ $ktail) #f))
(lp (1- n))))))))
(unless (= (dfg-var-count dfg) (var-counter))
(error "internal error" (dfg-var-count dfg) (var-counter)))
(let lp ()
(set! changed? #f)
(visit-fun fun)
@ -175,8 +177,8 @@
(values fun-data-table live-vars)))
(define (process-eliminations fun fun-data-table live-vars)
(define (value-live? sym)
(hashq-ref live-vars sym))
(define (value-live? var)
(bitvector-ref live-vars var))
(define (make-adaptor name k defs)
(let* ((names (map (lambda (_) 'tmp) defs))
(syms (map (lambda (_) (fresh-var)) defs))

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

@ -889,14 +889,32 @@ BODY for each body continuation in the prompt."
min-var max-var var-count)
(let ((min-label (min* label min-label))
(max-label (max label max-label)))
(match cont
(($ $kargs names vars)
(values min-label max-label (1+ label-count)
(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)))