{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE ExistentialQuantification, GADTs #-} {-# LANGUAGE ViewPatterns, ScopedTypeVariables, PatternGuards #-} module LLVM.Analysis.CFG.Internal ( -- * CFG CFG(..), HasCFG(..), controlFlowGraph, basicBlockPredecessors, basicBlockSuccessors, -- * Dataflow DataflowAnalysis(..), fwdDataflowAnalysis, bwdDataflowAnalysis, fwdDataflowEdgeAnalysis, bwdDataflowEdgeAnalysis, dataflow, DataflowResult(..), dataflowResult, dataflowResultAt, -- * Internal types 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 -- CFG stuff -- | A class for things from which a CFG can be obtained. 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 -- | The type of function control flow graphs. 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] } -- See Note [CFG Back Edges] {- Note [CFG Back Edges] The control flow graph provided by hoopl only tracks forward edges. Since we want to let users query predecessor blocks, we need to record predecessors on the side at CFG construction time (see cfgPredecessors). We build the cache with a single pass over the successors of the CFG. -} -- | This instance does not compare the graphs directly - instead it -- compares just the function from which the graph is constructed. -- The construction is completely deterministic so this should be -- fine. It is also fast because function comparison just compares -- unique integer IDs. instance Eq CFG where (==) = on (==) cfgFunction -- | This is a wrapper GADT around the LLVM IR to mesh with Hoopl. It -- won't be exported or exposed to the user at all. We need this for -- two reasons: -- -- 1) Hoopl requires explicit Label instructions. In LLVM these are -- implicit in the function structure through BasicBlocks -- -- 2) Additionally, LLVM doens't have a unique exit instruction per -- function. resume, ret, and unreachable all terminate execution. -- c.f. UniqueExitLabel and ExitLabel (both seem to be needed because -- hoopl blocks need an entry and an exit). 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" -- | Create a CFG for a function controlFlowGraph :: Function -> CFG controlFlowGraph f = runSimpleUniqueMonad (evalStateT builder mempty) where builder = do -- This is a unique label not associated with any block. All of -- the instructions that exit a function get an edge to this -- virtual label. 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 -- | A builder environment for constructing CFGs. Mostly needed for -- generating and tracking block labels. type Builder a = StateT (Map BasicBlock Label) SimpleUniqueMonad a -- | Return the Label for the given BasicBlock. Generates a new Label -- and caches it, if necessary. 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 -- | Convert a BasicBlock into a CFG chunk (the caller will combine -- all of the chunks). The block is C C shaped. The first argument -- is the unique exit label that certain instructions generated edges -- to. 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 -- | All instructions that exit a function get an edge to the special -- ExitLabel. This allows all results along all branches (even those -- with non-standard exits) to be collected. If only normal exit -- results are desired, just check the dataflow result for RetInst -- results. 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) -- Visualization 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) -- | There is an edge from the terminator of the BB to the entry of -- each of its successors. The edges should be labelled according to -- the type of the terminator. There are OtherEdge markers on between -- each instruction in the BB. 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 -- Basic blocks are not allowed to be empty so this pattern match -- should never fail. 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) -- Dataflow analysis stuff -- | An opaque representation of a dataflow analysis. Analyses of -- this type are suitable for both forward and backward use. -- -- For all dataflow analyses, the standard rules apply. -- -- 1) @meet a top == a@ -- -- 2) Your lattice @f@ must have finite height -- -- The @m@ type parameter is a 'Monad'; this dataflow framework -- provides a /monadic/ transfer function. This is intended to allow -- transfer functions to have monadic contexts that provide -- MonadReader and MonadWriter-like functionality. State is also -- useful for caching expensive sub-computations. Keep in mind that -- the analysis iterates to a fixedpoint and side effects in the monad -- will be repeated. 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 -- | Define a basic 'DataflowAnalysis' fwdDataflowAnalysis :: (Eq f, Monad m) => f -- ^ Top -> (f -> f -> f) -- ^ Meet -> (f -> Instruction -> m f) -- ^ Transfer -> DataflowAnalysis m f fwdDataflowAnalysis top m t = FwdDataflowAnalysis top m t Nothing -- | A basic backward dataflow analysis bwdDataflowAnalysis :: (Eq f, Monad m) => f -- ^ Top -> (f -> f -> f) -- ^ Meet -> (f -> Instruction -> m f) -- ^ Transfer -> DataflowAnalysis m f bwdDataflowAnalysis top m t = BwdDataflowAnalysis top m t Nothing -- | A forward dataflow analysis that provides an addition /edge -- transfer function/. This function is run with each Terminator -- instruction (/after/ the normal transfer function, whose results -- are fed to the edge transfer function). The edge transfer function -- allows you to let different information flow to each successor -- block of a terminator instruction. -- -- If a BasicBlock in the edge transfer result is not a successor of -- the input instruction, that mapping is discarded. Multiples are -- @meet@ed together. Missing values are taken from the result of the -- normal transfer function. fwdDataflowEdgeAnalysis :: (Eq f, Monad m) => f -- ^ Top -> (f -> f -> f) -- ^ meet -> (f -> Instruction -> m f) -- ^ Transfer -> (f -> Instruction -> m [(BasicBlock, f)]) -- ^ Edge Transfer -> DataflowAnalysis m f fwdDataflowEdgeAnalysis top m t e = FwdDataflowAnalysis top m t (Just e) bwdDataflowEdgeAnalysis :: (Eq f, Monad m) => f -- ^ Top -> (f -> f -> f) -- ^ meet -> (f -> Instruction -> m f) -- ^ Transfer -> ([(BasicBlock, f)] -> Instruction -> m f) -- ^ Edge Transfer -> DataflowAnalysis m f bwdDataflowEdgeAnalysis top m t e = BwdDataflowAnalysis top m t (Just e) -- | The opaque result of a dataflow analysis. Use the functions -- 'dataflowResult' and 'dataflowResultAt' to extract results. data DataflowResult m f where DataflowResult :: CFG -> DataflowAnalysis m f -> Fact C f -> Direction -> DataflowResult m f -- See Note [Dataflow Results] 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 -- This may have to cheat... LabelMap doesn't have an NFData instance. -- Not sure if this will affect monad-par or not. instance (NFData f) => NFData (DataflowResult m f) where rnf _ = () -- (DataflowResult m) = m `deepseq` () -- | Look up the dataflow fact at a particular Instruction. 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) -- Here, look up the facts for all successors 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' -- | Look up the dataflow fact at the virtual exit note. This -- combines the results along /all/ paths, including those ending in -- "termination" instructions like Unreachable and Resume. -- -- If you want the result at only the return instruction(s), use -- 'dataflowResultAt' and 'meets' the results together. 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 -- ^ Something providing a CFG -> DataflowAnalysis m f -- ^ The analysis to run -> f -- ^ Initial fact for the entry node -> m (DataflowResult m f) dataflow cfgLike da@FwdDataflowAnalysis { analysisTop = top , analysisMeet = meet , analysisTransfer = transfer , analysisFwdEdgeTransfer = etransfer } fact0 = do {- -- | Run a forward dataflow analysis forwardDataflow :: forall m f cfgLike . (HasCFG cfgLike) => cfgLike -- ^ Something providing a CFG -> DataflowAnalysis m f -- ^ The analysis to run -> f -- ^ Initial fact for the entry node -> m (DataflowResult m f) forwardDataflow cfgLike da@DataflowAnalysis { 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] -- We'll record the entry block in the CFG later graph :: Graph Insn C C -> Fact C f -> m (Fact C f) -- graph GNil = return -- graph (GUnit blk) = block blk 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 NothingC (JustO entry) = block entry `cat` body (successors entry) bdy c eps NothingO = body eps cbdy c _ _ = error "Bogus GADT pattern match failure" -- Analyze Rewrite Forward Transformer? 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 -- We don't do the meet operation here (unlike hoopl). They -- only performed it (knowing it is a no-op) to preserve side -- effects. 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) -- Labels aren't visible to the user and don't add facts for us. -- Now, the phi variant *can* add facts node (Lbl _ _) f = return f node (UniqueExitLabel _) f = return f -- Standard transfer function node (Normal i) f = transfer f i -- This gets a single input fact and needs to produce a -- *factbase*. This should actually be fairly simple; run the -- transfer function on the instruction and update all of the lbl node (Terminator i lbls) f = do f' <- transfer f i -- Now create a new map with all of the labels mapped to -- f'. Code later will handle merging this result. let baseResult = mapFromList $ zip lbls (repeat f') case etransfer of Nothing -> return baseResult Just etransfer' -> do -- Now convert BasicBlocks to their labels (discarding -- mappings where the label is not in @lbls@. Duplicates -- are meeted together. Missing elements are filled in by -- the result of the normal transfer function blockOuts <- etransfer' f' i let res = foldr (addBlockEdgeResult lbls) mapEmpty blockOuts return $ mapUnion res (mapDeleteList (mapKeys res) baseResult) -- The unique exit doesn't do anything - it just collects the -- final results. 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 {- -- | Run a backward dataflow analysis backwardDataflow :: forall m f cfgLike . (HasCFG cfgLike) => cfgLike -- ^ Something providing a CFG -> DataflowAnalysis m f -- ^ The analysis to run -> f -- ^ Initial fact for the entry node -> m (DataflowResult m f) backwardDataflow cfgLike da@DataflowAnalysis { analysisTop = top , analysisMeet = meet , analysisTransfer = transfer } fact0 = do -} 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] -- We'll record the entry block in the CFG later graph :: Graph Insn C C -> Fact C f -> m (Fact C f) -- graph GNil = return -- graph (GUnit blk) = block blk 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 NothingC (JustO entry) = block entry <=< body (successors entry) bdy c eps NothingO = body eps cbdy c _ _ = error "Bogus GADT pattern match failure" -- Analyze Rewrite Backward Transformer? 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 -- We don't do the meet operation here (unlike hoopl). They -- only performed it (knowing it is a no-op) to preserve side -- effects. 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 -- Labels aren't visible to the user and don't add facts for us. -- Now, the phi variant *can* add facts node (Lbl _ _) f = return f node (UniqueExitLabel _) f = return f -- Standard transfer function node (Normal i) f = transfer f i -- In backward mode, the transfer function gets a FactBase and -- returns a single Fact. node (Terminator i lbls) fbase = do let fs = mapMaybe (\l -> lookupFact l fbase) lbls f = foldr meet top fs transfer f i -- The unique exit doesn't do anything - it just collects the -- final results. 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 -- | The fixedpoint calculations (and joins) all happen in here. 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 = -- See Note [Fixpoint] loop initFbase entries mempty where meet = dataflowMeet da -- This is a map from label L to all of its dependencies; if L -- changes, all of its dependencies need to be re-analyzed. 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 -- Fold updateFact over each fact in the result from doBlock -- updateFact; facts are meet-ed pairwise. let (changed, fbase') = mapFoldWithKey (updateFact visited) ([], fbase) outFacts depLookup l = mapFindWithDefault [] l depBlocks toAnalyze = filter (`notElem` todo) $ concatMap depLookup changed -- In the original code, there is a binding @newblocks'@ -- that includes any new blocks added by the graph rewriting -- step. This analysis does not rewrite any blocks, so we -- only need @newblocks@ here. loop fbase' (todo ++ toAnalyze) (S.insert lbl visited) -- We also have a simpler update condition in updateFact since we -- don't carry around newBlocks. 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) {- Note [Fixpoint] In hoopl, the fixpoint returns a factbase that includes only the facts that are not in the body. Facts for the body are in the rewritten body nodes in the DG. Since we are not rewriting the graph, we keep all facts in the factbase in fixpoint. -} {- Note [Dataflow Results] To get a forward result, we have to look up the result for the block of the instruction and then run the analysis forward to the target instruction. For a /backward/ analysis, we have to do a bit more. Instead, we need all of the successors of the block (if there are none, then we have to take the summary for the unique exit node). Then we have to meet those and use that as the initial fact. Then replay over the basic block instructoins /in reverse/. Also note that the dataflowResultAt function does not need to use the edge transfer function because the result replay only needs to work within a single block. -}