module LLVM.Analysis.CFG.Internal (
CFG(..),
HasCFG(..),
controlFlowGraph,
basicBlockPredecessors,
basicBlockSuccessors,
DataflowAnalysis(..),
fwdDataflowAnalysis,
bwdDataflowAnalysis,
fwdDataflowEdgeAnalysis,
bwdDataflowEdgeAnalysis,
dataflow,
DataflowResult(..),
dataflowResult,
dataflowResultAt,
Insn(..),
) where
import Compiler.Hoopl
import Control.DeepSeq
import Control.Monad ( (>=>), (<=<) )
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Function ( on )
import qualified Data.GraphViz as GV
import qualified Data.List as L
import Data.Map ( Map )
import qualified Data.Map as M
import Data.Maybe ( fromMaybe, mapMaybe )
import Data.Monoid
import Data.Set ( Set )
import qualified Data.Set as S
import Data.Tuple ( swap )
import qualified Text.PrettyPrint.GenericPretty as PP
import LLVM.Analysis
class HasCFG a where
getCFG :: a -> CFG
instance HasCFG CFG where
getCFG = id
instance HasCFG Function where
getCFG = controlFlowGraph
instance HasFunction CFG where
getFunction = cfgFunction
instance FuncLike CFG where
fromFunction = controlFlowGraph
data CFG = CFG { cfgFunction :: Function
, cfgLabelMap :: Map BasicBlock Label
, cfgBlockMap :: Map Label BasicBlock
, cfgBody :: Graph Insn C C
, cfgEntryLabel :: Label
, cfgExitLabel :: Label
, cfgPredecessors :: Map BasicBlock [BasicBlock]
}
instance Eq CFG where
(==) = on (==) cfgFunction
data Insn e x where
Lbl :: BasicBlock -> Label -> Insn C O
Terminator :: Instruction -> [Label] -> Insn O C
UniqueExitLabel :: Label -> Insn C O
UniqueExit :: Insn O C
Normal :: Instruction -> Insn O O
instance NonLocal Insn where
entryLabel (Lbl _ lbl) = lbl
entryLabel (UniqueExitLabel lbl) = lbl
successors (Terminator _ lbls) = lbls
successors UniqueExit = []
instance Show (Insn e x) where
show (Lbl bb _) = identifierAsString (basicBlockName bb) ++ ":"
show (Terminator t _) = " " ++ show t
show (Normal i) = " " ++ show i
show (UniqueExitLabel _) = "UniqueExit:"
show UniqueExit = " done"
controlFlowGraph :: Function -> CFG
controlFlowGraph f = runSimpleUniqueMonad (evalStateT builder mempty)
where
builder = do
exitLabel <- lift $ freshLabel
gs <- mapM (fromBlock exitLabel) (functionBody f)
let g = L.foldl' (|*><*|) emptyClosedGraph gs
x = mkFirst (UniqueExitLabel exitLabel) <*> mkLast UniqueExit
g' = g |*><*| x
m <- get
let i0 = functionEntryInstruction f
Just bb0 = instructionBasicBlock i0
Just fEntryLabel = M.lookup bb0 m
cfg = CFG { cfgFunction = f
, cfgBody = g'
, cfgLabelMap = m
, cfgBlockMap = M.fromList $ map swap $ M.toList m
, cfgEntryLabel = fEntryLabel
, cfgExitLabel = exitLabel
, cfgPredecessors = mempty
}
preds = foldr (recordPreds cfg) mempty (functionBody f)
return $ cfg { cfgPredecessors = fmap S.toList preds }
addPred pblock b =
M.insertWith S.union b (S.singleton pblock)
recordPreds cfg bb acc =
let succs = basicBlockSuccessors cfg bb
in foldr (addPred bb) acc succs
type Builder a = StateT (Map BasicBlock Label) SimpleUniqueMonad a
blockLabel :: BasicBlock -> Builder Label
blockLabel bb = do
m <- get
case M.lookup bb m of
Just l -> return l
Nothing -> do
l <- lift $ freshLabel
put $ M.insert bb l m
return l
fromBlock :: Label -> BasicBlock -> Builder (Graph Insn C C)
fromBlock xlabel bb = do
lbl <- blockLabel bb
let body = basicBlockInstructions bb
(body', [term]) = L.splitAt (length body 1) body
normalNodes = map Normal body'
tlbls <- terminatorLabels xlabel term
let termNode = Terminator term tlbls
entry = Lbl bb lbl
return $ mkFirst entry <*> mkMiddles normalNodes <*> mkLast termNode
terminatorLabels :: Label -> Instruction -> Builder [Label]
terminatorLabels xlabel i =
case i of
RetInst {} -> return [xlabel]
UnconditionalBranchInst { unconditionalBranchTarget = t } -> do
bl <- blockLabel t
return [bl]
BranchInst { branchTrueTarget = tt, branchFalseTarget = ft } -> do
tl <- blockLabel tt
fl <- blockLabel ft
return [tl, fl]
SwitchInst { switchDefaultTarget = dt, switchCases = (map snd -> ts) } -> do
dl <- blockLabel dt
tls <- mapM blockLabel ts
return $ dl : tls
IndirectBranchInst { indirectBranchTargets = ts } ->
mapM blockLabel ts
ResumeInst {} -> return [xlabel]
UnreachableInst {} -> return [xlabel]
InvokeInst { invokeNormalLabel = nt, invokeUnwindLabel = ut } -> do
nl <- blockLabel nt
ul <- blockLabel ut
return [nl, ul]
_ -> error "LLVM.Analysis.CFG.successors: non-terminator instruction"
basicBlockPredecessors :: (HasCFG cfgLike) => cfgLike -> BasicBlock -> [BasicBlock]
basicBlockPredecessors cfgLike bb =
fromMaybe [] $ M.lookup bb (cfgPredecessors cfg)
where
cfg = getCFG cfgLike
basicBlockSuccessors :: (HasCFG cfgLike) => cfgLike -> BasicBlock -> [BasicBlock]
basicBlockSuccessors cfgLike bb = case cfgBody cfg of
GMany _ lm _ -> fromMaybe [] $ do
blbl <- basicBlockToLabel cfg bb
blk <- mapLookup blbl lm
return $ mapMaybe (labelToBasicBlock cfg) (successors blk)
where
cfg = getCFG cfgLike
basicBlockToLabel :: CFG -> BasicBlock -> Maybe Label
basicBlockToLabel cfg bb = M.lookup bb (cfgLabelMap cfg)
labelToBasicBlock :: CFG -> Label -> Maybe BasicBlock
labelToBasicBlock cfg l = M.lookup l (cfgBlockMap cfg)
cfgGraphvizParams :: GV.GraphvizParams n Instruction CFGEdge BasicBlock Instruction
cfgGraphvizParams =
GV.defaultParams { GV.fmtNode = \(_,l) -> [GV.toLabel (toValue l)]
, GV.fmtEdge = formatEdge
, GV.clusterID = GV.Int . basicBlockUniqueId
, GV.fmtCluster = formatCluster
, GV.clusterBy = nodeCluster
}
where
nodeCluster l@(_, i) =
let Just bb = instructionBasicBlock i
in GV.C bb (GV.N l)
formatCluster bb = [GV.GraphAttrs [GV.toLabel (show (basicBlockName bb))]]
formatEdge (_, _, l) =
let lbl = GV.toLabel l
in case l of
TrueEdge -> [lbl, GV.color GV.ForestGreen]
FalseEdge -> [lbl, GV.color GV.Crimson]
EqualityEdge _ -> [lbl, GV.color GV.DeepSkyBlue]
IndirectEdge -> [lbl, GV.color GV.Indigo, GV.style GV.dashed]
UnwindEdge -> [lbl, GV.color GV.Tomato4, GV.style GV.dotted]
OtherEdge -> [lbl]
data CFGEdge = TrueEdge
| FalseEdge
| EqualityEdge Value
| IndirectEdge
| UnwindEdge
| OtherEdge
deriving (Eq, Show)
instance GV.Labellable CFGEdge where
toLabelValue TrueEdge = GV.toLabelValue "True"
toLabelValue FalseEdge = GV.toLabelValue "False"
toLabelValue (EqualityEdge v) = GV.toLabelValue ("== " ++ show v)
toLabelValue IndirectEdge = GV.toLabelValue "Indirect"
toLabelValue UnwindEdge = GV.toLabelValue "Unwind"
toLabelValue OtherEdge = GV.toLabelValue ""
instance ToGraphviz CFG where
toGraphviz = cfgGraphvizRepr
cfgGraphvizRepr :: CFG -> GV.DotGraph Int
cfgGraphvizRepr cfg = GV.graphElemsToDot cfgGraphvizParams ns es
where
f = getFunction cfg
ns = map toGNode (functionInstructions f)
es = concatMap toEdges (functionBody f)
toEdges :: BasicBlock -> [(Int, Int, CFGEdge)]
toEdges bb =
case ti of
RetInst {} -> intraEdges
UnreachableInst {} -> intraEdges
UnconditionalBranchInst { unconditionalBranchTarget = t } ->
let (ei:_) = basicBlockInstructions t
in (instructionUniqueId ti, instructionUniqueId ei, OtherEdge) : intraEdges
BranchInst { branchTrueTarget = tt, branchFalseTarget = ft } ->
let (tei:_) = basicBlockInstructions tt
(fei:_) = basicBlockInstructions ft
in (instructionUniqueId ti, instructionUniqueId tei, TrueEdge) :
(instructionUniqueId ti, instructionUniqueId fei, FalseEdge) :
intraEdges
SwitchInst { switchDefaultTarget = dt, switchCases = cases } ->
let (dei:_) = basicBlockInstructions dt
caseNodes = map toCaseNode cases
in (instructionUniqueId ti, instructionUniqueId dei, OtherEdge):caseNodes ++ intraEdges
IndirectBranchInst { indirectBranchTargets = bs } ->
map toIndirectEdge bs ++ intraEdges
ResumeInst {} -> intraEdges
InvokeInst { invokeUnwindLabel = ul, invokeNormalLabel = nl } ->
let (nei:_) = basicBlockInstructions nl
(uei:_) = basicBlockInstructions ul
in (instructionUniqueId ti, instructionUniqueId nei, OtherEdge):
(instructionUniqueId ti, instructionUniqueId uei, UnwindEdge):
intraEdges
_ -> error "Not a terminator instruction"
where
is@(_:rest) = basicBlockInstructions bb
intraEdges = map toIntraEdge (zip is rest)
toIntraEdge (s,d) = (instructionUniqueId s, instructionUniqueId d, OtherEdge)
ti = basicBlockTerminatorInstruction bb
toIndirectEdge tgt =
let (ei:_) = basicBlockInstructions tgt
in (instructionUniqueId ti, instructionUniqueId ei, IndirectEdge)
toCaseNode (val, tgt) =
let (ei:_) = basicBlockInstructions tgt
in (instructionUniqueId ti, instructionUniqueId ei, EqualityEdge val)
toGNode :: Instruction -> (Int, Instruction)
toGNode i = (instructionUniqueId i, i)
data DataflowAnalysis m f where
FwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f
, analysisMeet :: f -> f -> f
, analysisTransfer :: f -> Instruction -> m f
, analysisFwdEdgeTransfer :: Maybe (f -> Instruction -> m [(BasicBlock, f)])
} -> DataflowAnalysis m f
BwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f
, analysisMeet :: f -> f -> f
, analysisTransfer :: f -> Instruction -> m f
, analysisBwdEdgeTransfer :: Maybe ([(BasicBlock, f)] -> Instruction -> m f)
} -> DataflowAnalysis m f
fwdDataflowAnalysis :: (Eq f, Monad m)
=> f
-> (f -> f -> f)
-> (f -> Instruction -> m f)
-> DataflowAnalysis m f
fwdDataflowAnalysis top m t = FwdDataflowAnalysis top m t Nothing
bwdDataflowAnalysis :: (Eq f, Monad m)
=> f
-> (f -> f -> f)
-> (f -> Instruction -> m f)
-> DataflowAnalysis m f
bwdDataflowAnalysis top m t = BwdDataflowAnalysis top m t Nothing
fwdDataflowEdgeAnalysis :: (Eq f, Monad m)
=> f
-> (f -> f -> f)
-> (f -> Instruction -> m f)
-> (f -> Instruction -> m [(BasicBlock, f)])
-> DataflowAnalysis m f
fwdDataflowEdgeAnalysis top m t e =
FwdDataflowAnalysis top m t (Just e)
bwdDataflowEdgeAnalysis :: (Eq f, Monad m)
=> f
-> (f -> f -> f)
-> (f -> Instruction -> m f)
-> ([(BasicBlock, f)] -> Instruction -> m f)
-> DataflowAnalysis m f
bwdDataflowEdgeAnalysis top m t e =
BwdDataflowAnalysis top m t (Just e)
data DataflowResult m f where
DataflowResult :: CFG
-> DataflowAnalysis m f
-> Fact C f
-> Direction
-> DataflowResult m f
instance (Show f) => Show (DataflowResult m f) where
show (DataflowResult _ _ fb _) =
PP.pretty (map (\(f,s) -> (show f, show s)) (mapToList fb))
instance (Eq f) => Eq (DataflowResult m f) where
(DataflowResult c1 _ m1 d1) == (DataflowResult c2 _ m2 d2) =
c1 == c2 && m1 == m2 && d1 == d2
instance (NFData f) => NFData (DataflowResult m f) where
rnf _ = ()
dataflowResultAt :: DataflowResult m f
-> Instruction
-> m f
dataflowResultAt (DataflowResult cfg (FwdDataflowAnalysis top meet transfer _) m dir) i = do
let Just bb = instructionBasicBlock i
Just lbl = M.lookup bb (cfgLabelMap cfg)
initialFactAndInsts = findInitialFact bb lbl dir
case initialFactAndInsts of
Nothing -> return top
Just (bres, is) -> replayTransfer is bres
where
findInitialFact bb lbl Fwd = do
f0 <- lookupFact lbl m
return (f0, basicBlockInstructions bb)
findInitialFact bb _ Bwd =
case basicBlockSuccessors cfg bb of
[] -> do
f0 <- lookupFact (cfgExitLabel cfg) m
return (f0, reverse (basicBlockInstructions bb))
ss -> do
let trBlock b = do
l <- basicBlockToLabel cfg b
lookupFact l m
f0 = foldr meet top (mapMaybe trBlock ss)
return (f0, reverse (basicBlockInstructions bb))
replayTransfer [] _ = error "LLVM.Analysis.Dataflow.dataflowResult: replayed past end of block, impossible"
replayTransfer (thisI:rest) r
| thisI == i = transfer r i
| otherwise = do
r' <- transfer r thisI
replayTransfer rest r'
dataflowResult :: DataflowResult m f -> f
dataflowResult (DataflowResult cfg (FwdDataflowAnalysis top _ _ _) m _) =
fromMaybe top $ lookupFact (cfgExitLabel cfg) m
dataflowResult (DataflowResult cfg (BwdDataflowAnalysis top _ _ _) m _) =
fromMaybe top $ lookupFact (cfgEntryLabel cfg) m
dataflow :: forall m f cfgLike . (HasCFG cfgLike)
=> cfgLike
-> DataflowAnalysis m f
-> f
-> m (DataflowResult m f)
dataflow cfgLike da@FwdDataflowAnalysis { analysisTop = top
, analysisMeet = meet
, analysisTransfer = transfer
, analysisFwdEdgeTransfer = etransfer
} fact0 = do
r <- graph (cfgBody cfg) (mapSingleton elbl fact0)
return $ DataflowResult cfg da r Fwd
where
cfg = getCFG cfgLike
elbl = cfgEntryLabel cfg
entryPoints = [elbl]
graph :: Graph Insn C C -> Fact C f -> m (Fact C f)
graph (GMany e bdy x) = (e `ebcat` bdy) >=> exit x
where
exit :: MaybeO x (Block Insn C O) -> Fact C f -> m (Fact x f)
exit (JustO blk) = arfx block blk
exit NothingO = return
ebcat entry cbdy = c entryPoints entry
where
c :: [Label] -> MaybeO e (Block Insn O C)
-> Fact e f -> m (Fact C f)
c eps NothingO = body eps cbdy
c _ _ = error "Bogus GADT pattern match failure"
arfx :: forall thing x . (NonLocal thing)
=> (thing C x -> f -> m (Fact x f))
-> (thing C x -> Fact C f -> m (Fact x f))
arfx arf thing fb = arf thing f'
where
Just f' = lookupFact (entryLabel thing) fb
body :: [Label]
-> LabelMap (Block Insn C C)
-> Fact C f
-> m (Fact C f)
body bentries blockmap initFbase =
fixpoint Fwd da doBlock bentries blockmap initFbase
where
doBlock :: forall x . Block Insn C x -> FactBase f -> m (Fact x f)
doBlock b fb = block b entryFact
where
entryFact = fromMaybe top $ lookupFact (entryLabel b) fb
node :: forall e x . Insn e x -> f -> m (Fact x f)
node (Lbl _ _) f = return f
node (UniqueExitLabel _) f = return f
node (Normal i) f = transfer f i
node (Terminator i lbls) f = do
f' <- transfer f i
let baseResult = mapFromList $ zip lbls (repeat f')
case etransfer of
Nothing -> return baseResult
Just etransfer' -> do
blockOuts <- etransfer' f' i
let res = foldr (addBlockEdgeResult lbls) mapEmpty blockOuts
return $ mapUnion res (mapDeleteList (mapKeys res) baseResult)
node UniqueExit _ = return mapEmpty
addBlockEdgeResult :: [Label] -> (BasicBlock, f) -> FactBase f -> FactBase f
addBlockEdgeResult lbls (bb, res) acc
| Just lbl <- basicBlockToLabel cfg bb, lbl `elem` lbls =
case mapLookup lbl acc of
Nothing -> mapInsert lbl res acc
Just ex -> mapInsert lbl (meet res ex) acc
| otherwise = acc
block :: Block Insn e x -> f -> m (Fact x f)
block BNil = return
block (BlockCO l b) = node l >=> block b
block (BlockCC l b n) = node l >=> block b >=> node n
block (BlockOC b n) = block b >=> node n
block (BMiddle n) = node n
block (BCat b1 b2) = block b1 >=> block b2
block (BSnoc h n) = block h >=> node n
block (BCons n t) = node n >=> block t
dataflow cfgLike da@BwdDataflowAnalysis { analysisTop = top
, analysisMeet = meet
, analysisTransfer = transfer
} fact0 = do
r <- graph (cfgBody cfg) (mapSingleton xlbl fact0)
return $ DataflowResult cfg da r Bwd
where
cfg = getCFG cfgLike
xlbl = cfgExitLabel cfg
entryPoints = [xlbl]
graph :: Graph Insn C C -> Fact C f -> m (Fact C f)
graph (GMany e bdy x) = (e `ebcat` bdy) <=< exit x
where
exit :: MaybeO x (Block Insn C O) -> Fact C f -> m (Fact x f)
exit (JustO blk) = arbx block blk
exit NothingO = return
ebcat entry cbdy = c entryPoints entry
where
c :: [Label] -> MaybeO e (Block Insn O C)
-> Fact e f -> m (Fact C f)
c eps NothingO = body eps cbdy
c _ _ = error "Bogus GADT pattern match failure"
arbx :: forall thing x . (NonLocal thing)
=> (thing C x -> f -> m (Fact x f))
-> (thing C x -> Fact C f -> m (Fact x f))
arbx arf thing fb = arf thing f'
where
Just f' = lookupFact (entryLabel thing) fb
body :: [Label]
-> LabelMap (Block Insn C C)
-> Fact C f
-> m (Fact C f)
body bentries blockmap initFbase =
fixpoint Bwd da doBlock (map entryLabel (backwardBlockList bentries blockmap)) blockmap initFbase
where
doBlock :: forall x . Block Insn C x -> Fact x f -> m (LabelMap f)
doBlock b fb = do
f <- block b fb
return $ mapSingleton (entryLabel b) f
node :: forall e x . Insn e x -> Fact x f -> m f
node (Lbl _ _) f = return f
node (UniqueExitLabel _) f = return f
node (Normal i) f = transfer f i
node (Terminator i lbls) fbase = do
let fs = mapMaybe (\l -> lookupFact l fbase) lbls
f = foldr meet top fs
transfer f i
node UniqueExit fbase =
return $ foldr meet top (mapElems fbase)
block :: Block Insn e x -> Fact x f -> m f
block BNil = return
block (BlockCO l b) = node l <=< block b
block (BlockCC l b n) = node l <=< block b <=< node n
block (BlockOC b n) = block b <=< node n
block (BMiddle n) = node n
block (BCat b1 b2) = block b1 <=< block b2
block (BSnoc h n) = block h <=< node n
block (BCons n t) = node n <=< block t
forwardBlockList :: (NonLocal n, LabelsPtr entry)
=> entry -> Body n -> [Block n C C]
forwardBlockList entries blks = postorder_dfs_from blks entries
backwardBlockList :: (NonLocal n, LabelsPtr entries)
=> entries -> Body n -> [Block n C C]
backwardBlockList entries body = reverse $ forwardBlockList entries body
data Direction = Fwd | Bwd
deriving (Eq)
dataflowMeet :: DataflowAnalysis m f -> (f -> f -> f)
dataflowMeet FwdDataflowAnalysis { analysisMeet = m } = m
dataflowMeet BwdDataflowAnalysis { analysisMeet = m } = m
fixpoint :: forall m f . (Monad m, Eq f)
=> Direction
-> DataflowAnalysis m f
-> (Block Insn C C -> Fact C f -> m (Fact C f))
-> [Label]
-> LabelMap (Block Insn C C)
-> (Fact C f -> m (Fact C f))
fixpoint dir da doBlock entries blockmap initFbase =
loop initFbase entries mempty
where
meet = dataflowMeet da
depBlocks :: LabelMap [Label]
depBlocks = mapFromListWith (++) [ (l, [entryLabel b])
| b <- mapElems blockmap
, l <- case dir of
Fwd -> [entryLabel b]
Bwd -> successors b
]
loop :: FactBase f -> [Label] -> Set Label -> m (FactBase f)
loop fbase [] _ = return fbase
loop fbase (lbl:todo) visited =
case mapLookup lbl blockmap of
Nothing -> loop fbase todo (S.insert lbl visited)
Just blk -> do
outFacts <- doBlock blk fbase
let (changed, fbase') = mapFoldWithKey (updateFact visited) ([], fbase) outFacts
depLookup l = mapFindWithDefault [] l depBlocks
toAnalyze = filter (`notElem` todo) $ concatMap depLookup changed
loop fbase' (todo ++ toAnalyze) (S.insert lbl visited)
updateFact :: Set Label
-> Label
-> f
-> ([Label], FactBase f)
-> ([Label], FactBase f)
updateFact visited lbl newFact acc@(cha, fbase) =
case lookupFact lbl fbase of
Nothing -> (lbl:cha, mapInsert lbl newFact fbase)
Just oldFact ->
let fact' = oldFact `meet` newFact
in case fact' == oldFact && S.member lbl visited of
True -> acc
False -> (lbl:cha, mapInsert lbl fact' fbase)