{- |
Module           : $Header$
Description      : LLVM control flow graphs and related utilities
Stability        : provisional
Point-of-contact : jstanley
-}
{-# 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

-- import Debug.Trace

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)

-- | The control-flow graph for LLVM functions
data CFG = CFG
  { CFG -> Gr BB ()
cfgGraph :: G.Gr BB ()
  -- | The @BBId@ of the entry node in the control-flow graph
  , CFG -> BBId
entryId :: BBId
  -- | The @BBId@ of the exit node from the control-flow graph
  , CFG -> BBId
exitId :: BBId
  -- | All basic blocks in the CFG
  , CFG -> [BB]
allBBs :: [BB]
  -- | Obtain a basic block from a @BBId@ (runtime error if it DNE)
  , CFG -> BBId -> BB
bbById :: BBId -> BB
  -- | Obtain the @BBId@ of a block from its name (runtime error if it DNE)
  , CFG -> BlockLabel -> BBId
asId :: BlockLabel -> BBId
  -- | Obtain the name of a block from a @BBId@ (runtime error if it DNE)
  , CFG -> BBId -> BlockLabel
asName :: BBId -> BlockLabel
  -- | Obtain all predecessor basic blocks from a @BBId@
  , CFG -> BBId -> [BBId]
bbPreds :: BBId -> [BBId]
  -- | Obtain all successor basic blocks from a @BBId@
  , CFG -> BBId -> [BBId]
bbSuccs :: BBId -> [BBId]
  -- | @dom x y@ yields True iff x dominates y in the CFG (i.e., all paths from
  -- the entry node to y must pass through x)
  , CFG -> BBId -> BBId -> Bool
dom :: BBId -> BBId -> Bool
  -- | @idom x@ yields the unique immediate dominator of x in the CFG
  -- (intuitively, the "nearest" dominator of x; formally, y immediately
  -- dominates x iff y dominates x and there is no intervening block z such that
  -- y dominates z and z dominates x).  The entry node has no immediate
  -- dominator.
  , CFG -> BBId -> Maybe BBId
idom :: BBId -> Maybe BBId
    -- | @pdom x y@ yields True iff x postdominates y in the CFG (i.e., all
    -- paths in the CFG from y to the exit node pass through x)
  , CFG -> BBId -> BBId -> Bool
pdom :: BBId -> BBId -> Bool
    -- | @ipdom x@ yields the unique immediate postdominator of x in the CFG
    -- (intuitively, the "nearest" postdominator; formally, y immediately
    -- postdominates x iff y postdominates x and there is no intervening block z
    -- such that y postdominates z and z postdominates x).  The exit node has no
    -- immediate postdominator.
  , CFG -> BBId -> Maybe BBId
ipdom :: BBId -> Maybe BBId
    -- | @pdom@ yields post-dominator analysis for the entire CFG; the resulting
    -- list associates each node with a list of its postdominators.  The
    -- postdominator list is sorted in order of ascending immediacy; i.e., the
    -- last element of the list associated with a node @n@ is @n@'s immediate
    -- dominator, the penultimate element of the list is the immediate
    -- postdominator of @n@'s immediate postdominator, and so forth.  NB: note
    -- the postdominator lists do not explicitly reflect that a node
    -- postdominates itself.
  , CFG -> [(BBId, [BBId])]
pdoms :: [(BBId, [BBId])]
  }

dummyExitName :: String
dummyExitName :: [Char]
dummyExitName = [Char]
"_dummy_exit"

-- | Builds the control-flow graph of a function.  Assumes that the entry node
-- is the first basic block in the list. Note that when multiple exit nodes are
-- present in the list, they will all end up connected to a single, unique
-- "dummy" exit node.  Note, also, that the CFG basic blocks are of type
-- @BasicBlock' (BBId, Ident)@; that is, they are all named, which is not the
-- case with the input BBs.  It is expected that clients use these versions of
-- the basic blocks rather than those that are passed in.
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
          }

    -- Dominance and post-dominance relations
    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)

    -- Graph construction
    (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)

    -- Relabeling and aux data structures; note that unnamed basic blocks get a
    -- generated name here so that clients don't have to deal with extraneous
    -- checks.
    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) =
--           trace ("relabel: mid = " ++ show mid)
--           $
          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
      -- This should be fine, as there shouldn't be references to labels that
      -- aren't defined.
      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)


--------------------------------------------------------------------------------
-- Utility functions

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 labf gr@ adds to graph @gr@ a dummy terminal node with a
-- caller-generated label (parameterized by the new exit node id) and connects
-- all other terminal nodes to it, if needed.  The first element of the returned
-- tuple is the id of the exit node (Left: already present, Right: added). The
-- second element of the returned tuple is the (un)modified graph.

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