{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Data.LLVM.CFG
( CFG(..)
, BB
, BBId
, blockId
, blockName
, buildCFG
, dummyExitName
)
where
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative
#endif
import Control.Arrow
import Data.Functor.Identity (runIdentity)
import qualified Data.Graph.Inductive.Query.Dominators as Dom
import qualified Data.Graph.Inductive as G
import qualified Data.Map as M
import Text.LLVM hiding (BB)
import qualified Text.LLVM.Labels as L
newtype BBId = BBId { BBId -> Node
unBBId :: G.Node } deriving (BBId -> BBId -> Bool
(BBId -> BBId -> Bool) -> (BBId -> BBId -> Bool) -> Eq BBId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BBId -> BBId -> Bool
== :: BBId -> BBId -> Bool
$c/= :: BBId -> BBId -> Bool
/= :: BBId -> BBId -> Bool
Eq)
type BB = BasicBlock' (BBId, BlockLabel)
data CFG = CFG
{ CFG -> Gr BB ()
cfgGraph :: G.Gr BB ()
, CFG -> BBId
entryId :: BBId
, CFG -> BBId
exitId :: BBId
, CFG -> [BB]
allBBs :: [BB]
, CFG -> BBId -> BB
bbById :: BBId -> BB
, CFG -> BlockLabel -> BBId
asId :: BlockLabel -> BBId
, CFG -> BBId -> BlockLabel
asName :: BBId -> BlockLabel
, CFG -> BBId -> [BBId]
bbPreds :: BBId -> [BBId]
, CFG -> BBId -> [BBId]
bbSuccs :: BBId -> [BBId]
, CFG -> BBId -> BBId -> Bool
dom :: BBId -> BBId -> Bool
, CFG -> BBId -> Maybe BBId
idom :: BBId -> Maybe BBId
, CFG -> BBId -> BBId -> Bool
pdom :: BBId -> BBId -> Bool
, CFG -> BBId -> Maybe BBId
ipdom :: BBId -> Maybe BBId
, CFG -> [(BBId, [BBId])]
pdoms :: [(BBId, [BBId])]
}
dummyExitName :: String
dummyExitName :: [Char]
dummyExitName = [Char]
"_dummy_exit"
buildCFG :: [BasicBlock] -> CFG
buildCFG :: [BasicBlock] -> CFG
buildCFG [BasicBlock]
bs = CFG
cfg
where
cfg :: CFG
cfg = CFG
{ cfgGraph :: Gr BB ()
cfgGraph = Gr BB ()
gr
, entryId :: BBId
entryId = Node -> BBId
BBId Node
0
, exitId :: BBId
exitId = Node -> BBId
BBId ((Node -> Node) -> (Node -> Node) -> Either Node Node -> Node
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Node -> Node
forall a. a -> a
id Node -> Node
forall a. a -> a
id Either Node Node
exit)
, allBBs :: [BB]
allBBs = Gr BB () -> [Node] -> [BB]
getBBs Gr BB ()
gr (Gr BB () -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
G.nodes Gr BB ()
gr)
, bbById :: BBId -> BB
bbById = \(BBId Node
x) ->
case Context BB () -> BB
bbFromCtx (Context BB () -> BB) -> Maybe (Context BB ()) -> Maybe BB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Context BB ()), Gr BB ()) -> Maybe (Context BB ())
forall a b. (a, b) -> a
fst (Node -> Gr BB () -> (Maybe (Context BB ()), Gr BB ())
forall a b. Node -> Gr a b -> Decomp Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
G.match Node
x Gr BB ()
gr) of
Maybe BB
Nothing -> [Char] -> BB
forall a. HasCallStack => [Char] -> a
error [Char]
"buildCFG: bbById: invalid BBId"
Just BB
bb -> BB
bb
, asId :: BlockLabel -> BBId
asId = \BlockLabel
ident ->
case Node -> BBId
BBId (Node -> BBId) -> Maybe Node -> Maybe BBId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockLabel -> Map BlockLabel Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup BlockLabel
ident Map BlockLabel Node
nodeByName of
Maybe BBId
Nothing -> [Char] -> BBId
forall a. HasCallStack => [Char] -> a
error [Char]
"buildCFG: asId: invalid ident"
Just BBId
bbid -> BBId
bbid
, asName :: BBId -> BlockLabel
asName = \BBId
bbid -> BB -> BlockLabel
blockName (BB -> BlockLabel) -> BB -> BlockLabel
forall a b. (a -> b) -> a -> b
$ CFG -> BBId -> BB
bbById CFG
cfg BBId
bbid
, bbPreds :: BBId -> [BBId]
bbPreds = \(BBId Node
x) -> Node -> BBId
BBId (Node -> BBId) -> [Node] -> [BBId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gr BB () -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
G.pre Gr BB ()
gr Node
x
, bbSuccs :: BBId -> [BBId]
bbSuccs = \(BBId Node
x) -> Node -> BBId
BBId (Node -> BBId) -> [Node] -> [BBId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gr BB () -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
G.suc Gr BB ()
gr Node
x
, dom :: BBId -> BBId -> Bool
dom = \(BBId Node
x) (BBId Node
y) -> [(Node, [Node])] -> Node -> Node -> Bool
forall {t :: * -> *} {a} {a}.
(Foldable t, Eq a, Eq a) =>
[(a, t a)] -> a -> a -> Bool
lkupDom [(Node, [Node])]
domInfo Node
x Node
y
, idom :: BBId -> Maybe BBId
idom = \(BBId Node
x) -> Node -> BBId
BBId (Node -> BBId) -> Maybe Node -> Maybe BBId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> [(Node, Node)] -> Maybe Node
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
x [(Node, Node)]
idomInfo
, pdom :: BBId -> BBId -> Bool
pdom = \(BBId Node
x) (BBId Node
y) -> [(Node, [Node])] -> Node -> Node -> Bool
forall {t :: * -> *} {a} {a}.
(Foldable t, Eq a, Eq a) =>
[(a, t a)] -> a -> a -> Bool
lkupDom [(Node, [Node])]
pdomInfo Node
x Node
y
, ipdom :: BBId -> Maybe BBId
ipdom = \(BBId Node
x) -> Node -> BBId
BBId (Node -> BBId) -> Maybe Node -> Maybe BBId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> [(Node, Node)] -> Maybe Node
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Node
x [(Node, Node)]
ipdomInfo
, pdoms :: [(BBId, [BBId])]
pdoms = ((Node, [Node]) -> (BBId, [BBId]))
-> [(Node, [Node])] -> [(BBId, [BBId])]
forall a b. (a -> b) -> [a] -> [b]
map (Node -> BBId
BBId (Node -> BBId)
-> ([Node] -> [BBId]) -> (Node, [Node]) -> (BBId, [BBId])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Node -> BBId) -> [Node] -> [BBId]
forall a b. (a -> b) -> [a] -> [b]
map Node -> BBId
BBId ([Node] -> [BBId]) -> ([Node] -> [Node]) -> [Node] -> [BBId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Node]
forall a. [a] -> [a]
reverse ([Node] -> [Node]) -> ([Node] -> [Node]) -> [Node] -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node] -> [Node]
forall a. Node -> [a] -> [a]
drop Node
1) [(Node, [Node])]
pdomInfo
}
cdom :: gr a b -> BBId -> ([(Node, [Node])], [(Node, Node)])
cdom gr a b
g (BBId Node
root) = (gr a b -> Node -> [(Node, [Node])]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [(Node, [Node])]
Dom.dom gr a b
g Node
root, gr a b -> Node -> [(Node, Node)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [(Node, Node)]
Dom.iDom gr a b
g Node
root)
([(Node, [Node])]
domInfo, [(Node, Node)]
idomInfo) = Gr BB () -> BBId -> ([(Node, [Node])], [(Node, Node)])
forall {gr :: * -> * -> *} {a} {b}.
Graph gr =>
gr a b -> BBId -> ([(Node, [Node])], [(Node, Node)])
cdom Gr BB ()
gr (CFG -> BBId
entryId CFG
cfg)
([(Node, [Node])]
pdomInfo, [(Node, Node)]
ipdomInfo) = Gr BB () -> BBId -> ([(Node, [Node])], [(Node, Node)])
forall {gr :: * -> * -> *} {a} {b}.
Graph gr =>
gr a b -> BBId -> ([(Node, [Node])], [(Node, Node)])
cdom (Gr BB () -> Gr BB ()
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
G.grev Gr BB ()
gr) (CFG -> BBId
exitId CFG
cfg)
lkupDom :: [(a, t a)] -> a -> a -> Bool
lkupDom [(a, t a)]
info a
x a
y = Bool -> (Bool -> Bool) -> Maybe Bool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Bool -> Bool
forall a. a -> a
id (a -> t a -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x (t a -> Bool) -> Maybe (t a) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [(a, t a)] -> Maybe (t a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
y [(a, t a)]
info)
(Either Node Node
exit, Gr BB ()
gr) = (Node -> BB) -> Gr BB () -> (Either Node Node, Gr BB ())
forall (gr :: * -> * -> *) a.
DynGraph gr =>
(Node -> a) -> gr a () -> (Either Node Node, gr a ())
stitchDummyExit Node -> BB
lab ([LNode BB] -> [LEdge ()] -> Gr BB ()
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
G.mkGraph [LNode BB]
nodes' [LEdge ()]
edges')
where lab :: Node -> BB
lab Node
n = Maybe (BBId, BlockLabel) -> [Stmt' (BBId, BlockLabel)] -> BB
forall lab. Maybe lab -> [Stmt' lab] -> BasicBlock' lab
BasicBlock ((BBId, BlockLabel) -> Maybe (BBId, BlockLabel)
forall a. a -> Maybe a
Just (Node -> BBId
BBId Node
n, Ident -> BlockLabel
Named (Ident -> BlockLabel) -> Ident -> BlockLabel
forall a b. (a -> b) -> a -> b
$ [Char] -> Ident
Ident [Char]
dummyExitName))
[Instr' (BBId, BlockLabel)
-> [([Char], ValMd' (BBId, BlockLabel))]
-> Stmt' (BBId, BlockLabel)
forall lab. Instr' lab -> [([Char], ValMd' lab)] -> Stmt' lab
Effect Instr' (BBId, BlockLabel)
forall lab. Instr' lab
Unreachable []]
nodes' :: [LNode BB]
nodes' = (BB -> LNode BB) -> [BB] -> [LNode BB]
forall a b. (a -> b) -> [a] -> [b]
map (BB -> Node
nodeId (BB -> Node) -> (BB -> BB) -> BB -> LNode BB
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& BB -> BB
forall a. a -> a
id) [BB]
bs'
edges' :: [LEdge ()]
edges' = (BB -> [LEdge ()]) -> [BB] -> [LEdge ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BB -> [LEdge ()]
bbOutEdges [BB]
bs'
bbOutEdges :: BB -> [G.LEdge ()]
bbOutEdges :: BB -> [LEdge ()]
bbOutEdges BB
bb = [(BBId, BlockLabel)] -> [LEdge ()]
forall {b}. [(BBId, b)] -> [LEdge ()]
edgesTo (BB -> [(BBId, BlockLabel)]
forall lab. BasicBlock' lab -> [lab]
brTargets BB
bb)
where
srcId :: Node
srcId = BB -> Node
nodeId BB
bb
edgesTo :: [(BBId, b)] -> [LEdge ()]
edgesTo = ((BBId, b) -> LEdge ()) -> [(BBId, b)] -> [LEdge ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(BBId Node
tgt,b
_) -> Node
srcId Node -> Node -> LEdge ()
`to` Node
tgt)
bs' :: [BB]
(Map BlockLabel (BBId, BlockLabel)
bbIds, [BB]
bs', Node
_, Node
_) = (BasicBlock
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node)
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node))
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node)
-> [BasicBlock]
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BasicBlock
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node)
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node)
relabel (Map BlockLabel (BBId, BlockLabel)
forall k a. Map k a
M.empty, [], [BasicBlock] -> Node
forall a. [a] -> Node
forall (t :: * -> *) a. Foldable t => t a -> Node
length [BasicBlock]
bs Node -> Node -> Node
forall a. Num a => a -> a -> a
- Node
1, Node
0) [BasicBlock]
bs
where
relabel :: BasicBlock
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node)
-> (Map BlockLabel (BBId, BlockLabel), [BB], Node, Node)
relabel (BasicBlock Maybe BlockLabel
mid [Stmt' BlockLabel]
stmts) (Map BlockLabel (BBId, BlockLabel)
mp, [BB]
acc, Node
n, Node
s :: Int) =
let (Node
s', BlockLabel
nm) = case Maybe BlockLabel
mid of
Maybe BlockLabel
Nothing -> (Node
s Node -> Node -> Node
forall a. Num a => a -> a -> a
+ Node
1, Ident -> BlockLabel
Named (Ident -> BlockLabel) -> Ident -> BlockLabel
forall a b. (a -> b) -> a -> b
$ [Char] -> Ident
Ident ([Char] -> Ident) -> [Char] -> Ident
forall a b. (a -> b) -> a -> b
$ [Char]
"__anon_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Node -> [Char]
forall a. Show a => a -> [Char]
show Node
s)
Just BlockLabel
nm' -> (Node
s, BlockLabel
nm')
bbid :: (BBId, BlockLabel)
bbid = (Node -> BBId
BBId Node
n, BlockLabel
nm)
in
( BlockLabel
-> (BBId, BlockLabel)
-> Map BlockLabel (BBId, BlockLabel)
-> Map BlockLabel (BBId, BlockLabel)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert BlockLabel
nm (BBId, BlockLabel)
bbid Map BlockLabel (BBId, BlockLabel)
mp
, Maybe (BBId, BlockLabel) -> [Stmt' (BBId, BlockLabel)] -> BB
forall lab. Maybe lab -> [Stmt' lab] -> BasicBlock' lab
BasicBlock ((BBId, BlockLabel) -> Maybe (BBId, BlockLabel)
forall a. a -> Maybe a
Just (BBId, BlockLabel)
bbid) ([Stmt' BlockLabel] -> [Stmt' (BBId, BlockLabel)]
fixLabels [Stmt' BlockLabel]
stmts) BB -> [BB] -> [BB]
forall a. a -> [a] -> [a]
: [BB]
acc
, Node
n Node -> Node -> Node
forall a. Num a => a -> a -> a
- Node
1
, Node
s'
)
nodeByName :: Map BlockLabel Node
nodeByName = ((BBId, BlockLabel) -> Node)
-> Map BlockLabel (BBId, BlockLabel) -> Map BlockLabel Node
forall a b. (a -> b) -> Map BlockLabel a -> Map BlockLabel b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(BBId Node
n, BlockLabel
_) -> Node
n) Map BlockLabel (BBId, BlockLabel)
bbIds
fixLabels :: [Stmt' BlockLabel] -> [Stmt' (BBId, BlockLabel)]
fixLabels [Stmt' BlockLabel]
stmts = Identity [Stmt' (BBId, BlockLabel)] -> [Stmt' (BBId, BlockLabel)]
forall a. Identity a -> a
runIdentity ((Stmt' BlockLabel -> Identity (Stmt' (BBId, BlockLabel)))
-> [Stmt' BlockLabel] -> Identity [Stmt' (BBId, BlockLabel)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Maybe Symbol -> BlockLabel -> Identity (BBId, BlockLabel))
-> Stmt' BlockLabel -> Identity (Stmt' (BBId, BlockLabel))
forall (f :: * -> *) (m :: * -> *) a b.
(HasLabel f, Applicative m) =>
(Maybe Symbol -> a -> m b) -> f a -> m (f b)
forall (m :: * -> *) a b.
Applicative m =>
(Maybe Symbol -> a -> m b) -> Stmt' a -> m (Stmt' b)
L.relabel Maybe Symbol -> BlockLabel -> Identity (BBId, BlockLabel)
forall {m :: * -> *} {p}.
Monad m =>
p -> BlockLabel -> m (BBId, BlockLabel)
f) [Stmt' BlockLabel]
stmts)
where
f :: p -> BlockLabel -> m (BBId, BlockLabel)
f p
_ BlockLabel
lab = (BBId, BlockLabel) -> m (BBId, BlockLabel)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map BlockLabel (BBId, BlockLabel)
bbIds Map BlockLabel (BBId, BlockLabel)
-> BlockLabel -> (BBId, BlockLabel)
forall k a. Ord k => Map k a -> k -> a
M.! BlockLabel
lab)
bbFromCtx :: G.Context BB () -> BB
bbFromCtx :: Context BB () -> BB
bbFromCtx (Adj ()
_, Node
_, BB
bb, Adj ()
_) = BB
bb
to :: G.Node -> G.Node -> G.LEdge ()
Node
u to :: Node -> Node -> LEdge ()
`to` Node
v = (Node
u, Node
v, ())
requireLabel :: BB -> (BBId, BlockLabel)
requireLabel :: BB -> (BBId, BlockLabel)
requireLabel BB
bb =
case BB -> Maybe (BBId, BlockLabel)
forall lab. BasicBlock' lab -> Maybe lab
bbLabel BB
bb of
Just (BBId, BlockLabel)
lab -> (BBId, BlockLabel)
lab
Maybe (BBId, BlockLabel)
Nothing -> [Char] -> (BBId, BlockLabel)
forall a. HasCallStack => [Char] -> a
error ([Char]
"requireLabel: basic block without a label\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BB -> [Char]
forall a. Show a => a -> [Char]
show BB
bb)
blockId :: BB -> BBId
blockId :: BB -> BBId
blockId = (BBId, BlockLabel) -> BBId
forall a b. (a, b) -> a
fst ((BBId, BlockLabel) -> BBId)
-> (BB -> (BBId, BlockLabel)) -> BB -> BBId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BB -> (BBId, BlockLabel)
requireLabel
blockName :: BB -> BlockLabel
blockName :: BB -> BlockLabel
blockName = (BBId, BlockLabel) -> BlockLabel
forall a b. (a, b) -> b
snd ((BBId, BlockLabel) -> BlockLabel)
-> (BB -> (BBId, BlockLabel)) -> BB -> BlockLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BB -> (BBId, BlockLabel)
requireLabel
nodeId :: BB -> G.Node
nodeId :: BB -> Node
nodeId = BBId -> Node
unBBId (BBId -> Node) -> (BB -> BBId) -> BB -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BB -> BBId
blockId
getBBs :: G.Gr BB () -> [G.Node] -> [BB]
getBBs :: Gr BB () -> [Node] -> [BB]
getBBs Gr BB ()
gr [Node]
ns =
case (Node -> Maybe BB) -> [Node] -> Maybe [BB]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Gr BB () -> Node -> Maybe BB
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
G.lab Gr BB ()
gr) [Node]
ns of
Just [BB]
bbs -> [BB]
bbs
Maybe [BB]
Nothing -> [Char] -> [BB]
forall a. HasCallStack => [Char] -> a
error [Char]
"internal: encountered unlabeled node"
newNode :: G.Graph gr => gr a b -> G.Node
newNode :: forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node
newNode = [Node] -> Node
forall a. HasCallStack => [a] -> a
head ([Node] -> Node) -> (gr a b -> [Node]) -> gr a b -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> gr a b -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> [Node]
G.newNodes Node
1
exitNodes :: G.DynGraph gr => gr a b -> [G.Node]
exitNodes :: forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> [Node]
exitNodes gr a b
gr = (Context a b -> Node) -> [Context a b] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Context a b -> Node
forall a b. Context a b -> Node
G.node' ([Context a b] -> [Node]) -> [Context a b] -> [Node]
forall a b. (a -> b) -> a -> b
$ (Context a b -> Bool) -> gr a b -> [Context a b]
forall (gr :: * -> * -> *) a b.
Graph gr =>
(Context a b -> Bool) -> gr a b -> [Context a b]
G.gsel ([Node] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Node] -> Bool) -> (Context a b -> [Node]) -> Context a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. gr a b -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
G.suc gr a b
gr (Node -> [Node]) -> (Context a b -> Node) -> Context a b -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context a b -> Node
forall a b. Context a b -> Node
G.node') gr a b
gr
stitchDummyExit :: G.DynGraph gr =>
(G.Node -> a) -> gr a () -> (Either G.Node G.Node, gr a ())
stitchDummyExit :: forall (gr :: * -> * -> *) a.
DynGraph gr =>
(Node -> a) -> gr a () -> (Either Node Node, gr a ())
stitchDummyExit Node -> a
exitLabelF gr a ()
gr = case gr a () -> [Node]
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> [Node]
exitNodes gr a ()
gr of
[] -> [Char] -> (Either Node Node, gr a ())
forall a. HasCallStack => [Char] -> a
error [Char]
"internal: input graph contains no exit nodes"
[Node
n] -> (Node -> Either Node Node
forall a b. a -> Either a b
Left Node
n, gr a ()
gr)
[Node]
exits ->
let new :: Node
new = gr a () -> Node
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node
newNode gr a ()
gr
!g0 :: gr a ()
g0 = LNode a -> gr a () -> gr a ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
G.insNode (Node
new, Node -> a
exitLabelF Node
new) gr a ()
gr
!g1 :: gr a ()
g1 = (LEdge () -> gr a () -> gr a ())
-> gr a () -> [LEdge ()] -> gr a ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LEdge () -> gr a () -> gr a ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
G.insEdge gr a ()
g0 ([LEdge ()] -> gr a ()) -> [LEdge ()] -> gr a ()
forall a b. (a -> b) -> a -> b
$ (Node -> LEdge ()) -> [Node] -> [LEdge ()]
forall a b. (a -> b) -> [a] -> [b]
map (Node -> Node -> LEdge ()
`to` Node
new) [Node]
exits
in (Node -> Either Node Node
forall a b. b -> Either a b
Right Node
new, gr a ()
g1)
instance Show CFG where
show :: CFG -> [Char]
show CFG
cfg = [[Char]] -> [Char]
unlines [ [Char]
"Entry : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BBId -> [Char]
forall a. Show a => a -> [Char]
show (CFG -> BBId
entryId CFG
cfg)
, [Char]
"Exit : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BBId -> [Char]
forall a. Show a => a -> [Char]
show (CFG -> BBId
exitId CFG
cfg)
, [Char]
"Graph : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ( [[Char]] -> [Char]
unlines
([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
s -> Node -> Char -> [Char]
forall a. Node -> a -> [a]
replicate Node
8 Char
' ' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s)
([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Gr BB () -> [Char]
forall a. Show a => a -> [Char]
show (CFG -> Gr BB ()
cfgGraph CFG
cfg)
)
]
instance Show BBId where show :: BBId -> [Char]
show (BBId Node
n) = [Char]
"BB#" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Node -> [Char]
forall a. Show a => a -> [Char]
show Node
n