{-# LANGUAGE FlexibleContexts, PatternGuards, ScopedTypeVariables, TupleSections, DeriveGeneric, DeriveDataTypeable #-}
module Language.Fortran.Analysis.DataFlow
( dominators, iDominators, DomMap, IDomMap
, postOrder, revPostOrder, preOrder, revPreOrder, OrderF
, dataFlowSolver, InOut, InOutMap, InF, OutF
, liveVariableAnalysis, reachingDefinitions
, genUDMap, genDUMap, duMapToUdMap, UDMap, DUMap
, genFlowsToGraph, FlowsGraph
, genVarFlowsToMap, VarFlowsMap
, Constant(..), ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars
, genBlockMap, genDefMap, BlockMap, DefMap
, genCallMap, CallMap
, loopNodes, genBackEdgeMap, sccWith, BackEdgeMap
, genLoopNodeMap, LoopNodeMap
, genInductionVarMap, InductionVarMap
, genInductionVarMapByASTBlock, InductionVarMapByASTBlock
, genDerivedInductionMap, DerivedInductionMap, InductionExpr(..)
, showDataFlow, showFlowsDOT
, BBNodeMap, BBNodeSet, ASTBlockNodeMap, ASTBlockNodeSet, ASTExprNodeMap, ASTExprNodeSet
) where
import Prelude hiding (init)
import Data.Generics.Uniplate.Data
import GHC.Generics
import Data.Data
import Control.Monad.State.Lazy
import Control.Arrow ((&&&))
import Text.PrettyPrint.GenericPretty (Out)
import Language.Fortran.Parser.Utils
import Language.Fortran.Analysis
import Language.Fortran.Analysis.BBlocks (showBlock, ASTBlockNode, ASTExprNode)
import Language.Fortran.AST
import qualified Data.Map as M
import qualified Data.IntMap.Lazy as IM
import qualified Data.Set as S
import qualified Data.IntSet as IS
import Data.Graph.Inductive hiding (trc, dom, order, inn, out, rc)
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Maybe
import Data.List (foldl', foldl1', (\\), union, intersect)
import Control.Monad.Writer hiding (fix)
type BBNodeMap = IM.IntMap
type BBNodeSet = IS.IntSet
type ASTBlockNodeMap = IM.IntMap
type ASTBlockNodeSet = IS.IntSet
type ASTExprNodeMap = IM.IntMap
type ASTExprNodeSet = IS.IntSet
type DomMap = BBNodeMap BBNodeSet
dominators :: BBGr a -> DomMap
dominators bbgr = IM.map snd $ dataFlowSolver bbgr init revPostOrder inn out
where
gr = bbgrGr bbgr
nodeSet = IS.fromList $ nodes gr
init _ = (nodeSet, nodeSet)
inn outF n
| preNodes@(_:_) <- pre gr n = foldl1' IS.intersection . map outF $ preNodes
| otherwise = IS.empty
out inF n = IS.insert n $ inF n
type IDomMap = BBNodeMap BBNode
iDominators :: BBGr a -> IDomMap
iDominators gr = IM.unions [ IM.fromList . flip iDom n $ bbgrGr gr | n <- bbgrEntries gr ]
type OrderF a = BBGr a -> [Node]
postOrder :: OrderF a
postOrder gr = concatMap postorder . dff (bbgrEntries gr) $ bbgrGr gr
revPostOrder :: OrderF a
revPostOrder = reverse . postOrder
preOrder :: OrderF a
preOrder gr = concatMap preorder . dff (bbgrEntries gr) $ bbgrGr gr
revPreOrder :: OrderF a
revPreOrder = reverse . preOrder
type InOut t = (t, t)
type InOutMap t = BBNodeMap (InOut t)
type InF t = Node -> t
type OutF t = Node -> t
dataFlowSolver :: Ord t => BBGr a
-> (Node -> InOut t)
-> OrderF a
-> (OutF t -> InF t)
-> (InF t -> OutF t)
-> InOutMap t
dataFlowSolver gr initF order inF outF = converge (==) $ iterate step initM
where
ordNodes = order gr
initM = IM.fromList [ (n, initF n) | n <- ordNodes ]
step m = IM.fromList [ (n, (inF (snd . get' m) n, outF (fst . get' m) n)) | n <- ordNodes ]
get' m n = fromJustMsg ("dataFlowSolver: get " ++ show n) $ IM.lookup n m
type BlockMap a = ASTBlockNodeMap (Block (Analysis a))
genBlockMap :: Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap pf = IM.fromList [ (i, b) | gr <- uni pf
, (_, bs) <- labNodes $ bbgrGr gr
, b <- bs
, let Just i = insLabel (getAnnotation b) ]
where
uni :: Data a => ProgramFile (Analysis a) -> [BBGr (Analysis a)]
uni = universeBi
type DefMap = M.Map Name ASTBlockNodeSet
genDefMap :: Data a => BlockMap a -> DefMap
genDefMap bm = M.fromListWith IS.union [
(y, IS.singleton i) | (i, b) <- IM.toList bm, y <- allLhsVars b
]
liveVariableAnalysis :: Data a => BBGr (Analysis a) -> InOutMap (S.Set Name)
liveVariableAnalysis gr = dataFlowSolver gr (const (S.empty, S.empty)) revPreOrder inn out
where
inn outF b = (outF b S.\\ kill b) `S.union` gen b
out innF b = S.unions [ innF s | s <- suc (bbgrGr gr) b ]
kill b = bblockKill (fromJustMsg "liveVariableAnalysis kill" $ lab (bbgrGr gr) b)
gen b = bblockGen (fromJustMsg "liveVariableAnalysis gen" $ lab (bbgrGr gr) b)
bblockKill :: Data a => [Block (Analysis a)] -> S.Set Name
bblockKill = S.fromList . concatMap blockKill
bblockGen :: Data a => [Block (Analysis a)] -> S.Set Name
bblockGen bs = S.fromList . fst . foldl' f ([], []) $ map (blockGen &&& blockKill) bs
where
f (bbgen, bbkill) (gen, kill) = ((gen \\ bbkill) `union` bbgen, kill `union` bbkill)
blockKill :: Data a => Block (Analysis a) -> [Name]
blockKill = blockVarDefs
blockGen :: Data a => Block (Analysis a) -> [Name]
blockGen = blockVarUses
reachingDefinitions :: Data a => DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet
reachingDefinitions dm gr = dataFlowSolver gr (const (IS.empty, IS.empty)) revPostOrder inn out
where
inn outF b = IS.unions [ outF s | s <- pre (bbgrGr gr) b ]
out innF b = gen `IS.union` (innF b IS.\\ kill)
where (gen, kill) = rdBblockGenKill dm (fromJustMsg "reachingDefinitions" $ lab (bbgrGr gr) b)
rdBblockGenKill :: Data a => DefMap -> [Block (Analysis a)] -> (ASTBlockNodeSet, ASTBlockNodeSet)
rdBblockGenKill dm bs = foldl' f (IS.empty, IS.empty) $ map (gen &&& kill) bs
where
gen b | null (allLhsVars b) = IS.empty
| otherwise = IS.singleton . fromJustMsg "rdBblockGenKill" . insLabel . getAnnotation $ b
kill = rdDefs dm
f (bbgen, bbkill) (gen', kill') =
((bbgen IS.\\ kill') `IS.union` gen', (bbkill IS.\\ gen') `IS.union` kill')
rdDefs :: Data a => DefMap -> Block (Analysis a) -> ASTBlockNodeSet
rdDefs dm b = IS.unions [ IS.empty `fromMaybe` M.lookup y dm | y <- allLhsVars b ]
type DUMap = ASTBlockNodeMap ASTBlockNodeSet
genDUMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> DUMap
genDUMap bm dm gr rdefs = IM.unionsWith IS.union duMaps
where
duMaps = [ fst (foldl' inBBlock (IM.empty, is) bs) |
(n, (is, _)) <- IM.toList rdefs,
let Just bs = lab (bbgrGr gr) n ]
inBBlock (duMap, inSet) b = (duMap', inSet')
where
Just i = insLabel (getAnnotation b)
bduMap = IM.fromListWith IS.union [ (i', IS.singleton i) | i' <- IS.toList inSet, overlap i' ]
overlap i' = not . null . intersect uses $ blockVarDefs b'
where Just b' = IM.lookup i' bm
uses = blockVarUses b
duMap' = IM.unionWith IS.union duMap bduMap
gen b' | null (allLhsVars b') = IS.empty
| otherwise = IS.singleton . fromJustMsg "genDUMap" . insLabel . getAnnotation $ b'
kill = rdDefs dm
inSet' = (inSet IS.\\ kill b) `IS.union` gen b
type UDMap = ASTBlockNodeMap ASTBlockNodeSet
duMapToUdMap :: DUMap -> UDMap
duMapToUdMap duMap = IM.fromListWith IS.union [
(use, IS.singleton def) | (def, uses) <- IM.toList duMap, use <- IS.toList uses
]
genUDMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> UDMap
genUDMap bm dm gr = duMapToUdMap . genDUMap bm dm gr
mapToGraph :: DynGraph gr => BlockMap a -> ASTBlockNodeMap ASTBlockNodeSet -> gr (Block (Analysis a)) ()
mapToGraph bm m = mkGraph nodes' edges'
where
nodes' = [ (i, iLabel) | i <- IM.keys m ++ concatMap IS.toList (IM.elems m)
, let iLabel = fromJustMsg "mapToGraph" (IM.lookup i bm) ]
edges' = [ (i, j, ()) | (i, js) <- IM.toList m
, j <- IS.toList js ]
type FlowsGraph a = Gr (Block (Analysis a)) ()
genFlowsToGraph :: Data a => BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> InOutMap ASTBlockNodeSet
-> FlowsGraph a
genFlowsToGraph bm dm gr = mapToGraph bm . genDUMap bm dm gr
type VarFlowsMap = M.Map Name (S.Set Name)
genVarFlowsToMap :: Data a => DefMap -> FlowsGraph a -> VarFlowsMap
genVarFlowsToMap dm fg = M.fromListWith S.union [ (conv u, sconv v) | (u, v) <- edges fg ]
where
sconv i | Just v <- IM.lookup i revDM = S.singleton v
| otherwise = S.empty
conv i | Just v <- IM.lookup i revDM = v
| otherwise = error $ "genVarFlowsToMap: convert failed, i=" ++ show i
revDM = IM.fromListWith (curry fst) [ (i, v) | (v, is) <- M.toList dm, i <- IS.toList is ]
minConst :: Integer
minConst = (-2::Integer) ^ (31::Integer)
maxConst :: Integer
maxConst = (2::Integer) ^ (31::Integer) - (1::Integer)
inBounds :: Integer -> Bool
inBounds x = minConst <= x && x <= maxConst
constantFolding :: Constant -> Constant
constantFolding c = case c of
ConstBinary binOp a b | ConstInt x <- constantFolding a
, ConstInt y <- constantFolding b -> case binOp of
Addition | inBounds (x + y) -> ConstInt (x + y)
Subtraction | inBounds (x - y) -> ConstInt (x - y)
Multiplication | inBounds (x * y) -> ConstInt (x * y)
Division | y /= 0 -> ConstInt (x `div` y)
_ -> ConstBinary binOp (ConstInt x) (ConstInt y)
ConstUnary Minus a | ConstInt x <- constantFolding a -> ConstInt (-x)
ConstUnary Plus a -> constantFolding a
_ -> c
type ParameterVarMap = M.Map Name Constant
type ConstExpMap = ASTExprNodeMap (Maybe Constant)
genConstExpMap :: forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap pf = ceMap
where
pvMap = M.fromList $
[ (varName v, getE e)
| st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)]
, AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)]
, (DeclVariable _ _ v _ (Just e)) <- universeBi st ] ++
[ (varName v, getE e)
| st@StParameter{} <- universeBi pf :: [Statement (Analysis a)]
, (DeclVariable _ _ v _ (Just e)) <- universeBi st ]
getV :: Expression (Analysis a) -> Maybe Constant
getV e = constExp (getAnnotation e) `mplus` (join . flip M.lookup pvMap . varName $ e)
ceMap = IM.fromList [ (label, doExpr e) | e <- universeBi pf, Just label <- [labelOf e] ]
getE :: Expression (Analysis a) -> Maybe Constant
getE = join . (flip IM.lookup ceMap <=< labelOf)
labelOf = insLabel . getAnnotation
doExpr :: Expression (Analysis a) -> Maybe Constant
doExpr e = case e of
ExpValue _ _ (ValInteger str)
| Just i <- readInteger str -> Just . ConstInt $ fromIntegral i
ExpValue _ _ (ValInteger str) -> Just $ ConstUninterpInt str
ExpValue _ _ (ValReal str) -> Just $ ConstUninterpReal str
ExpValue _ _ (ValVariable _) -> getV e
ExpBinary _ _ binOp e1 e2 -> constantFolding <$> liftM2 (ConstBinary binOp) (getE e1) (getE e2)
ExpUnary _ _ unOp e' -> constantFolding <$> ConstUnary unOp <$> getE e'
_ -> Nothing
analyseConstExps :: forall a. Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseConstExps pf = pf'
where
ceMap = genConstExpMap pf
pf' = transformBB (bbgrMap (nmap (transformExpr insertConstExp))) $ transformBi insertConstExp pf
insertConstExp :: Expression (Analysis a) -> Expression (Analysis a)
insertConstExp e = flip modifyAnnotation e $ \ a ->
a { constExp = constExp a `mplus` join (flip IM.lookup ceMap =<< insLabel (getAnnotation e)) }
transformBB :: (BBGr (Analysis a) -> BBGr (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
transformBB = transformBi
transformExpr :: (Expression (Analysis a) -> Expression (Analysis a)) ->
[Block (Analysis a)] -> [Block (Analysis a)]
transformExpr = transformBi
analyseParameterVars :: forall a. Data a => ParameterVarMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseParameterVars pvm = transformBi expr
where
expr :: Expression (Analysis a) -> Expression (Analysis a)
expr e@(ExpValue _ _ ValVariable{})
| Just con <- M.lookup (varName e) pvm = flip modifyAnnotation e $ \ a -> a { constExp = Just con }
expr e = e
type BackEdgeMap = BBNodeMap BBNode
genBackEdgeMap :: Graph gr => DomMap -> gr a b -> BackEdgeMap
genBackEdgeMap domMap = IM.fromList . filter isBackEdge . edges
where
isBackEdge (s, t) = t `IS.member` fromJustMsg "genBackEdgeMap" (s `IM.lookup` domMap)
loopNodes :: Graph gr => BackEdgeMap -> gr a b -> [BBNodeSet]
loopNodes bedges gr = [
IS.fromList (n:intersect (sccWith n gr) (rdfs [m] (delNode n gr))) | (m, n) <- IM.toList bedges
]
type LoopNodeMap = BBNodeMap BBNodeSet
genLoopNodeMap :: Graph gr => BackEdgeMap -> gr a b -> LoopNodeMap
genLoopNodeMap bedges gr = IM.fromList [
(n, IS.fromList (n:intersect (sccWith n gr) (rdfs [m] (delNode n gr)))) | (m, n) <- IM.toList bedges
]
sccWith :: (Graph gr) => Node -> gr a b -> [Node]
sccWith n g = case filter (n `elem`) $ scc g of
[] -> []
c:_ -> c
type InductionVarMap = BBNodeMap (S.Set Name)
basicInductionVars :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars bedges gr = IM.fromListWith S.union [
(n, S.singleton v) | (_, n) <- IM.toList bedges
, let Just bs = lab (bbgrGr gr) n
, b@BlDo{} <- bs
, v <- blockVarDefs b
]
genInductionVarMap :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap = basicInductionVars
type InductionVarMapByASTBlock = ASTBlockNodeMap (S.Set Name)
genInductionVarMapByASTBlock :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMapByASTBlock
genInductionVarMapByASTBlock bedges gr = loopsToLabs . genInductionVarMap bedges $ gr
where
lnMap = genLoopNodeMap bedges $ bbgrGr gr
get' = fromMaybe (error "missing loop-header node") . flip IM.lookup lnMap
astLabels n = [ i | b <- (universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (lab (bbgrGr gr) n)
, let Just i = insLabel (getAnnotation b) ]
loopsToLabs = IM.fromListWith S.union . concatMap loopToLabs . IM.toList
loopToLabs (n, ivs) = (map (,ivs) . astLabels) =<< IS.toList (get' n)
data InductionExpr
= IETop
| IELinear Name Int Int
| IEBottom
deriving (Show, Eq, Ord, Typeable, Generic, Data)
type DerivedInductionMap = ASTExprNodeMap InductionExpr
data IEFlow = IEFlow { ieFlowVars :: M.Map Name InductionExpr, ieFlowExprs :: DerivedInductionMap }
deriving (Show, Eq, Ord, Typeable, Generic, Data)
ieFlowInsertVar :: Name -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertVar v ie flow = flow { ieFlowVars = M.insert v ie (ieFlowVars flow) }
ieFlowInsertExpr :: ASTExprNode -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr i ie flow = flow { ieFlowExprs = IM.insert i ie (ieFlowExprs flow) }
emptyIEFlow :: IEFlow
emptyIEFlow = IEFlow M.empty IM.empty
joinIEFlows :: [IEFlow] -> IEFlow
joinIEFlows flows = IEFlow flowV flowE
where
flowV = M.unionsWith joinInductionExprs (map ieFlowVars flows)
flowE = IM.unionsWith joinInductionExprs (map ieFlowExprs flows)
genDerivedInductionMap :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> DerivedInductionMap
genDerivedInductionMap bedges gr = ieFlowExprs . joinIEFlows . map snd . IM.elems . IM.filterWithKey inLoop $ inOutMaps
where
bivMap = basicInductionVars bedges gr
loopNodeSet = IS.unions (loopNodes bedges $ bbgrGr gr)
inLoop i _ = i `IS.member` loopNodeSet
step :: IEFlow -> Block (Analysis a) -> IEFlow
step flow b = case b of
BlStatement _ _ _ (StExpressionAssign _ _ lv@(ExpValue _ _ (ValVariable _)) rhs)
| _ <- insLabel (getAnnotation rhs)
, flow'' <- ieFlowInsertVar (varName lv) (derivedInductionExpr flow' rhs) flow' -> stepExpr flow'' lv
_ -> flow'
where
flow' = foldl' stepExpr flow (universeBi b)
stepExpr :: IEFlow -> Expression (Analysis a) -> IEFlow
stepExpr flow e = ieFlowInsertExpr label ie flow
where
ie = derivedInductionExpr flow e
label = fromJustMsg "stepExpr" $ insLabel (getAnnotation e)
out :: InF IEFlow -> OutF IEFlow
out inF node = foldl' step flow (fromJustMsg ("analyseDerivedIE out(" ++ show node ++ ")") $ lab (bbgrGr gr) node)
where
flow = joinIEFlows [fst (initF node), inF node]
inn :: OutF IEFlow -> InF IEFlow
inn outF node = joinIEFlows [ outF p | p <- pre (bbgrGr gr) node ]
initF :: Node -> InOut IEFlow
initF node = case IM.lookup node bivMap of
Just set -> (IEFlow (M.fromList [ (n, IELinear n 1 0) | n <- S.toList set ]) IM.empty, emptyIEFlow)
Nothing -> (emptyIEFlow, emptyIEFlow)
inOutMaps = dataFlowSolver gr initF revPostOrder inn out
derivedInductionExpr :: Data a => IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr flow e = case e of
v@(ExpValue _ _ (ValVariable _)) -> fromMaybe IETop $ M.lookup (varName v) (ieFlowVars flow)
ExpValue _ _ (ValInteger str)
| Just i <- readInteger str -> IELinear "" 0 (fromIntegral i)
ExpBinary _ _ Addition e1 e2 -> derive e1 `addInductionExprs` derive e2
ExpBinary _ _ Subtraction e1 e2 -> derive e1 `addInductionExprs` negInductionExpr (derive e2)
ExpBinary _ _ Multiplication e1 e2 -> derive e1 `mulInductionExprs` derive e2
_ -> IETop
where
derive = derivedInductionExpr flow
addInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
addInductionExprs (IELinear ln lc lo) (IELinear rn rc ro)
| ln == rn = IELinear ln (lc + rc) (lo + ro)
| lc == 0 = IELinear rn rc (lo + ro)
| rc == 0 = IELinear ln lc (lo + ro)
| otherwise = IEBottom
addInductionExprs _ IETop = IETop
addInductionExprs IETop _ = IETop
addInductionExprs _ _ = IEBottom
negInductionExpr :: InductionExpr -> InductionExpr
negInductionExpr (IELinear n c o) = IELinear n (-c) (-o)
negInductionExpr IETop = IETop
negInductionExpr _ = IEBottom
mulInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
mulInductionExprs (IELinear "" _ lo) (IELinear rn rc ro) = IELinear rn (rc * lo) (ro * lo)
mulInductionExprs (IELinear ln lc lo) (IELinear "" _ ro) = IELinear ln (lc * ro) (lo * ro)
mulInductionExprs _ IETop = IETop
mulInductionExprs IETop _ = IETop
mulInductionExprs _ _ = IEBottom
joinInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
joinInductionExprs ie1 IETop = ie1
joinInductionExprs IETop ie2 = ie2
joinInductionExprs ie1 ie2
| ie1 == ie2 = ie1
| otherwise = IEBottom
showDataFlow :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String
showDataFlow pf = perPU =<< uni pf
where
uni = universeBi :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
perPU pu | Analysis { bBlocks = Just gr } <- getAnnotation pu =
dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ dfStr gr ++ "\n\n"
where p = "| Program Unit " ++ show (puName pu) ++ " |"
dashes = replicate (length p) '-'
dfStr gr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [
("callMap", show cm)
, ("postOrder", show (postOrder gr))
, ("revPostOrder", show (revPostOrder gr))
, ("revPreOrder", show (revPreOrder gr))
, ("dominators", show (dominators gr))
, ("iDominators", show (iDominators gr))
, ("defMap", show dm)
, ("lva", show (IM.toList $ lva gr))
, ("rd", show (IM.toList $ rd gr))
, ("backEdges", show bedges)
, ("topsort", show (topsort $ bbgrGr gr))
, ("scc ", show (scc $ bbgrGr gr))
, ("loopNodes", show (loopNodes bedges $ bbgrGr gr))
, ("duMap", show (genDUMap bm dm gr (rd gr)))
, ("udMap", show (genUDMap bm dm gr (rd gr)))
, ("flowsTo", show (edges flTo))
, ("varFlowsTo", show (genVarFlowsToMap dm (genFlowsToGraph bm dm gr (rd gr))))
, ("ivMap", show (genInductionVarMap bedges gr))
, ("ivMapByAST", show (genInductionVarMapByASTBlock bedges gr))
, ("constExpMap", show (genConstExpMap pf))
, ("entries", show (bbgrEntries gr))
, ("exits", show (bbgrExits gr))
] where
bedges = genBackEdgeMap (dominators gr) $ bbgrGr gr
flTo = genFlowsToGraph bm dm gr (rd gr)
perPU pu = dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ dfStr ++ "\n\n"
where p = "| Program Unit " ++ show (puName pu) ++ " |"
dashes = replicate (length p) '-'
dfStr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [
("constExpMap", show (genConstExpMap pf))
]
lva = liveVariableAnalysis
bm = genBlockMap pf
dm = genDefMap bm
rd = reachingDefinitions dm
cm = genCallMap pf
showFlowsDOT :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> BBGr (Analysis a) -> ASTBlockNode -> Bool -> String
showFlowsDOT pf bbgr astBlockId isFrom = execWriter $ do
let bm = genBlockMap pf
dm = genDefMap bm
flowsTo = genFlowsToGraph bm dm bbgr (reachingDefinitions dm bbgr)
flows | isFrom = grev flowsTo
| otherwise = flowsTo
tell "strict digraph {\n"
forM_ (bfsn [astBlockId] flows) $ \ n -> do
let pseudocode = maybe "<N/A>" showBlock $ IM.lookup n bm
tell "node [shape=box,fontname=\"Courier New\"]\n"
tell $ "Bl" ++ show n ++ "[label=\"B" ++ show n ++ "\\l" ++ pseudocode ++ "\"]\n"
tell $ "Bl" ++ show n ++ " -> {"
forM_ (suc flows n) $ \ m -> tell (" Bl" ++ show m)
tell "}\n"
tell "}\n"
type CallMap = M.Map ProgramUnitName (S.Set Name)
genCallMap :: Data a => ProgramFile (Analysis a) -> CallMap
genCallMap pf = flip execState M.empty $ do
let uP = universeBi :: Data a => ProgramFile a -> [ProgramUnit a]
forM_ (uP pf) $ \ pu -> do
let n = puName pu
let uS :: Data a => ProgramUnit a -> [Statement a]
uS = universeBi
let uE :: Data a => ProgramUnit a -> [Expression a]
uE = universeBi
m <- get
let ns = [ varName v | StCall _ _ v@ExpValue{} _ <- uS pu ] ++
[ varName v | ExpFunctionCall _ _ v@ExpValue{} _ <- uE pu ]
put $ M.insert n (S.fromList ns) m
converge :: (a -> a -> Bool) -> [a] -> a
converge p (x:ys@(y:_))
| p x y = y
| otherwise = converge p ys
converge _ [] = error "converge: empty list"
converge _ [_] = error "converge: finite list"
fromJustMsg :: String -> Maybe a -> a
fromJustMsg _ (Just x) = x
fromJustMsg msg _ = error msg