mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-30 00:40:20 +02:00
Rewrite control-point? to avoid consing
* module/language/cps/dfg.scm (control-point?): Rewrite to avoid consing a successors list.
This commit is contained in:
parent
4bf757b810
commit
a3a45279c0
1 changed files with 19 additions and 4 deletions
|
@ -1053,13 +1053,28 @@ BODY for each body continuation in the prompt."
|
||||||
(lookup-uses var dfg)))
|
(lookup-uses var dfg)))
|
||||||
|
|
||||||
;; A continuation is a control point if it has multiple predecessors, or
|
;; A continuation is a control point if it has multiple predecessors, or
|
||||||
;; if its single predecessor has multiple successors.
|
;; if its single predecessor does not have a single successor.
|
||||||
(define (control-point? k dfg)
|
(define (control-point? k dfg)
|
||||||
(match (lookup-predecessors k dfg)
|
(match (lookup-predecessors k dfg)
|
||||||
((pred)
|
((pred)
|
||||||
(match (lookup-successors pred dfg)
|
(match (vector-ref (dfg-cont-table dfg) (- pred (dfg-min-label dfg)))
|
||||||
((_) #f)
|
(($ $kargs names syms body)
|
||||||
(_ #t)))
|
(let lp ((body body))
|
||||||
|
(match body
|
||||||
|
(($ $letk conts body) (lp body))
|
||||||
|
(($ $letrec names vars funs body) (lp body))
|
||||||
|
(($ $continue k src exp)
|
||||||
|
(match exp
|
||||||
|
(($ $prompt) #t)
|
||||||
|
(_ #f))))))
|
||||||
|
(($ $kif) #t)
|
||||||
|
(($ $kreceive) #f)
|
||||||
|
(($ $kclause) #f)
|
||||||
|
(($ $kentry self tail clauses)
|
||||||
|
(match clauses
|
||||||
|
((_) #t)
|
||||||
|
(_ #f)))
|
||||||
|
(($ $ktail) #t)))
|
||||||
(_ #t)))
|
(_ #t)))
|
||||||
|
|
||||||
(define (lookup-bound-syms k dfg)
|
(define (lookup-bound-syms k dfg)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue