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

add lookup-block-scope

Browse source 
* module/language/cps/dfg.scm (lookup-block-scope): New interface.
  (visit-fun): Give a bit more info if link-blocks! fails.
This commit is contained in:
Andy Wingo 2013-10-21 16:32:36 +02:00
parent bc01d8f7e0
commit c8ad7426e2
1 changed files with 5 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -50,6 +50,7 @@
lookup-uses lookup-uses
lookup-predecessors lookup-predecessors
lookup-successors lookup-successors
lookup-block-scope
find-call find-call
call-expression call-expression
find-expression find-expression
@ -599,7 +600,7 @@
(let ((pred-block (hashq-ref blocks pred)) (let ((pred-block (hashq-ref blocks pred))
(succ-block (hashq-ref blocks succ))) (succ-block (hashq-ref blocks succ)))
(unless (and pred-block succ-block) (unless (and pred-block succ-block)
(error "internal error")) (error "internal error" pred-block succ-block))
(set-block-succs! pred-block (cons succ (block-succs pred-block))) (set-block-succs! pred-block (cons succ (block-succs pred-block)))
(set-block-preds! succ-block (cons pred (block-preds succ-block))))) (set-block-preds! succ-block (cons pred (block-preds succ-block)))))
@ -727,6 +728,9 @@
(($ $use-map name sym def uses) (($ $use-map name sym def uses)
uses))))) uses)))))
(define (lookup-block-scope k dfg)
(block-scope (lookup-block k (dfg-blocks dfg))))
(define (lookup-predecessors k dfg) (define (lookup-predecessors k dfg)
(match (lookup-block k (dfg-blocks dfg)) (match (lookup-block k (dfg-blocks dfg))
(($ $block _ _ preds succs) preds))) (($ $block _ _ preds succs) preds)))