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

DFG refactor

Browse source 
* module/language/cps/dfg.scm (lookup-cont, lookup-block):
  (lookup-def, constant-needs-allocation?): Rework these accessors to
  avoid completely destructuring the $dfg.
This commit is contained in:
Andy Wingo 2014-03-30 20:27:31 +02:00
parent 62b7180bfd
commit f49e994b52
1 changed files with 47 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -99,14 +99,6 @@
(make-vector (1+ max-k) #f) (make-vector (1+ max-k) #f)
fun))) fun)))
(define (lookup-cont label dfg)
(match dfg
(($ $dfg conts blocks defs uses min-label nlabels min-var nvars)
(let ((res (vector-ref conts (- label min-label))))
(unless res
(error "Unknown continuation!" label conts))
res))))
;; Data-flow graph for CPS: both for values and continuations. ;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg (define-record-type $dfg
(make-dfg conts blocks defs uses min-label nlabels min-var nvars) (make-dfg conts blocks defs uses min-label nlabels min-var nvars)
@ -929,27 +921,27 @@ BODY for each body continuation in the prompt."
(make-dfg conts blocks defs uses (make-dfg conts blocks defs uses
min-label label-count min-var var-count))))) min-label label-count min-var var-count)))))
(define (lookup-cont label dfg)
(let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
(unless res
(error "Unknown continuation!" label))
res))
(define (lookup-block k dfg) (define (lookup-block k dfg)
(match dfg (let ((res (vector-ref (dfg-blocks dfg) (- k (dfg-min-label dfg)))))
(($ $dfg conts blocks defs uses min-label nlabels min-var nvars) (unless res
(let ((res (vector-ref blocks (- k min-label)))) (error "Unknown continuation!" k))
(unless res res))
(error "Unknown continuation!" k blocks))
res))))
(define (lookup-scope-level k dfg) (define (lookup-scope-level k dfg)
(match (lookup-block k dfg) (match (lookup-block k dfg)
(($ $block _ scope-level) scope-level))) (($ $block _ scope-level) scope-level)))
(define (lookup-def var dfg) (define (lookup-def var dfg)
(match dfg (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
(($ $dfg conts blocks defs uses min-label nlabels min-var nvars)
(vector-ref defs (- var min-var)))))
(define (lookup-uses var dfg) (define (lookup-uses var dfg)
(match dfg (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
(($ $dfg conts blocks defs uses min-label nlabels min-var nvars)
(vector-ref uses (- var min-var)))))
(define (lookup-block-scope k dfg) (define (lookup-block-scope k dfg)
(block-scope (lookup-block k dfg))) (block-scope (lookup-block k dfg)))
@ -1007,42 +999,41 @@ BODY for each body continuation in the prompt."
(($ $kargs names syms body) (find-exp body)) (($ $kargs names syms body) (find-exp body))
(($ $letk conts body) (find-exp body)) (($ $letk conts body) (find-exp body))
(else term))) (else term)))
(match dfg
(($ $dfg conts blocks defs uses min-label nlabels min-var nvars) (or-map
(or-map (lambda (use)
(lambda (use) (match (find-expression (lookup-cont use dfg))
(match (find-expression (lookup-cont use dfg)) (($ $call) #f)
(($ $call) #f) (($ $callk) #f)
(($ $callk) #f) (($ $values) #f)
(($ $values) #f) (($ $primcall 'free-ref (closure slot))
(($ $primcall 'free-ref (closure slot)) (not (eq? sym slot)))
(not (eq? sym slot))) (($ $primcall 'free-set! (closure slot value))
(($ $primcall 'free-set! (closure slot value)) (not (eq? sym slot)))
(not (eq? sym slot))) (($ $primcall 'cache-current-module! (mod . _))
(($ $primcall 'cache-current-module! (mod . _)) (eq? sym mod))
(eq? sym mod)) (($ $primcall 'cached-toplevel-box _)
(($ $primcall 'cached-toplevel-box _) #f)
#f) (($ $primcall 'cached-module-box _)
(($ $primcall 'cached-module-box _) #f)
#f) (($ $primcall 'resolve (name bound?))
(($ $primcall 'resolve (name bound?)) (eq? sym name))
(eq? sym name)) (($ $primcall 'make-vector/immediate (len init))
(($ $primcall 'make-vector/immediate (len init)) (not (eq? sym len)))
(not (eq? sym len))) (($ $primcall 'vector-ref/immediate (v i))
(($ $primcall 'vector-ref/immediate (v i)) (not (eq? sym i)))
(not (eq? sym i))) (($ $primcall 'vector-set!/immediate (v i x))
(($ $primcall 'vector-set!/immediate (v i x)) (not (eq? sym i)))
(not (eq? sym i))) (($ $primcall 'allocate-struct/immediate (vtable nfields))
(($ $primcall 'allocate-struct/immediate (vtable nfields)) (not (eq? sym nfields)))
(not (eq? sym nfields))) (($ $primcall 'struct-ref/immediate (s n))
(($ $primcall 'struct-ref/immediate (s n)) (not (eq? sym n)))
(not (eq? sym n))) (($ $primcall 'struct-set!/immediate (s n x))
(($ $primcall 'struct-set!/immediate (s n x)) (not (eq? sym n)))
(not (eq? sym n))) (($ $primcall 'builtin-ref (idx))
(($ $primcall 'builtin-ref (idx)) #f)
#f) (_ #t)))
(_ #t))) (vector-ref (dfg-uses dfg) (- sym (dfg-min-var dfg)))))
(vector-ref uses (- sym min-var))))))
(define (continuation-scope-contains? scope-k k dfg) (define (continuation-scope-contains? scope-k k dfg)
(let ((scope-level (lookup-scope-level scope-k dfg))) (let ((scope-level (lookup-scope-level scope-k dfg)))