-- | Dataflow analysis to be applied once basic block analysis is complete.

{-# LANGUAGE FlexibleContexts, PatternGuards, ScopedTypeVariables, TupleSections, DeriveGeneric, DeriveDataTypeable, BangPatterns #-}
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 qualified Control.Monad.State.Lazy as Lazy
import Control.Monad.State.Strict
import Control.DeepSeq
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.IntMap.Strict as IMS
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.Maybe
import Data.List (foldl', foldl1', (\\), union, intersect)
import Control.Monad.Writer hiding (fix)

--------------------------------------------------
-- Better names for commonly used types
type BBNodeMap = IM.IntMap
type BBNodeSet = IS.IntSet
type ASTBlockNodeMap = IM.IntMap
type ASTBlockNodeSet = IS.IntSet
type ASTExprNodeMap = IMS.IntMap
type ASTExprNodeSet = IS.IntSet

-- | DomMap : node -> dominators of node
type DomMap = BBNodeMap BBNodeSet

-- | Compute dominators of each bblock in the graph. Node A dominates
-- node B when all paths from the start node of that program unit must
-- pass through node A in order to reach node B. That will be
-- represented as the relation (B, [A, ...]) in the DomMap.
dominators :: BBGr a -> DomMap
dominators :: BBGr a -> DomMap
dominators BBGr a
bbgr = ((IntSet, IntSet) -> IntSet) -> IntMap (IntSet, IntSet) -> DomMap
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map (IntSet, IntSet) -> IntSet
forall a b. (a, b) -> b
snd (IntMap (IntSet, IntSet) -> DomMap)
-> IntMap (IntSet, IntSet) -> DomMap
forall a b. (a -> b) -> a -> b
$ BBGr a
-> (Node -> (IntSet, IntSet))
-> OrderF a
-> (OutF IntSet -> OutF IntSet)
-> (OutF IntSet -> OutF IntSet)
-> IntMap (IntSet, IntSet)
forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Node -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr a
bbgr Node -> (IntSet, IntSet)
forall p. p -> (IntSet, IntSet)
init OrderF a
forall a. OrderF a
revPostOrder OutF IntSet -> OutF IntSet
inn OutF IntSet -> OutF IntSet
out
  where
    gr :: Gr (BB a) ()
gr        = BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
bbgr
    nodeSet :: IntSet
nodeSet   = [Node] -> IntSet
IS.fromList ([Node] -> IntSet) -> [Node] -> IntSet
forall a b. (a -> b) -> a -> b
$ Gr (BB a) () -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes Gr (BB a) ()
gr
    init :: p -> (IntSet, IntSet)
init p
_    = (IntSet
nodeSet, IntSet
nodeSet)

    inn :: OutF IntSet -> OutF IntSet
inn OutF IntSet
outF Node
n
      | preNodes :: [Node]
preNodes@(Node
_:[Node]
_) <- Gr (BB a) () -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
pre Gr (BB a) ()
gr Node
n = (IntSet -> IntSet -> IntSet) -> [IntSet] -> IntSet
forall a. (a -> a -> a) -> [a] -> a
foldl1' IntSet -> IntSet -> IntSet
IS.intersection ([IntSet] -> IntSet) -> ([Node] -> [IntSet]) -> [Node] -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutF IntSet -> [Node] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map OutF IntSet
outF ([Node] -> IntSet) -> [Node] -> IntSet
forall a b. (a -> b) -> a -> b
$ [Node]
preNodes
      | Bool
otherwise                  = IntSet
IS.empty

    out :: OutF IntSet -> OutF IntSet
out OutF IntSet
inF Node
n                      = Node -> IntSet -> IntSet
IS.insert Node
n (IntSet -> IntSet) -> IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ OutF IntSet
inF Node
n

-- | IDomMap : node -> immediate dominator of node
type IDomMap = BBNodeMap BBNode

-- | Compute the immediate dominator of each bblock in the graph. The
-- immediate dominator is, in a sense, the 'closest' dominator of a
-- node. Given nodes A and B, you can say that node A is immediately
-- dominated by node B if there does not exist any node C such that:
-- node A dominates node C and node C dominates node B.
iDominators :: BBGr a -> IDomMap
iDominators :: BBGr a -> IDomMap
iDominators BBGr a
gr = [IDomMap] -> IDomMap
forall (f :: * -> *) a. Foldable f => f (IntMap a) -> IntMap a
IM.unions [ [(Node, Node)] -> IDomMap
forall a. [(Node, a)] -> IntMap a
IM.fromList ([(Node, Node)] -> IDomMap)
-> (Gr (BB a) () -> [(Node, Node)]) -> Gr (BB a) () -> IDomMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Gr (BB a) () -> Node -> [(Node, Node)])
-> Node -> Gr (BB a) () -> [(Node, Node)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gr (BB a) () -> Node -> [(Node, Node)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [(Node, Node)]
iDom Node
n (Gr (BB a) () -> IDomMap) -> Gr (BB a) () -> IDomMap
forall a b. (a -> b) -> a -> b
$ BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr | Node
n <- BBGr a -> [Node]
forall a. OrderF a
bbgrEntries BBGr a
gr ]

-- | An OrderF is a function from graph to a specific ordering of nodes.
type OrderF a = BBGr a -> [Node]

-- | The postordering of a graph outputs the label after traversal of children.
postOrder :: OrderF a
postOrder :: OrderF a
postOrder BBGr a
gr = (Tree Node -> [Node]) -> [Tree Node] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Node -> [Node]
forall a. Tree a -> [a]
postorder ([Tree Node] -> [Node])
-> (Gr (BB a) () -> [Tree Node]) -> Gr (BB a) () -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Gr (BB a) () -> [Tree Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Tree Node]
dff (OrderF a
forall a. OrderF a
bbgrEntries BBGr a
gr) (Gr (BB a) () -> [Node]) -> Gr (BB a) () -> [Node]
forall a b. (a -> b) -> a -> b
$ BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr

-- | Reversed postordering.
revPostOrder :: OrderF a
revPostOrder :: OrderF a
revPostOrder = [Node] -> [Node]
forall a. [a] -> [a]
reverse ([Node] -> [Node]) -> OrderF a -> OrderF a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrderF a
forall a. OrderF a
postOrder

-- | The preordering of a graph outputs the label before traversal of children.
preOrder :: OrderF a
preOrder :: OrderF a
preOrder BBGr a
gr = (Tree Node -> [Node]) -> [Tree Node] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Node -> [Node]
forall a. Tree a -> [a]
preorder ([Tree Node] -> [Node])
-> (Gr (BB a) () -> [Tree Node]) -> Gr (BB a) () -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> Gr (BB a) () -> [Tree Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Tree Node]
dff (OrderF a
forall a. OrderF a
bbgrEntries BBGr a
gr) (Gr (BB a) () -> [Node]) -> Gr (BB a) () -> [Node]
forall a b. (a -> b) -> a -> b
$ BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr

-- | Reversed preordering.
revPreOrder :: OrderF a
revPreOrder :: OrderF a
revPreOrder = [Node] -> [Node]
forall a. [a] -> [a]
reverse ([Node] -> [Node]) -> OrderF a -> OrderF a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrderF a
forall a. OrderF a
preOrder

--------------------------------------------------

-- | InOut : (dataflow into the bblock, dataflow out of the bblock)
type InOut t    = (t, t)

-- | InOutMap : node -> (dataflow into node, dataflow out of node)
type InOutMap t = BBNodeMap (InOut t)

-- | InF, a function that returns the in-dataflow for a given node
type InF t      = Node -> t

-- | OutF, a function that returns the out-dataflow for a given node
type OutF t     = Node -> t

-- | Apply the iterative dataflow analysis method. Forces evaluation
-- of intermediate data structures at each step.
dataFlowSolver :: (NFData t, Ord t)
               => BBGr a            -- ^ basic block graph
               -> (Node -> InOut t) -- ^ initialisation for in and out dataflows
               -> OrderF a          -- ^ ordering function
               -> (OutF t -> InF t) -- ^ compute the in-flow given an out-flow function
               -> (InF t -> OutF t) -- ^ compute the out-flow given an in-flow function
               -> InOutMap t        -- ^ final dataflow for each node
dataFlowSolver :: BBGr a
-> (Node -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr a
gr Node -> InOut t
initF OrderF a
order OutF t -> OutF t
inF OutF t -> OutF t
outF = (InOutMap t -> InOutMap t -> Bool) -> [InOutMap t] -> InOutMap t
forall a. (a -> a -> Bool) -> [a] -> a
converge InOutMap t -> InOutMap t -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([InOutMap t] -> InOutMap t) -> [InOutMap t] -> InOutMap t
forall a b. (a -> b) -> a -> b
$ (InOutMap t -> InOutMap t) -> InOutMap t -> [InOutMap t]
forall t. NFData t => (t -> t) -> t -> [t]
iterate' InOutMap t -> InOutMap t
step InOutMap t
initM
  where
    ordNodes :: [Node]
ordNodes     = OrderF a
order BBGr a
gr
    initM :: InOutMap t
initM        = [(Node, InOut t)] -> InOutMap t
forall a. [(Node, a)] -> IntMap a
IM.fromList [ (Node
n, Node -> InOut t
initF Node
n) | Node
n <- [Node]
ordNodes ]
    step :: InOutMap t -> InOutMap t
step !InOutMap t
m      = [(Node, InOut t)] -> InOutMap t
forall a. [(Node, a)] -> IntMap a
IM.fromList [ (Node
n, (OutF t -> OutF t
inF (InOut t -> t
forall a b. (a, b) -> b
snd (InOut t -> t) -> (Node -> InOut t) -> OutF t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InOutMap t -> Node -> InOut t
forall a. IntMap a -> Node -> a
get' InOutMap t
m) Node
n, OutF t -> OutF t
outF (InOut t -> t
forall a b. (a, b) -> a
fst (InOut t -> t) -> (Node -> InOut t) -> OutF t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InOutMap t -> Node -> InOut t
forall a. IntMap a -> Node -> a
get' InOutMap t
m) Node
n)) | Node
n <- [Node]
ordNodes ]
    get' :: IntMap a -> Node -> a
get' IntMap a
m Node
n     = String -> Maybe a -> a
forall a. String -> Maybe a -> a
fromJustMsg (String
"dataFlowSolver: get " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
n) (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Node -> IntMap a -> Maybe a
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
n IntMap a
m
    iterate' :: (t -> t) -> t -> [t]
iterate' t -> t
f t
x = t
x t -> t -> t
forall a b. NFData a => a -> b -> b
`deepseq` t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: (t -> t) -> t -> [t]
iterate' t -> t
f (t -> t
f t
x)

-- Similar to above but return a list of states instead of just the final one.
--dataFlowSolver' :: Ord t => BBGr a            -- ^ basic block graph
--                        -> (Node -> InOut t) -- ^ initialisation for in and out dataflows
--                        -> OrderF a          -- ^ ordering function
--                        -> (OutF t -> InF t) -- ^ compute the in-flow given an out-flow function
--                        -> (InF t -> OutF t) -- ^ compute the out-flow given an in-flow function
--                        -> [InOutMap t]        -- ^ dataflow steps
--dataFlowSolver' gr initF order inF outF = 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

--------------------------------------------------

-- | BlockMap : AST-block label -> AST-block
-- Each AST-block has been given a unique number label during analysis
-- of basic blocks. The purpose of this map is to provide the ability
-- to lookup AST-blocks by label.
type BlockMap a = ASTBlockNodeMap (Block (Analysis a))

-- | Build a BlockMap from the AST. This can only be performed after
-- analyseBasicBlocks has operated, created basic blocks, and labeled
-- all of the AST-blocks with unique numbers.
genBlockMap :: Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap :: ProgramFile (Analysis a) -> BlockMap a
genBlockMap ProgramFile (Analysis a)
pf = [(Node, Block (Analysis a))] -> BlockMap a
forall a. [(Node, a)] -> IntMap a
IM.fromList [ (Node
i, Block (Analysis a)
b) | BBGr (Analysis a)
gr         <- ProgramFile (Analysis a) -> [BBGr (Analysis a)]
forall a. Data a => ProgramFile (Analysis a) -> [BBGr (Analysis a)]
uni ProgramFile (Analysis a)
pf
                                      , (Node
_, BB (Analysis a)
bs)    <- Gr (BB (Analysis a)) () -> [(Node, BB (Analysis a))]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (Gr (BB (Analysis a)) () -> [(Node, BB (Analysis a))])
-> Gr (BB (Analysis a)) () -> [(Node, BB (Analysis a))]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr
                                      , Block (Analysis a)
b          <- BB (Analysis a)
bs
                                      , let Just Node
i = Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) ]
  where
    uni :: Data a => ProgramFile (Analysis a) -> [BBGr (Analysis a)]
    uni :: ProgramFile (Analysis a) -> [BBGr (Analysis a)]
uni = ProgramFile (Analysis a) -> [BBGr (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

-- | DefMap : variable name -> { AST-block label }
type DefMap = M.Map Name ASTBlockNodeSet

-- | Build a DefMap from the BlockMap. This allows us to quickly look
-- up the AST-block labels that wrote into the given variable.
genDefMap :: Data a => BlockMap a -> DefMap
genDefMap :: BlockMap a -> DefMap
genDefMap BlockMap a
bm = (IntSet -> IntSet -> IntSet) -> [(String, IntSet)] -> DefMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith IntSet -> IntSet -> IntSet
IS.union [
                 (String
y, OutF IntSet
IS.singleton Node
i) | (Node
i, Block (Analysis a)
b) <- BlockMap a -> [(Node, Block (Analysis a))]
forall a. IntMap a -> [(Node, a)]
IM.toList BlockMap a
bm, String
y <- Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
allLhsVars Block (Analysis a)
b
               ]

--------------------------------------------------

-- | Dataflow analysis for live variables given basic block graph.
-- Muchnick, p. 445: A variable is "live" at a particular program
-- point if there is a path to the exit along which its value may be
-- used before it is redefined. It is "dead" if there is no such path.
liveVariableAnalysis :: Data a => BBGr (Analysis a) -> InOutMap (S.Set Name)
liveVariableAnalysis :: BBGr (Analysis a) -> InOutMap (Set String)
liveVariableAnalysis BBGr (Analysis a)
gr = BBGr (Analysis a)
-> (Node -> InOut (Set String))
-> OrderF (Analysis a)
-> (OutF (Set String) -> OutF (Set String))
-> (OutF (Set String) -> OutF (Set String))
-> InOutMap (Set String)
forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Node -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr (Analysis a)
gr (InOut (Set String) -> Node -> InOut (Set String)
forall a b. a -> b -> a
const (Set String
forall a. Set a
S.empty, Set String
forall a. Set a
S.empty)) OrderF (Analysis a)
forall a. OrderF a
revPreOrder OutF (Set String) -> OutF (Set String)
inn OutF (Set String) -> OutF (Set String)
forall a. Ord a => (Node -> Set a) -> Node -> Set a
out
  where
    inn :: OutF (Set String) -> OutF (Set String)
inn OutF (Set String)
outF Node
b = (OutF (Set String)
outF Node
b Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
S.\\ OutF (Set String)
kill Node
b) Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`S.union` OutF (Set String)
gen Node
b
    out :: (Node -> Set a) -> Node -> Set a
out Node -> Set a
innF Node
b = [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [ Node -> Set a
innF Node
s | Node
s <- Gr (BB (Analysis a)) () -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
suc (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
b ]
    kill :: OutF (Set String)
kill Node
b     = BB (Analysis a) -> Set String
forall a. Data a => [Block (Analysis a)] -> Set String
bblockKill (String -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. String -> Maybe a -> a
fromJustMsg String
"liveVariableAnalysis kill" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Node -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
b)
    gen :: OutF (Set String)
gen Node
b      = BB (Analysis a) -> Set String
forall a. Data a => [Block (Analysis a)] -> Set String
bblockGen (String -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. String -> Maybe a -> a
fromJustMsg String
"liveVariableAnalysis gen" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Node -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
b)

-- | Iterate "KILL" set through a single basic block.
bblockKill :: Data a => [Block (Analysis a)] -> S.Set Name
bblockKill :: [Block (Analysis a)] -> Set String
bblockKill = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> ([Block (Analysis a)] -> [String])
-> [Block (Analysis a)]
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block (Analysis a) -> [String])
-> [Block (Analysis a)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockKill

-- | Iterate "GEN" set through a single basic block.
bblockGen :: Data a => [Block (Analysis a)] -> S.Set Name
bblockGen :: [Block (Analysis a)] -> Set String
bblockGen [Block (Analysis a)]
bs = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String)
-> ([([String], [String])] -> [String])
-> [([String], [String])]
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], [String]) -> [String]
forall a b. (a, b) -> a
fst (([String], [String]) -> [String])
-> ([([String], [String])] -> ([String], [String]))
-> [([String], [String])]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], [String])
 -> ([String], [String]) -> ([String], [String]))
-> ([String], [String])
-> [([String], [String])]
-> ([String], [String])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([String], [String])
-> ([String], [String]) -> ([String], [String])
forall a. Eq a => ([a], [a]) -> ([a], [a]) -> ([a], [a])
f ([], []) ([([String], [String])] -> Set String)
-> [([String], [String])] -> Set String
forall a b. (a -> b) -> a -> b
$ (Block (Analysis a) -> ([String], [String]))
-> [Block (Analysis a)] -> [([String], [String])]
forall a b. (a -> b) -> [a] -> [b]
map (Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockGen (Block (Analysis a) -> [String])
-> (Block (Analysis a) -> [String])
-> Block (Analysis a)
-> ([String], [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockKill) [Block (Analysis a)]
bs
  where
    f :: ([a], [a]) -> ([a], [a]) -> ([a], [a])
f ([a]
bbgen, [a]
bbkill) ([a]
gen, [a]
kill) = (([a]
gen [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
bbkill) [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`union` [a]
bbgen, [a]
kill [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`union` [a]
bbkill)

-- | "KILL" set for a single AST-block.
blockKill :: Data a => Block (Analysis a) -> [Name]
blockKill :: Block (Analysis a) -> [String]
blockKill = Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockVarDefs

-- | "GEN" set for a single AST-block.
blockGen :: Data a => Block (Analysis a) -> [Name]
blockGen :: Block (Analysis a) -> [String]
blockGen = Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockVarUses

--------------------------------------------------

-- Reaching Definitions
-- forward flow analysis (revPostOrder)

-- GEN b@( definition of anything ) = {b}
-- KILL b@( definition of y ) = DEFS y    -- technically, except b, but it won't matter
-- DEFS y = { all definitions of y }

-- Within a basic block
-- GEN [] = KILL [] = {}
-- GEN [b_1 .. b_{n+1}] = GEN b_{n+1} `union` (GEN [b_1 .. b_n] `difference` KILL b_{n+1})
-- KILL [b_1 .. b_{n+1}] = KILL b_{n+1} `union` (KILL [b_1 .. b_n] `difference` GEN b_{n+1})

-- Between basic blocks
-- REACHin bb = unions [ REACHout bb | bb <- pred bb ]
-- REACHout bb = GEN bb `union` (REACHin bb `difference` KILL bb)

-- | Reaching definitions dataflow analysis. Reaching definitions are
-- the set of variable-defining AST-block labels that may reach a
-- program point. Suppose AST-block with label A defines a variable
-- named v. Label A may reach another program point labeled P if there
-- is at least one program path from label A to label P that does not
-- redefine variable v.
reachingDefinitions :: Data a => DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet
reachingDefinitions :: DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet)
reachingDefinitions DefMap
dm BBGr (Analysis a)
gr = BBGr (Analysis a)
-> (Node -> (IntSet, IntSet))
-> OrderF (Analysis a)
-> (OutF IntSet -> OutF IntSet)
-> (OutF IntSet -> OutF IntSet)
-> IntMap (IntSet, IntSet)
forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Node -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr (Analysis a)
gr ((IntSet, IntSet) -> Node -> (IntSet, IntSet)
forall a b. a -> b -> a
const (IntSet
IS.empty, IntSet
IS.empty)) OrderF (Analysis a)
forall a. OrderF a
revPostOrder OutF IntSet -> OutF IntSet
inn OutF IntSet -> OutF IntSet
out
  where
    inn :: OutF IntSet -> OutF IntSet
inn OutF IntSet
outF Node
b = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions [ OutF IntSet
outF Node
s | Node
s <- Gr (BB (Analysis a)) () -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
pre (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
b ]
    out :: OutF IntSet -> OutF IntSet
out OutF IntSet
innF Node
b = IntSet
gen IntSet -> IntSet -> IntSet
`IS.union` (OutF IntSet
innF Node
b IntSet -> IntSet -> IntSet
IS.\\ IntSet
kill)
      where (IntSet
gen, IntSet
kill) = DefMap -> BB (Analysis a) -> (IntSet, IntSet)
forall a.
Data a =>
DefMap -> [Block (Analysis a)] -> (IntSet, IntSet)
rdBblockGenKill DefMap
dm (String -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. String -> Maybe a -> a
fromJustMsg String
"reachingDefinitions" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Node -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
b)

-- Compute the "GEN" and "KILL" sets for a given basic block.
rdBblockGenKill :: Data a => DefMap -> [Block (Analysis a)] -> (ASTBlockNodeSet, ASTBlockNodeSet)
rdBblockGenKill :: DefMap -> [Block (Analysis a)] -> (IntSet, IntSet)
rdBblockGenKill DefMap
dm [Block (Analysis a)]
bs = ((IntSet, IntSet) -> (IntSet, IntSet) -> (IntSet, IntSet))
-> (IntSet, IntSet) -> [(IntSet, IntSet)] -> (IntSet, IntSet)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntSet, IntSet) -> (IntSet, IntSet) -> (IntSet, IntSet)
f (IntSet
IS.empty, IntSet
IS.empty) ([(IntSet, IntSet)] -> (IntSet, IntSet))
-> [(IntSet, IntSet)] -> (IntSet, IntSet)
forall a b. (a -> b) -> a -> b
$ (Block (Analysis a) -> (IntSet, IntSet))
-> [Block (Analysis a)] -> [(IntSet, IntSet)]
forall a b. (a -> b) -> [a] -> [b]
map (Block (Analysis a) -> IntSet
forall a. Data a => Block (Analysis a) -> IntSet
gen (Block (Analysis a) -> IntSet)
-> (Block (Analysis a) -> IntSet)
-> Block (Analysis a)
-> (IntSet, IntSet)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Block (Analysis a) -> IntSet
kill) [Block (Analysis a)]
bs
  where
    gen :: Block (Analysis a) -> IntSet
gen Block (Analysis a)
b | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
allLhsVars Block (Analysis a)
b) = IntSet
IS.empty
          | Bool
otherwise           = OutF IntSet
IS.singleton OutF IntSet
-> (Block (Analysis a) -> Node) -> Block (Analysis a) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Node -> Node
forall a. String -> Maybe a -> a
fromJustMsg String
"rdBblockGenKill" (Maybe Node -> Node)
-> (Block (Analysis a) -> Maybe Node) -> Block (Analysis a) -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Analysis a -> Maybe Node)
-> (Block (Analysis a) -> Analysis a)
-> Block (Analysis a)
-> Maybe Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation (Block (Analysis a) -> IntSet) -> Block (Analysis a) -> IntSet
forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b
    kill :: Block (Analysis a) -> IntSet
kill = DefMap -> Block (Analysis a) -> IntSet
forall a. Data a => DefMap -> Block (Analysis a) -> IntSet
rdDefs DefMap
dm
    f :: (IntSet, IntSet) -> (IntSet, IntSet) -> (IntSet, IntSet)
f (IntSet
bbgen, IntSet
bbkill) (IntSet
gen', IntSet
kill') =
      ((IntSet
bbgen IntSet -> IntSet -> IntSet
IS.\\ IntSet
kill') IntSet -> IntSet -> IntSet
`IS.union` IntSet
gen', (IntSet
bbkill IntSet -> IntSet -> IntSet
IS.\\ IntSet
gen') IntSet -> IntSet -> IntSet
`IS.union` IntSet
kill')

-- Set of all AST-block labels that also define variables defined by AST-block b
rdDefs :: Data a => DefMap -> Block (Analysis a) -> ASTBlockNodeSet
rdDefs :: DefMap -> Block (Analysis a) -> IntSet
rdDefs DefMap
dm Block (Analysis a)
b = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions [ IntSet
IS.empty IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
`fromMaybe` String -> DefMap -> Maybe IntSet
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
y DefMap
dm | String
y <- Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
allLhsVars Block (Analysis a)
b ]

--------------------------------------------------

-- | DUMap : definition -> { use }
type DUMap = ASTBlockNodeMap ASTBlockNodeSet

-- | def-use map: map AST-block labels of defining AST-blocks to the
-- AST-blocks that may use the definition.
genDUMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> DUMap
genDUMap :: BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
genDUMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr IntMap (IntSet, IntSet)
rdefs = (IntSet -> IntSet -> IntSet) -> [DomMap] -> DomMap
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IM.unionsWith IntSet -> IntSet -> IntSet
IS.union [DomMap]
duMaps
  where
    -- duMaps for each bblock
    duMaps :: [DomMap]
duMaps = [ (DomMap, IntSet) -> DomMap
forall a b. (a, b) -> a
fst (((DomMap, IntSet) -> Block (Analysis a) -> (DomMap, IntSet))
-> (DomMap, IntSet) -> [Block (Analysis a)] -> (DomMap, IntSet)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (DomMap, IntSet) -> Block (Analysis a) -> (DomMap, IntSet)
forall a.
Data a =>
(DomMap, IntSet) -> Block (Analysis a) -> (DomMap, IntSet)
inBBlock (DomMap
forall a. IntMap a
IM.empty, IntSet
is) [Block (Analysis a)]
bs) |
               (Node
n, (IntSet
is, IntSet
_)) <- IntMap (IntSet, IntSet) -> [(Node, (IntSet, IntSet))]
forall a. IntMap a -> [(Node, a)]
IM.toList IntMap (IntSet, IntSet)
rdefs,
               let Just [Block (Analysis a)]
bs = Gr [Block (Analysis a)] () -> Node -> Maybe [Block (Analysis a)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab (BBGr (Analysis a) -> Gr [Block (Analysis a)] ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
n ]
    -- internal analysis within bblock; fold over list of AST-blocks
    inBBlock :: (DomMap, IntSet) -> Block (Analysis a) -> (DomMap, IntSet)
inBBlock (DomMap
duMap, IntSet
inSet) Block (Analysis a)
b = (DomMap
duMap', IntSet
inSet')
      where
        Just Node
i = Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b)
        bduMap :: DomMap
bduMap = (IntSet -> IntSet -> IntSet) -> [(Node, IntSet)] -> DomMap
forall a. (a -> a -> a) -> [(Node, a)] -> IntMap a
IM.fromListWith IntSet -> IntSet -> IntSet
IS.union [ (Node
i', OutF IntSet
IS.singleton Node
i) | Node
i' <- IntSet -> [Node]
IS.toList IntSet
inSet, Node -> Bool
overlap Node
i' ]
        -- asks: does AST-block at label i' define anything used by AST-block b?
        overlap :: Node -> Bool
overlap Node
i' = Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> ([String] -> [String]) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
intersect [String]
uses ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockVarDefs Block (Analysis a)
b'
          where Just Block (Analysis a)
b' = Node -> BlockMap a -> Maybe (Block (Analysis a))
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
i' BlockMap a
bm
        uses :: [String]
uses   = Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockVarUses Block (Analysis a)
b
        duMap' :: DomMap
duMap' = (IntSet -> IntSet -> IntSet) -> DomMap -> DomMap -> DomMap
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith IntSet -> IntSet -> IntSet
IS.union DomMap
duMap DomMap
bduMap
        gen :: Block (Analysis a) -> IntSet
gen Block (Analysis a)
b' | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
allLhsVars Block (Analysis a)
b') = IntSet
IS.empty
               | Bool
otherwise           = OutF IntSet
IS.singleton OutF IntSet
-> (Block (Analysis a) -> Node) -> Block (Analysis a) -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Node -> Node
forall a. String -> Maybe a -> a
fromJustMsg String
"genDUMap" (Maybe Node -> Node)
-> (Block (Analysis a) -> Maybe Node) -> Block (Analysis a) -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Analysis a -> Maybe Node)
-> (Block (Analysis a) -> Analysis a)
-> Block (Analysis a)
-> Maybe Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation (Block (Analysis a) -> IntSet) -> Block (Analysis a) -> IntSet
forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b'
        kill :: Block (Analysis a) -> IntSet
kill   = DefMap -> Block (Analysis a) -> IntSet
forall a. Data a => DefMap -> Block (Analysis a) -> IntSet
rdDefs DefMap
dm
        inSet' :: IntSet
inSet' = (IntSet
inSet IntSet -> IntSet -> IntSet
IS.\\ Block (Analysis a) -> IntSet
kill Block (Analysis a)
b) IntSet -> IntSet -> IntSet
`IS.union` Block (Analysis a) -> IntSet
forall a. Data a => Block (Analysis a) -> IntSet
gen Block (Analysis a)
b

-- | UDMap : use -> { definition }
type UDMap = ASTBlockNodeMap ASTBlockNodeSet

-- | Invert the DUMap into a UDMap
duMapToUdMap :: DUMap -> UDMap
duMapToUdMap :: DomMap -> DomMap
duMapToUdMap DomMap
duMap = (IntSet -> IntSet -> IntSet) -> [(Node, IntSet)] -> DomMap
forall a. (a -> a -> a) -> [(Node, a)] -> IntMap a
IM.fromListWith IntSet -> IntSet -> IntSet
IS.union [
    (Node
use, OutF IntSet
IS.singleton Node
def) | (Node
def, IntSet
uses) <- DomMap -> [(Node, IntSet)]
forall a. IntMap a -> [(Node, a)]
IM.toList DomMap
duMap, Node
use <- IntSet -> [Node]
IS.toList IntSet
uses
  ]

-- | use-def map: map AST-block labels of variable-using AST-blocks to
-- the AST-blocks that define those variables.
genUDMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> UDMap
genUDMap :: BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
genUDMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr = DomMap -> DomMap
duMapToUdMap (DomMap -> DomMap)
-> (IntMap (IntSet, IntSet) -> DomMap)
-> IntMap (IntSet, IntSet)
-> DomMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
genDUMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr

--------------------------------------------------

-- | Convert a UD or DU Map into a graph.
mapToGraph :: DynGraph gr => BlockMap a -> ASTBlockNodeMap ASTBlockNodeSet -> gr (Block (Analysis a)) ()
mapToGraph :: BlockMap a -> DomMap -> gr (Block (Analysis a)) ()
mapToGraph BlockMap a
bm DomMap
m = [LNode (Block (Analysis a))]
-> [LEdge ()] -> gr (Block (Analysis a)) ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode (Block (Analysis a))]
nodes' [LEdge ()]
edges'
  where
    nodes' :: [LNode (Block (Analysis a))]
nodes' = [ (Node
i, Block (Analysis a)
iLabel) | Node
i <- DomMap -> [Node]
forall a. IntMap a -> [Node]
IM.keys DomMap
m [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
++ (IntSet -> [Node]) -> [IntSet] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IntSet -> [Node]
IS.toList (DomMap -> [IntSet]
forall a. IntMap a -> [a]
IM.elems DomMap
m)
                          , let iLabel :: Block (Analysis a)
iLabel = String -> Maybe (Block (Analysis a)) -> Block (Analysis a)
forall a. String -> Maybe a -> a
fromJustMsg String
"mapToGraph" (Node -> BlockMap a -> Maybe (Block (Analysis a))
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
i BlockMap a
bm) ]
    edges' :: [LEdge ()]
edges' = [ (Node
i, Node
j, ()) | (Node
i, IntSet
js) <- DomMap -> [(Node, IntSet)]
forall a. IntMap a -> [(Node, a)]
IM.toList DomMap
m
                         , Node
j       <- IntSet -> [Node]
IS.toList IntSet
js ]

-- | FlowsGraph : nodes as AST-block (numbered by label), edges
-- showing which definitions contribute to which uses.
type FlowsGraph a = Gr (Block (Analysis a)) ()

-- | "Flows-To" analysis. Represent def-use map as a graph.
genFlowsToGraph :: Data a => BlockMap a
                          -> DefMap
                          -> BBGr (Analysis a)
                          -> InOutMap ASTBlockNodeSet -- ^ result of reaching definitions
                          -> FlowsGraph a
genFlowsToGraph :: BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (IntSet, IntSet)
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr = BlockMap a -> DomMap -> FlowsGraph a
forall (gr :: * -> * -> *) a.
DynGraph gr =>
BlockMap a -> DomMap -> gr (Block (Analysis a)) ()
mapToGraph BlockMap a
bm (DomMap -> FlowsGraph a)
-> (IntMap (IntSet, IntSet) -> DomMap)
-> IntMap (IntSet, IntSet)
-> FlowsGraph a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
genDUMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr

-- | Represent "flows" between variables
type VarFlowsMap = M.Map Name (S.Set Name)

-- | Create a map (A -> Bs) where A "flows" or contributes towards the variables Bs.
genVarFlowsToMap :: Data a => DefMap -> FlowsGraph a -> VarFlowsMap
genVarFlowsToMap :: DefMap -> FlowsGraph a -> VarFlowsMap
genVarFlowsToMap DefMap
dm FlowsGraph a
fg = (Set String -> Set String -> Set String)
-> [(String, Set String)] -> VarFlowsMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
S.union [ (Node -> String
conv Node
u, OutF (Set String)
sconv Node
v) | (Node
u, Node
v) <- FlowsGraph a -> [(Node, Node)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> [(Node, Node)]
edges FlowsGraph a
fg ]
  where
    sconv :: OutF (Set String)
sconv Node
i | Just String
v  <- Node -> IntMap String -> Maybe String
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
i IntMap String
revDM = String -> Set String
forall a. a -> Set a
S.singleton String
v
            | Bool
otherwise                    = Set String
forall a. Set a
S.empty
    conv :: Node -> String
conv Node
i | Just String
v  <- Node -> IntMap String -> Maybe String
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
i IntMap String
revDM = String
v
           | Bool
otherwise                    = String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"genVarFlowsToMap: convert failed, i=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
i
    -- planning to make revDM a surjection, after I flatten-out Fortran functions
    revDM :: IntMap String
revDM = (String -> String -> String) -> [(Node, String)] -> IntMap String
forall a. (a -> a -> a) -> [(Node, a)] -> IntMap a
IM.fromListWith (((String, String) -> String) -> String -> String -> String
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (String, String) -> String
forall a b. (a, b) -> a
fst) [ (Node
i, String
v) | (String
v, IntSet
is) <- DefMap -> [(String, IntSet)]
forall k a. Map k a -> [(k, a)]
M.toList DefMap
dm, Node
i <- IntSet -> [Node]
IS.toList IntSet
is ]

--------------------------------------------------

-- Integer arithmetic can be compile-time evaluated if we guard
-- against overflow, divide-by-zero. We must interpret the various
-- lexical forms of integers.
--
-- Floating point arithmetic requires knowing the target machine and
-- being very careful with all the possible effects of IEEE FP. Will
-- leave it alone for now.

-- conservative assumption: stay within bounds of signed 32-bit integer
minConst :: Integer
minConst :: Integer
minConst = (-Integer
2::Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
31::Integer)

maxConst :: Integer
maxConst :: Integer
maxConst = (Integer
2::Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
31::Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
1::Integer)

inBounds :: Integer -> Bool
inBounds :: Integer -> Bool
inBounds Integer
x = Integer
minConst Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
x Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxConst

-- | Evaluate possible constant expressions within tree.
constantFolding :: Constant -> Constant
constantFolding :: Constant -> Constant
constantFolding Constant
c = case Constant
c of
  ConstBinary BinaryOp
binOp Constant
a Constant
b | ConstInt Integer
x <- Constant -> Constant
constantFolding Constant
a
                        , ConstInt Integer
y <- Constant -> Constant
constantFolding Constant
b -> case BinaryOp
binOp of
    BinaryOp
Addition       | Integer -> Bool
inBounds (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y) -> Integer -> Constant
ConstInt (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y)
    BinaryOp
Subtraction    | Integer -> Bool
inBounds (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y) -> Integer -> Constant
ConstInt (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y)
    BinaryOp
Multiplication | Integer -> Bool
inBounds (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y) -> Integer -> Constant
ConstInt (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y)
    BinaryOp
Division       | Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0           -> Integer -> Constant
ConstInt (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
y)
    BinaryOp
_                                 -> BinaryOp -> Constant -> Constant -> Constant
ConstBinary BinaryOp
binOp (Integer -> Constant
ConstInt Integer
x) (Integer -> Constant
ConstInt Integer
y)
  ConstUnary UnaryOp
Minus Constant
a | ConstInt Integer
x <- Constant -> Constant
constantFolding Constant
a -> Integer -> Constant
ConstInt (-Integer
x)
  ConstUnary UnaryOp
Plus  Constant
a                                   -> Constant -> Constant
constantFolding Constant
a
  Constant
_ -> Constant
c

-- | The map of all parameter variables and their corresponding values
type ParameterVarMap = M.Map Name Constant
-- | The map of all expressions and whether they are undecided (not
-- present in map), a constant value (Just Constant), or probably not
-- constant (Nothing).
type ConstExpMap = ASTExprNodeMap (Maybe Constant)

-- | Generate a constant-expression map with information about the
-- expressions (identified by insLabel numbering) in the ProgramFile
-- pf (must have analysis initiated & basic blocks generated) .
genConstExpMap :: forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap :: ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap ProgramFile (Analysis a)
pf = ConstExpMap
ceMap
  where
    -- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily.
    pvMap :: Map String (Maybe Constant)
pvMap = [(String, Maybe Constant)] -> Map String (Maybe Constant)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, Maybe Constant)] -> Map String (Maybe Constant))
-> [(String, Maybe Constant)] -> Map String (Maybe Constant)
forall a b. (a -> b) -> a -> b
$
      [ (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v, Expression (Analysis a) -> Maybe Constant
getE Expression (Analysis a)
e)
      | st :: Statement (Analysis a)
st@(StDeclaration Analysis a
_ SrcSpan
_ (TypeSpec Analysis a
_ SrcSpan
_ BaseType
_ Maybe (Selector (Analysis a))
_) Maybe (AList Attribute (Analysis a))
_ AList Declarator (Analysis a)
_) <- ProgramFile (Analysis a) -> [Statement (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf :: [Statement (Analysis a)]
      , AttrParameter Analysis a
_ SrcSpan
_ <- Statement (Analysis a) -> [Attribute (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
st :: [Attribute (Analysis a)]
      , (DeclVariable Analysis a
_ SrcSpan
_ Expression (Analysis a)
v Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
e)) <- Statement (Analysis a) -> [Declarator (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
st ] [(String, Maybe Constant)]
-> [(String, Maybe Constant)] -> [(String, Maybe Constant)]
forall a. [a] -> [a] -> [a]
++
      [ (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v, Expression (Analysis a) -> Maybe Constant
getE Expression (Analysis a)
e)
      | st :: Statement (Analysis a)
st@StParameter{} <- ProgramFile (Analysis a) -> [Statement (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf :: [Statement (Analysis a)]
      , (DeclVariable Analysis a
_ SrcSpan
_ Expression (Analysis a)
v Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
e)) <- Statement (Analysis a) -> [Declarator (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
st ]
    getV :: Expression (Analysis a) -> Maybe Constant
    getV :: Expression (Analysis a) -> Maybe Constant
getV Expression (Analysis a)
e = Analysis a -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e) Maybe Constant -> Maybe Constant -> Maybe Constant
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Maybe (Maybe Constant) -> Maybe Constant
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Constant) -> Maybe Constant)
-> (Expression (Analysis a) -> Maybe (Maybe Constant))
-> Expression (Analysis a)
-> Maybe Constant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Map String (Maybe Constant) -> Maybe (Maybe Constant))
-> Map String (Maybe Constant) -> String -> Maybe (Maybe Constant)
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Map String (Maybe Constant) -> Maybe (Maybe Constant)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map String (Maybe Constant)
pvMap (String -> Maybe (Maybe Constant))
-> (Expression (Analysis a) -> String)
-> Expression (Analysis a)
-> Maybe (Maybe Constant)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName (Expression (Analysis a) -> Maybe Constant)
-> Expression (Analysis a) -> Maybe Constant
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a)
e)

    -- Generate map of information about 'constant expressions'.
    ceMap :: ConstExpMap
ceMap = [(Node, Maybe Constant)] -> ConstExpMap
forall a. [(Node, a)] -> IntMap a
IM.fromList [ (Node
label, Expression (Analysis a) -> Maybe Constant
doExpr Expression (Analysis a)
e) | Expression (Analysis a)
e <- ProgramFile (Analysis a) -> [Expression (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf, Just Node
label <- [Expression (Analysis a) -> Maybe Node
forall a. Expression (Analysis a) -> Maybe Node
labelOf Expression (Analysis a)
e] ]
    getE :: Expression (Analysis a) -> Maybe Constant
    getE :: Expression (Analysis a) -> Maybe Constant
getE = Maybe (Maybe Constant) -> Maybe Constant
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Constant) -> Maybe Constant)
-> (Expression (Analysis a) -> Maybe (Maybe Constant))
-> Expression (Analysis a)
-> Maybe Constant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node -> ConstExpMap -> Maybe (Maybe Constant))
-> ConstExpMap -> Node -> Maybe (Maybe Constant)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node -> ConstExpMap -> Maybe (Maybe Constant)
forall a. Node -> IntMap a -> Maybe a
IM.lookup ConstExpMap
ceMap (Node -> Maybe (Maybe Constant))
-> (Expression (Analysis a) -> Maybe Node)
-> Expression (Analysis a)
-> Maybe (Maybe Constant)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Expression (Analysis a) -> Maybe Node
forall a. Expression (Analysis a) -> Maybe Node
labelOf)
    labelOf :: Expression (Analysis a) -> Maybe Node
labelOf = Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Analysis a -> Maybe Node)
-> (Expression (Analysis a) -> Analysis a)
-> Expression (Analysis a)
-> Maybe Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation
    doExpr :: Expression (Analysis a) -> Maybe Constant
    doExpr :: Expression (Analysis a) -> Maybe Constant
doExpr Expression (Analysis a)
e = case Expression (Analysis a)
e of
      ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
str)
        | Just Integer
i <- String -> Maybe Integer
readInteger String
str -> Constant -> Maybe Constant
forall a. a -> Maybe a
Just (Constant -> Maybe Constant)
-> (Integer -> Constant) -> Integer -> Maybe Constant
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Constant
ConstInt (Integer -> Maybe Constant) -> Integer -> Maybe Constant
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i
      ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
str) -> Constant -> Maybe Constant
forall a. a -> Maybe a
Just (Constant -> Maybe Constant) -> Constant -> Maybe Constant
forall a b. (a -> b) -> a -> b
$ String -> Constant
ConstUninterpInt String
str
      ExpValue Analysis a
_ SrcSpan
_ (ValReal String
str)    -> Constant -> Maybe Constant
forall a. a -> Maybe a
Just (Constant -> Maybe Constant) -> Constant -> Maybe Constant
forall a b. (a -> b) -> a -> b
$ String -> Constant
ConstUninterpReal String
str
      ExpValue Analysis a
_ SrcSpan
_ (ValVariable String
_)  -> Expression (Analysis a) -> Maybe Constant
getV Expression (Analysis a)
e
      -- Recursively seek information about sub-expressions, relying on laziness.
      ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
binOp Expression (Analysis a)
e1 Expression (Analysis a)
e2     -> Constant -> Constant
constantFolding (Constant -> Constant) -> Maybe Constant -> Maybe Constant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Constant -> Constant -> Constant)
-> Maybe Constant -> Maybe Constant -> Maybe Constant
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (BinaryOp -> Constant -> Constant -> Constant
ConstBinary BinaryOp
binOp) (Expression (Analysis a) -> Maybe Constant
getE Expression (Analysis a)
e1) (Expression (Analysis a) -> Maybe Constant
getE Expression (Analysis a)
e2)
      ExpUnary Analysis a
_ SrcSpan
_ UnaryOp
unOp Expression (Analysis a)
e'           -> Constant -> Constant
constantFolding (Constant -> Constant)
-> (Constant -> Constant) -> Constant -> Constant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnaryOp -> Constant -> Constant
ConstUnary UnaryOp
unOp (Constant -> Constant) -> Maybe Constant -> Maybe Constant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> Maybe Constant
getE Expression (Analysis a)
e'
      Expression (Analysis a)
_ -> Maybe Constant
forall a. Maybe a
Nothing

-- | Get constant-expression information and put it into the AST
-- analysis annotation. Must occur after analyseBBlocks.
analyseConstExps :: forall a. Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseConstExps :: ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseConstExps ProgramFile (Analysis a)
pf = ProgramFile (Analysis a)
pf'
  where
    ceMap :: ConstExpMap
ceMap = ProgramFile (Analysis a) -> ConstExpMap
forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap ProgramFile (Analysis a)
pf
    -- transform both the AST and the basic block graph
    pf' :: ProgramFile (Analysis a)
pf'   = (BBGr (Analysis a) -> BBGr (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
transformBB ((Gr (BB (Analysis a)) () -> Gr (BB (Analysis a)) ())
-> BBGr (Analysis a) -> BBGr (Analysis a)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap ((BB (Analysis a) -> BB (Analysis a))
-> Gr (BB (Analysis a)) () -> Gr (BB (Analysis a)) ()
forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap ((Expression (Analysis a) -> Expression (Analysis a))
-> BB (Analysis a) -> BB (Analysis a)
transformExpr Expression (Analysis a) -> Expression (Analysis a)
insertConstExp))) (ProgramFile (Analysis a) -> ProgramFile (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall a b. (a -> b) -> a -> b
$ (Expression (Analysis a) -> Expression (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Expression (Analysis a) -> Expression (Analysis a)
insertConstExp ProgramFile (Analysis a)
pf
    -- insert info about constExp into Expression annotation
    insertConstExp :: Expression (Analysis a) -> Expression (Analysis a)
    insertConstExp :: Expression (Analysis a) -> Expression (Analysis a)
insertConstExp Expression (Analysis a)
e = ((Analysis a -> Analysis a)
 -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a)
-> (Analysis a -> Analysis a)
-> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Analysis a -> Analysis a)
-> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a. Annotated f => (a -> a) -> f a -> f a
modifyAnnotation Expression (Analysis a)
e ((Analysis a -> Analysis a) -> Expression (Analysis a))
-> (Analysis a -> Analysis a) -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ \ Analysis a
a ->
      Analysis a
a { constExp :: Maybe Constant
constExp = Analysis a -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp Analysis a
a Maybe Constant -> Maybe Constant -> Maybe Constant
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (Maybe Constant) -> Maybe Constant
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ((Node -> ConstExpMap -> Maybe (Maybe Constant))
-> ConstExpMap -> Node -> Maybe (Maybe Constant)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node -> ConstExpMap -> Maybe (Maybe Constant)
forall a. Node -> IntMap a -> Maybe a
IM.lookup ConstExpMap
ceMap (Node -> Maybe (Maybe Constant))
-> Maybe Node -> Maybe (Maybe Constant)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)) }
    -- utility functions for transforming expressions tucked away inside of the basic block graph
    transformBB :: (BBGr (Analysis a) -> BBGr (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
    transformBB :: (BBGr (Analysis a) -> BBGr (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
transformBB = (BBGr (Analysis a) -> BBGr (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi
    transformExpr :: (Expression (Analysis a) -> Expression (Analysis a)) ->
                     [Block (Analysis a)] -> [Block (Analysis a)]
    transformExpr :: (Expression (Analysis a) -> Expression (Analysis a))
-> BB (Analysis a) -> BB (Analysis a)
transformExpr = (Expression (Analysis a) -> Expression (Analysis a))
-> BB (Analysis a) -> BB (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi

-- | Annotate AST with constant-expression information based on given
-- ParameterVarMap.
analyseParameterVars :: forall a. Data a => ParameterVarMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseParameterVars :: ParameterVarMap
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseParameterVars ParameterVarMap
pvm = (Expression (Analysis a) -> Expression (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Expression (Analysis a) -> Expression (Analysis a)
expr
  where
    expr :: Expression (Analysis a) -> Expression (Analysis a)
    expr :: Expression (Analysis a) -> Expression (Analysis a)
expr e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ ValVariable{})
      | Just Constant
con <- String -> ParameterVarMap -> Maybe Constant
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
e) ParameterVarMap
pvm = ((Analysis a -> Analysis a)
 -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a)
-> (Analysis a -> Analysis a)
-> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Analysis a -> Analysis a)
-> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a. Annotated f => (a -> a) -> f a -> f a
modifyAnnotation Expression (Analysis a)
e ((Analysis a -> Analysis a) -> Expression (Analysis a))
-> (Analysis a -> Analysis a) -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ \ Analysis a
a -> Analysis a
a { constExp :: Maybe Constant
constExp = Constant -> Maybe Constant
forall a. a -> Maybe a
Just Constant
con }
    expr Expression (Analysis a)
e = Expression (Analysis a)
e

--------------------------------------------------

-- | BackEdgeMap : bblock node -> bblock node
type BackEdgeMap = BBNodeMap BBNode

-- | Find the edges that 'loop back' in the graph; ones where the
-- target node dominates the source node. If the backedges are viewed
-- as (m -> n) then n is considered the 'loop-header'
genBackEdgeMap :: Graph gr => DomMap -> gr a b -> BackEdgeMap
genBackEdgeMap :: DomMap -> gr a b -> IDomMap
genBackEdgeMap DomMap
domMap = [(Node, Node)] -> IDomMap
forall a. [(Node, a)] -> IntMap a
IM.fromList ([(Node, Node)] -> IDomMap)
-> (gr a b -> [(Node, Node)]) -> gr a b -> IDomMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, Node) -> Bool) -> [(Node, Node)] -> [(Node, Node)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Node, Node) -> Bool
isBackEdge ([(Node, Node)] -> [(Node, Node)])
-> (gr a b -> [(Node, Node)]) -> gr a b -> [(Node, Node)]
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)]
edges
  where
    isBackEdge :: (Node, Node) -> Bool
isBackEdge (Node
s, Node
t) = Node
t Node -> IntSet -> Bool
`IS.member` String -> Maybe IntSet -> IntSet
forall a. String -> Maybe a -> a
fromJustMsg String
"genBackEdgeMap" (Node
s Node -> DomMap -> Maybe IntSet
forall a. Node -> IntMap a -> Maybe a
`IM.lookup` DomMap
domMap)

-- | For each loop in the program, find out which bblock nodes are
-- part of the loop by looking through the backedges (m, n) where n is
-- considered the 'loop-header', delete n from the map, and then do a
-- reverse-depth-first traversal starting from m to find all the nodes
-- of interest. Intersect this with the strongly-connected component
-- containing m, in case of 'improper' graphs with weird control
-- transfers.
loopNodes :: Graph gr => BackEdgeMap -> gr a b -> [BBNodeSet]
loopNodes :: IDomMap -> gr a b -> [IntSet]
loopNodes IDomMap
bedges gr a b
gr = [
    [Node] -> IntSet
IS.fromList (Node
nNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Node -> gr a b -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> [Node]
sccWith Node
n gr a b
gr) ([Node] -> gr a b -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Node]
rdfs [Node
m] (Node -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> gr a b
delNode Node
n gr a b
gr))) | (Node
m, Node
n) <- IDomMap -> [(Node, Node)]
forall a. IntMap a -> [(Node, a)]
IM.toList IDomMap
bedges
  ]

-- | LoopNodeMap : bblock node -> { bblock node }
type LoopNodeMap = BBNodeMap BBNodeSet

-- | Similar to loopNodes except it creates a map from loop-header to
-- the set of loop nodes, for each loop-header.
genLoopNodeMap :: Graph gr => BackEdgeMap -> gr a b -> LoopNodeMap
genLoopNodeMap :: IDomMap -> gr a b -> DomMap
genLoopNodeMap IDomMap
bedges gr a b
gr = [(Node, IntSet)] -> DomMap
forall a. [(Node, a)] -> IntMap a
IM.fromList [
    (Node
n, [Node] -> IntSet
IS.fromList (Node
nNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node] -> [Node] -> [Node]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Node -> gr a b -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> [Node]
sccWith Node
n gr a b
gr) ([Node] -> gr a b -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Node]
rdfs [Node
m] (Node -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> gr a b
delNode Node
n gr a b
gr)))) | (Node
m, Node
n) <- IDomMap -> [(Node, Node)]
forall a. IntMap a -> [(Node, a)]
IM.toList IDomMap
bedges
  ]

-- | The strongly connected component containing a given node.
sccWith :: (Graph gr) => Node -> gr a b -> [Node]
sccWith :: Node -> gr a b -> [Node]
sccWith Node
n gr a b
g = case ([Node] -> Bool) -> [[Node]] -> [[Node]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Node
n Node -> [Node] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([[Node]] -> [[Node]]) -> [[Node]] -> [[Node]]
forall a b. (a -> b) -> a -> b
$ gr a b -> [[Node]]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [[Node]]
scc gr a b
g of
  []  -> []
  [Node]
c:[[Node]]
_ -> [Node]
c

-- | Map of loop header nodes to the induction variables within that loop.
type InductionVarMap = BBNodeMap (S.Set Name)

-- | Basic induction variables are induction variables that are the
-- most easily derived from the syntactic structure of the program:
-- for example, directly appearing in a Do-statement.
basicInductionVars :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars :: IDomMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars IDomMap
bedges BBGr (Analysis a)
gr = (Set String -> Set String -> Set String)
-> [(Node, Set String)] -> InductionVarMap
forall a. (a -> a -> a) -> [(Node, a)] -> IntMap a
IM.fromListWith Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
S.union [
    (Node
n, String -> Set String
forall a. a -> Set a
S.singleton String
v) | (Node
_, Node
n)      <- IDomMap -> [(Node, Node)]
forall a. IntMap a -> [(Node, a)]
IM.toList IDomMap
bedges
                       , let Just BB (Analysis a)
bs = Gr (BB (Analysis a)) () -> Node -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
n
                       , b :: Block (Analysis a)
b@BlDo{}    <- BB (Analysis a)
bs
                       , String
v           <- Block (Analysis a) -> [String]
forall a. Data a => Block (Analysis a) -> [String]
blockVarDefs Block (Analysis a)
b
  ]

-- | For each loop in the program, figure out the names of the
-- induction variables: the variables that are used to represent the
-- current iteration of the loop.
genInductionVarMap :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap :: IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap = IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars

-- | InductionVarMapByASTBlock : AST-block label -> { name }
type InductionVarMapByASTBlock = ASTBlockNodeMap (S.Set Name)

-- | Generate an induction variable map that is indexed by the labels
-- on AST-blocks within those loops.
genInductionVarMapByASTBlock :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMapByASTBlock
genInductionVarMapByASTBlock :: IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMapByASTBlock IDomMap
bedges BBGr (Analysis a)
gr = InductionVarMap -> InductionVarMap
loopsToLabs (InductionVarMap -> InductionVarMap)
-> (BBGr (Analysis a) -> InductionVarMap)
-> BBGr (Analysis a)
-> InductionVarMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap IDomMap
bedges (BBGr (Analysis a) -> InductionVarMap)
-> BBGr (Analysis a) -> InductionVarMap
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a)
gr
  where
    lnMap :: DomMap
lnMap       = IDomMap -> Gr (BB (Analysis a)) () -> DomMap
forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> DomMap
genLoopNodeMap IDomMap
bedges (Gr (BB (Analysis a)) () -> DomMap)
-> Gr (BB (Analysis a)) () -> DomMap
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr
    get' :: OutF IntSet
get'        = IntSet -> Maybe IntSet -> IntSet
forall a. a -> Maybe a -> a
fromMaybe (String -> IntSet
forall a. HasCallStack => String -> a
error String
"missing loop-header node") (Maybe IntSet -> IntSet) -> (Node -> Maybe IntSet) -> OutF IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> DomMap -> Maybe IntSet) -> DomMap -> Node -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node -> DomMap -> Maybe IntSet
forall a. Node -> IntMap a -> Maybe a
IM.lookup DomMap
lnMap
    astLabels :: Node -> [Node]
astLabels Node
n = [ Node
i | Block (Analysis a)
b <- (Maybe (BB (Analysis a)) -> BB (Analysis a)
forall from to. Biplate from to => from -> [to]
universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (Gr (BB (Analysis a)) () -> Node -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
n)
                      , let Just Node
i = Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) ]
    loopsToLabs :: InductionVarMap -> InductionVarMap
loopsToLabs         = (Set String -> Set String -> Set String)
-> [(Node, Set String)] -> InductionVarMap
forall a. (a -> a -> a) -> [(Node, a)] -> IntMap a
IM.fromListWith Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
S.union ([(Node, Set String)] -> InductionVarMap)
-> (InductionVarMap -> [(Node, Set String)])
-> InductionVarMap
-> InductionVarMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Node, Set String) -> [(Node, Set String)])
-> [(Node, Set String)] -> [(Node, Set String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Node, Set String) -> [(Node, Set String)]
forall t. (Node, t) -> [(Node, t)]
loopToLabs ([(Node, Set String)] -> [(Node, Set String)])
-> (InductionVarMap -> [(Node, Set String)])
-> InductionVarMap
-> [(Node, Set String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InductionVarMap -> [(Node, Set String)]
forall a. IntMap a -> [(Node, a)]
IM.toList
    loopToLabs :: (Node, t) -> [(Node, t)]
loopToLabs (Node
n, t
ivs) = ((Node -> (Node, t)) -> [Node] -> [(Node, t)]
forall a b. (a -> b) -> [a] -> [b]
map (,t
ivs) ([Node] -> [(Node, t)]) -> (Node -> [Node]) -> Node -> [(Node, t)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node]
astLabels) (Node -> [(Node, t)]) -> [Node] -> [(Node, t)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IntSet -> [Node]
IS.toList (OutF IntSet
get' Node
n)

-- It's a 'lattice' but will leave it ungeneralised for the moment.
data InductionExpr
  = IETop                 -- not enough info
  | IELinear !Name !Int !Int -- Basic induction var 'Name' * coefficient + offset
  | IEBottom              -- too difficult
  deriving (Node -> InductionExpr -> String -> String
[InductionExpr] -> String -> String
InductionExpr -> String
(Node -> InductionExpr -> String -> String)
-> (InductionExpr -> String)
-> ([InductionExpr] -> String -> String)
-> Show InductionExpr
forall a.
(Node -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [InductionExpr] -> String -> String
$cshowList :: [InductionExpr] -> String -> String
show :: InductionExpr -> String
$cshow :: InductionExpr -> String
showsPrec :: Node -> InductionExpr -> String -> String
$cshowsPrec :: Node -> InductionExpr -> String -> String
Show, InductionExpr -> InductionExpr -> Bool
(InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool) -> Eq InductionExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InductionExpr -> InductionExpr -> Bool
$c/= :: InductionExpr -> InductionExpr -> Bool
== :: InductionExpr -> InductionExpr -> Bool
$c== :: InductionExpr -> InductionExpr -> Bool
Eq, Eq InductionExpr
Eq InductionExpr
-> (InductionExpr -> InductionExpr -> Ordering)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> InductionExpr)
-> (InductionExpr -> InductionExpr -> InductionExpr)
-> Ord InductionExpr
InductionExpr -> InductionExpr -> Bool
InductionExpr -> InductionExpr -> Ordering
InductionExpr -> InductionExpr -> InductionExpr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InductionExpr -> InductionExpr -> InductionExpr
$cmin :: InductionExpr -> InductionExpr -> InductionExpr
max :: InductionExpr -> InductionExpr -> InductionExpr
$cmax :: InductionExpr -> InductionExpr -> InductionExpr
>= :: InductionExpr -> InductionExpr -> Bool
$c>= :: InductionExpr -> InductionExpr -> Bool
> :: InductionExpr -> InductionExpr -> Bool
$c> :: InductionExpr -> InductionExpr -> Bool
<= :: InductionExpr -> InductionExpr -> Bool
$c<= :: InductionExpr -> InductionExpr -> Bool
< :: InductionExpr -> InductionExpr -> Bool
$c< :: InductionExpr -> InductionExpr -> Bool
compare :: InductionExpr -> InductionExpr -> Ordering
$ccompare :: InductionExpr -> InductionExpr -> Ordering
$cp1Ord :: Eq InductionExpr
Ord, Typeable, (forall x. InductionExpr -> Rep InductionExpr x)
-> (forall x. Rep InductionExpr x -> InductionExpr)
-> Generic InductionExpr
forall x. Rep InductionExpr x -> InductionExpr
forall x. InductionExpr -> Rep InductionExpr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InductionExpr x -> InductionExpr
$cfrom :: forall x. InductionExpr -> Rep InductionExpr x
Generic, Typeable InductionExpr
DataType
Constr
Typeable InductionExpr
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> InductionExpr -> c InductionExpr)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c InductionExpr)
-> (InductionExpr -> Constr)
-> (InductionExpr -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c InductionExpr))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c InductionExpr))
-> ((forall b. Data b => b -> b) -> InductionExpr -> InductionExpr)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> InductionExpr -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> InductionExpr -> r)
-> (forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u])
-> (forall u.
    Node -> (forall d. Data d => d -> u) -> InductionExpr -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr)
-> Data InductionExpr
InductionExpr -> DataType
InductionExpr -> Constr
(forall b. Data b => b -> b) -> InductionExpr -> InductionExpr
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> InductionExpr -> c InductionExpr
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c InductionExpr
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Node -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Node -> (forall d. Data d => d -> u) -> InductionExpr -> u
forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c InductionExpr
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> InductionExpr -> c InductionExpr
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c InductionExpr)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c InductionExpr)
$cIEBottom :: Constr
$cIELinear :: Constr
$cIETop :: Constr
$tInductionExpr :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
gmapMp :: (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
gmapM :: (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
gmapQi :: Node -> (forall d. Data d => d -> u) -> InductionExpr -> u
$cgmapQi :: forall u.
Node -> (forall d. Data d => d -> u) -> InductionExpr -> u
gmapQ :: (forall d. Data d => d -> u) -> InductionExpr -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
gmapT :: (forall b. Data b => b -> b) -> InductionExpr -> InductionExpr
$cgmapT :: (forall b. Data b => b -> b) -> InductionExpr -> InductionExpr
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c InductionExpr)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c InductionExpr)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c InductionExpr)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c InductionExpr)
dataTypeOf :: InductionExpr -> DataType
$cdataTypeOf :: InductionExpr -> DataType
toConstr :: InductionExpr -> Constr
$ctoConstr :: InductionExpr -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c InductionExpr
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c InductionExpr
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> InductionExpr -> c InductionExpr
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> InductionExpr -> c InductionExpr
$cp1Data :: Typeable InductionExpr
Data)
instance NFData InductionExpr
type DerivedInductionMap = ASTExprNodeMap InductionExpr

data IEFlow = IEFlow { IEFlow -> Map String InductionExpr
ieFlowVars :: M.Map Name InductionExpr, IEFlow -> DerivedInductionMap
ieFlowExprs :: !DerivedInductionMap }
  deriving (Node -> IEFlow -> String -> String
[IEFlow] -> String -> String
IEFlow -> String
(Node -> IEFlow -> String -> String)
-> (IEFlow -> String)
-> ([IEFlow] -> String -> String)
-> Show IEFlow
forall a.
(Node -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [IEFlow] -> String -> String
$cshowList :: [IEFlow] -> String -> String
show :: IEFlow -> String
$cshow :: IEFlow -> String
showsPrec :: Node -> IEFlow -> String -> String
$cshowsPrec :: Node -> IEFlow -> String -> String
Show, IEFlow -> IEFlow -> Bool
(IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool) -> Eq IEFlow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IEFlow -> IEFlow -> Bool
$c/= :: IEFlow -> IEFlow -> Bool
== :: IEFlow -> IEFlow -> Bool
$c== :: IEFlow -> IEFlow -> Bool
Eq, Eq IEFlow
Eq IEFlow
-> (IEFlow -> IEFlow -> Ordering)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> IEFlow)
-> (IEFlow -> IEFlow -> IEFlow)
-> Ord IEFlow
IEFlow -> IEFlow -> Bool
IEFlow -> IEFlow -> Ordering
IEFlow -> IEFlow -> IEFlow
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IEFlow -> IEFlow -> IEFlow
$cmin :: IEFlow -> IEFlow -> IEFlow
max :: IEFlow -> IEFlow -> IEFlow
$cmax :: IEFlow -> IEFlow -> IEFlow
>= :: IEFlow -> IEFlow -> Bool
$c>= :: IEFlow -> IEFlow -> Bool
> :: IEFlow -> IEFlow -> Bool
$c> :: IEFlow -> IEFlow -> Bool
<= :: IEFlow -> IEFlow -> Bool
$c<= :: IEFlow -> IEFlow -> Bool
< :: IEFlow -> IEFlow -> Bool
$c< :: IEFlow -> IEFlow -> Bool
compare :: IEFlow -> IEFlow -> Ordering
$ccompare :: IEFlow -> IEFlow -> Ordering
$cp1Ord :: Eq IEFlow
Ord, Typeable, (forall x. IEFlow -> Rep IEFlow x)
-> (forall x. Rep IEFlow x -> IEFlow) -> Generic IEFlow
forall x. Rep IEFlow x -> IEFlow
forall x. IEFlow -> Rep IEFlow x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IEFlow x -> IEFlow
$cfrom :: forall x. IEFlow -> Rep IEFlow x
Generic, Typeable IEFlow
DataType
Constr
Typeable IEFlow
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> IEFlow -> c IEFlow)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c IEFlow)
-> (IEFlow -> Constr)
-> (IEFlow -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c IEFlow))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c IEFlow))
-> ((forall b. Data b => b -> b) -> IEFlow -> IEFlow)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> IEFlow -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> IEFlow -> r)
-> (forall u. (forall d. Data d => d -> u) -> IEFlow -> [u])
-> (forall u. Node -> (forall d. Data d => d -> u) -> IEFlow -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow)
-> Data IEFlow
IEFlow -> DataType
IEFlow -> Constr
(forall b. Data b => b -> b) -> IEFlow -> IEFlow
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> IEFlow -> c IEFlow
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c IEFlow
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Node -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Node -> (forall d. Data d => d -> u) -> IEFlow -> u
forall u. (forall d. Data d => d -> u) -> IEFlow -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c IEFlow
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> IEFlow -> c IEFlow
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c IEFlow)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c IEFlow)
$cIEFlow :: Constr
$tIEFlow :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
gmapMp :: (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
gmapM :: (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
gmapQi :: Node -> (forall d. Data d => d -> u) -> IEFlow -> u
$cgmapQi :: forall u. Node -> (forall d. Data d => d -> u) -> IEFlow -> u
gmapQ :: (forall d. Data d => d -> u) -> IEFlow -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> IEFlow -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
gmapT :: (forall b. Data b => b -> b) -> IEFlow -> IEFlow
$cgmapT :: (forall b. Data b => b -> b) -> IEFlow -> IEFlow
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c IEFlow)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c IEFlow)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c IEFlow)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c IEFlow)
dataTypeOf :: IEFlow -> DataType
$cdataTypeOf :: IEFlow -> DataType
toConstr :: IEFlow -> Constr
$ctoConstr :: IEFlow -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c IEFlow
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c IEFlow
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> IEFlow -> c IEFlow
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> IEFlow -> c IEFlow
$cp1Data :: Typeable IEFlow
Data)
instance NFData IEFlow

ieFlowInsertVar :: Name -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertVar :: String -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertVar String
v InductionExpr
ie IEFlow
flow = IEFlow
flow { ieFlowVars :: Map String InductionExpr
ieFlowVars = String
-> InductionExpr
-> Map String InductionExpr
-> Map String InductionExpr
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
v InductionExpr
ie (IEFlow -> Map String InductionExpr
ieFlowVars IEFlow
flow) }

ieFlowInsertExpr :: ASTExprNode -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr :: Node -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr Node
i InductionExpr
ie IEFlow
flow = IEFlow
flow { ieFlowExprs :: DerivedInductionMap
ieFlowExprs = Node -> InductionExpr -> DerivedInductionMap -> DerivedInductionMap
forall a. Node -> a -> IntMap a -> IntMap a
IMS.insert Node
i InductionExpr
ie (IEFlow -> DerivedInductionMap
ieFlowExprs IEFlow
flow) }

emptyIEFlow :: IEFlow
emptyIEFlow :: IEFlow
emptyIEFlow = Map String InductionExpr -> DerivedInductionMap -> IEFlow
IEFlow Map String InductionExpr
forall k a. Map k a
M.empty DerivedInductionMap
forall a. IntMap a
IMS.empty

joinIEFlows :: [IEFlow] -> IEFlow
joinIEFlows :: [IEFlow] -> IEFlow
joinIEFlows [IEFlow]
flows = Map String InductionExpr -> DerivedInductionMap -> IEFlow
IEFlow Map String InductionExpr
flowV DerivedInductionMap
flowE
  where
    flowV :: Map String InductionExpr
flowV = (InductionExpr -> InductionExpr -> InductionExpr)
-> [Map String InductionExpr] -> Map String InductionExpr
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith InductionExpr -> InductionExpr -> InductionExpr
joinInductionExprs ((IEFlow -> Map String InductionExpr)
-> [IEFlow] -> [Map String InductionExpr]
forall a b. (a -> b) -> [a] -> [b]
map IEFlow -> Map String InductionExpr
ieFlowVars [IEFlow]
flows)
    flowE :: DerivedInductionMap
flowE = (InductionExpr -> InductionExpr -> InductionExpr)
-> [DerivedInductionMap] -> DerivedInductionMap
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IMS.unionsWith InductionExpr -> InductionExpr -> InductionExpr
joinInductionExprs ((IEFlow -> DerivedInductionMap)
-> [IEFlow] -> [DerivedInductionMap]
forall a b. (a -> b) -> [a] -> [b]
map IEFlow -> DerivedInductionMap
ieFlowExprs [IEFlow]
flows)

-- | For every expression in a loop, try to derive its relationship to
-- a basic induction variable.
genDerivedInductionMap :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> DerivedInductionMap
genDerivedInductionMap :: IDomMap -> BBGr (Analysis a) -> DerivedInductionMap
genDerivedInductionMap IDomMap
bedges BBGr (Analysis a)
gr = IEFlow -> DerivedInductionMap
ieFlowExprs (IEFlow -> DerivedInductionMap)
-> (IntMap (IEFlow, IEFlow) -> IEFlow)
-> IntMap (IEFlow, IEFlow)
-> DerivedInductionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IEFlow] -> IEFlow
joinIEFlows ([IEFlow] -> IEFlow)
-> (IntMap (IEFlow, IEFlow) -> [IEFlow])
-> IntMap (IEFlow, IEFlow)
-> IEFlow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IEFlow, IEFlow) -> IEFlow) -> [(IEFlow, IEFlow)] -> [IEFlow]
forall a b. (a -> b) -> [a] -> [b]
map (IEFlow, IEFlow) -> IEFlow
forall a b. (a, b) -> b
snd ([(IEFlow, IEFlow)] -> [IEFlow])
-> (IntMap (IEFlow, IEFlow) -> [(IEFlow, IEFlow)])
-> IntMap (IEFlow, IEFlow)
-> [IEFlow]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (IEFlow, IEFlow) -> [(IEFlow, IEFlow)]
forall a. IntMap a -> [a]
IMS.elems (IntMap (IEFlow, IEFlow) -> [(IEFlow, IEFlow)])
-> (IntMap (IEFlow, IEFlow) -> IntMap (IEFlow, IEFlow))
-> IntMap (IEFlow, IEFlow)
-> [(IEFlow, IEFlow)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> (IEFlow, IEFlow) -> Bool)
-> IntMap (IEFlow, IEFlow) -> IntMap (IEFlow, IEFlow)
forall a. (Node -> a -> Bool) -> IntMap a -> IntMap a
IMS.filterWithKey Node -> (IEFlow, IEFlow) -> Bool
forall p. Node -> p -> Bool
inLoop (IntMap (IEFlow, IEFlow) -> DerivedInductionMap)
-> IntMap (IEFlow, IEFlow) -> DerivedInductionMap
forall a b. (a -> b) -> a -> b
$ IntMap (IEFlow, IEFlow)
inOutMaps
  where
    bivMap :: InductionVarMap
bivMap = IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars IDomMap
bedges BBGr (Analysis a)
gr -- basic indvars indexed by loop header node
    loopNodeSet :: IntSet
loopNodeSet = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions (IDomMap -> Gr (BB (Analysis a)) () -> [IntSet]
forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> [IntSet]
loopNodes IDomMap
bedges (Gr (BB (Analysis a)) () -> [IntSet])
-> Gr (BB (Analysis a)) () -> [IntSet]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) -- set of nodes within a loop
    inLoop :: Node -> p -> Bool
inLoop Node
i p
_ = Node
i Node -> IntSet -> Bool
`IS.member` IntSet
loopNodeSet

    step :: IEFlow -> Block (Analysis a) -> IEFlow
    step :: IEFlow -> Block (Analysis a) -> IEFlow
step !IEFlow
flow Block (Analysis a)
b = case Block (Analysis a)
b of
      BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StExpressionAssign Analysis a
_ SrcSpan
_ lv :: Expression (Analysis a)
lv@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable String
_)) Expression (Analysis a)
rhs)
        | Maybe Node
_ <- Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
rhs), IEFlow
flow'' <- String -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertVar (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
lv) (IEFlow -> Expression (Analysis a) -> InductionExpr
forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExprMemo IEFlow
flow' Expression (Analysis a)
rhs) IEFlow
flow'
        -> IEFlow -> Expression (Analysis a) -> IEFlow
stepExpr IEFlow
flow'' Expression (Analysis a)
lv
      Block (Analysis a)
_ -> IEFlow
flow'
      where
        -- flow' = foldl' stepExpr flow (universeBi b)
        flow' :: IEFlow
flow' = State IEFlow (Block (Analysis a)) -> IEFlow -> IEFlow
forall s a. State s a -> s -> s
execState ((Expression (Analysis a) -> State IEFlow (Expression (Analysis a)))
-> Block (Analysis a) -> State IEFlow (Block (Analysis a))
trans (\ Expression (Analysis a)
e -> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e State IEFlow InductionExpr
-> State IEFlow (Expression (Analysis a))
-> State IEFlow (Expression (Analysis a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expression (Analysis a) -> State IEFlow (Expression (Analysis a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression (Analysis a)
e) Block (Analysis a)
b) IEFlow
flow -- monadic version
        trans :: (Expression (Analysis a) -> State IEFlow (Expression (Analysis a)))
-> Block (Analysis a) -> State IEFlow (Block (Analysis a))
trans = (Expression (Analysis a) -> State IEFlow (Expression (Analysis a)))
-> Block (Analysis a) -> State IEFlow (Block (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM :: (Expression (Analysis a) -> State IEFlow (Expression (Analysis a))) -> Block (Analysis a) -> State IEFlow (Block (Analysis a))


    stepExpr :: IEFlow -> Expression (Analysis a) -> IEFlow
    stepExpr :: IEFlow -> Expression (Analysis a) -> IEFlow
stepExpr !IEFlow
flow Expression (Analysis a)
e = Node -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr Node
label InductionExpr
ie IEFlow
flow
      where
        ie :: InductionExpr
ie = IEFlow -> Expression (Analysis a) -> InductionExpr
forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr IEFlow
flow Expression (Analysis a)
e
        label :: Node
label = String -> Maybe Node -> Node
forall a. String -> Maybe a -> a
fromJustMsg String
"stepExpr" (Maybe Node -> Node) -> Maybe Node -> Node
forall a b. (a -> b) -> a -> b
$ Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)

    out :: InF IEFlow -> OutF IEFlow
    out :: InF IEFlow -> InF IEFlow
out InF IEFlow
inF Node
node = IEFlow
flow'
      where
        flow :: IEFlow
flow = [IEFlow] -> IEFlow
joinIEFlows [(IEFlow, IEFlow) -> IEFlow
forall a b. (a, b) -> a
fst (Node -> (IEFlow, IEFlow)
initF Node
node), InF IEFlow
inF Node
node]
        flow' :: IEFlow
flow' = (IEFlow -> Block (Analysis a) -> IEFlow)
-> IEFlow -> BB (Analysis a) -> IEFlow
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IEFlow -> Block (Analysis a) -> IEFlow
step IEFlow
flow (String -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. String -> Maybe a -> a
fromJustMsg (String
"analyseDerivedIE out(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
node String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Node -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
node)

    inn :: OutF IEFlow -> InF IEFlow
    inn :: InF IEFlow -> InF IEFlow
inn InF IEFlow
outF Node
node = [IEFlow] -> IEFlow
joinIEFlows [ InF IEFlow
outF Node
p | Node
p <- Gr (BB (Analysis a)) () -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
pre (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Node
node ]

    initF :: Node -> InOut IEFlow
    initF :: Node -> (IEFlow, IEFlow)
initF Node
node = case Node -> InductionVarMap -> Maybe (Set String)
forall a. Node -> IntMap a -> Maybe a
IMS.lookup Node
node InductionVarMap
bivMap of
                   Just Set String
set -> (Map String InductionExpr -> DerivedInductionMap -> IEFlow
IEFlow ([(String, InductionExpr)] -> Map String InductionExpr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (String
n, String -> Node -> Node -> InductionExpr
IELinear String
n Node
1 Node
0) | String
n <- Set String -> [String]
forall a. Set a -> [a]
S.toList Set String
set ]) DerivedInductionMap
forall a. IntMap a
IMS.empty, IEFlow
emptyIEFlow)
                   Maybe (Set String)
Nothing  -> (IEFlow
emptyIEFlow, IEFlow
emptyIEFlow)

    inOutMaps :: IntMap (IEFlow, IEFlow)
inOutMaps = BBGr (Analysis a)
-> (Node -> (IEFlow, IEFlow))
-> OrderF (Analysis a)
-> (InF IEFlow -> InF IEFlow)
-> (InF IEFlow -> InF IEFlow)
-> IntMap (IEFlow, IEFlow)
forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Node -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr (Analysis a)
gr Node -> (IEFlow, IEFlow)
initF OrderF (Analysis a)
forall a. OrderF a
revPostOrder InF IEFlow -> InF IEFlow
inn InF IEFlow -> InF IEFlow
out

derivedInductionExprMemo :: Data a => IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExprMemo :: IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExprMemo IEFlow
flow Expression (Analysis a)
e
  | Just Node
label <- Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)
  , Just InductionExpr
iexpr <- Node -> DerivedInductionMap -> Maybe InductionExpr
forall a. Node -> IntMap a -> Maybe a
IMS.lookup Node
label (IEFlow -> DerivedInductionMap
ieFlowExprs IEFlow
flow) = InductionExpr
iexpr
  | Bool
otherwise = IEFlow -> Expression (Analysis a) -> InductionExpr
forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr IEFlow
flow Expression (Analysis a)
e

-- Compute the relationship between the given expression and a basic
-- induction variable, if possible.
derivedInductionExpr :: Data a => IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr :: IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr IEFlow
flow Expression (Analysis a)
e = case Expression (Analysis a)
e of
  v :: Expression (Analysis a)
v@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable String
_))   -> InductionExpr -> Maybe InductionExpr -> InductionExpr
forall a. a -> Maybe a -> a
fromMaybe InductionExpr
IETop (Maybe InductionExpr -> InductionExpr)
-> Maybe InductionExpr -> InductionExpr
forall a b. (a -> b) -> a -> b
$ String -> Map String InductionExpr -> Maybe InductionExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v) (IEFlow -> Map String InductionExpr
ieFlowVars IEFlow
flow)
  ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
str)
    | Just Integer
i <- String -> Maybe Integer
readInteger String
str      -> String -> Node -> Node -> InductionExpr
IELinear String
"" Node
0 (Integer -> Node
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
  ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Addition Expression (Analysis a)
e1 Expression (Analysis a)
e2       -> Expression (Analysis a) -> InductionExpr
derive Expression (Analysis a)
e1 InductionExpr -> InductionExpr -> InductionExpr
`addInductionExprs` Expression (Analysis a) -> InductionExpr
derive Expression (Analysis a)
e2
  ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Subtraction Expression (Analysis a)
e1 Expression (Analysis a)
e2    -> Expression (Analysis a) -> InductionExpr
derive Expression (Analysis a)
e1 InductionExpr -> InductionExpr -> InductionExpr
`addInductionExprs` InductionExpr -> InductionExpr
negInductionExpr (Expression (Analysis a) -> InductionExpr
derive Expression (Analysis a)
e2)
  ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Multiplication Expression (Analysis a)
e1 Expression (Analysis a)
e2 -> Expression (Analysis a) -> InductionExpr
derive Expression (Analysis a)
e1 InductionExpr -> InductionExpr -> InductionExpr
`mulInductionExprs` Expression (Analysis a) -> InductionExpr
derive Expression (Analysis a)
e2
  Expression (Analysis a)
_                                  -> InductionExpr
IETop -- unsure
  where
    derive :: Expression (Analysis a) -> InductionExpr
derive = IEFlow -> Expression (Analysis a) -> InductionExpr
forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr IEFlow
flow

-- Monadic version using State.
derivedInductionExprM :: Data a => Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM :: Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e = do
  IEFlow
flow <- StateT IEFlow Identity IEFlow
forall s (m :: * -> *). MonadState s m => m s
get
  let derive :: Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e' | Just Node
label <- Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e')
                , Just InductionExpr
iexpr <- Node -> DerivedInductionMap -> Maybe InductionExpr
forall a. Node -> IntMap a -> Maybe a
IMS.lookup Node
label (IEFlow -> DerivedInductionMap
ieFlowExprs IEFlow
flow) = InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure InductionExpr
iexpr
                | Bool
otherwise = Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e'
  InductionExpr
ie <- case Expression (Analysis a)
e of
        v :: Expression (Analysis a)
v@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable String
_))   -> InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InductionExpr -> State IEFlow InductionExpr)
-> (Maybe InductionExpr -> InductionExpr)
-> Maybe InductionExpr
-> State IEFlow InductionExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InductionExpr -> Maybe InductionExpr -> InductionExpr
forall a. a -> Maybe a -> a
fromMaybe InductionExpr
IETop (Maybe InductionExpr -> State IEFlow InductionExpr)
-> Maybe InductionExpr -> State IEFlow InductionExpr
forall a b. (a -> b) -> a -> b
$ String -> Map String InductionExpr -> Maybe InductionExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v) (IEFlow -> Map String InductionExpr
ieFlowVars IEFlow
flow)
        ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
str)
          | Just Integer
i <- String -> Maybe Integer
readInteger String
str      -> InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InductionExpr -> State IEFlow InductionExpr)
-> InductionExpr -> State IEFlow InductionExpr
forall a b. (a -> b) -> a -> b
$ String -> Node -> Node -> InductionExpr
IELinear String
"" Node
0 (Integer -> Node
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
        ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Addition Expression (Analysis a)
e1 Expression (Analysis a)
e2       -> InductionExpr -> InductionExpr -> InductionExpr
addInductionExprs (InductionExpr -> InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr
-> StateT IEFlow Identity (InductionExpr -> InductionExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 StateT IEFlow Identity (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e2
        ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Subtraction Expression (Analysis a)
e1 Expression (Analysis a)
e2    -> InductionExpr -> InductionExpr -> InductionExpr
addInductionExprs (InductionExpr -> InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr
-> StateT IEFlow Identity (InductionExpr -> InductionExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 StateT IEFlow Identity (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (InductionExpr -> InductionExpr
negInductionExpr (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e2)
        ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Multiplication Expression (Analysis a)
e1 Expression (Analysis a)
e2 -> InductionExpr -> InductionExpr -> InductionExpr
mulInductionExprs (InductionExpr -> InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr
-> StateT IEFlow Identity (InductionExpr -> InductionExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 StateT IEFlow Identity (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e2
        Expression (Analysis a)
_                                  -> InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InductionExpr -> State IEFlow InductionExpr)
-> InductionExpr -> State IEFlow InductionExpr
forall a b. (a -> b) -> a -> b
$ InductionExpr
IETop -- unsure
  let Just Node
label = Analysis a -> Maybe Node
forall a. Analysis a -> Maybe Node
insLabel (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)
  IEFlow -> StateT IEFlow Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IEFlow -> StateT IEFlow Identity ())
-> IEFlow -> StateT IEFlow Identity ()
forall a b. (a -> b) -> a -> b
$ Node -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr Node
label InductionExpr
ie IEFlow
flow
  InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure InductionExpr
ie

-- Combine two induction variable relationships through addition.
addInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
addInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
addInductionExprs (IELinear String
ln Node
lc Node
lo) (IELinear String
rn Node
rc Node
ro)
  | String
ln String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
rn                = String -> Node -> Node -> InductionExpr
IELinear String
ln (Node
lc Node -> Node -> Node
forall a. Num a => a -> a -> a
+ Node
rc) (Node
lo Node -> Node -> Node
forall a. Num a => a -> a -> a
+ Node
ro)
  | Node
lc Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
== Node
0                 = String -> Node -> Node -> InductionExpr
IELinear String
rn Node
rc (Node
lo Node -> Node -> Node
forall a. Num a => a -> a -> a
+ Node
ro)
  | Node
rc Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
== Node
0                 = String -> Node -> Node -> InductionExpr
IELinear String
ln Node
lc (Node
lo Node -> Node -> Node
forall a. Num a => a -> a -> a
+ Node
ro)
  | Bool
otherwise               = InductionExpr
IEBottom -- maybe for future...
addInductionExprs InductionExpr
_ InductionExpr
IETop = InductionExpr
IETop
addInductionExprs InductionExpr
IETop InductionExpr
_ = InductionExpr
IETop
addInductionExprs InductionExpr
_ InductionExpr
_       = InductionExpr
IEBottom

-- Negate an induction variable relationship.
negInductionExpr :: InductionExpr -> InductionExpr
negInductionExpr :: InductionExpr -> InductionExpr
negInductionExpr (IELinear String
n Node
c Node
o) = String -> Node -> Node -> InductionExpr
IELinear String
n (-Node
c) (-Node
o)
negInductionExpr InductionExpr
IETop            = InductionExpr
IETop
negInductionExpr InductionExpr
_                = InductionExpr
IEBottom

-- Combine two induction variable relationships through multiplication.
mulInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
mulInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
mulInductionExprs (IELinear String
"" Node
_ Node
lo) (IELinear String
rn Node
rc Node
ro) = String -> Node -> Node -> InductionExpr
IELinear String
rn (Node
rc Node -> Node -> Node
forall a. Num a => a -> a -> a
* Node
lo) (Node
ro Node -> Node -> Node
forall a. Num a => a -> a -> a
* Node
lo)
mulInductionExprs (IELinear String
ln Node
lc Node
lo) (IELinear String
"" Node
_ Node
ro) = String -> Node -> Node -> InductionExpr
IELinear String
ln (Node
lc Node -> Node -> Node
forall a. Num a => a -> a -> a
* Node
ro) (Node
lo Node -> Node -> Node
forall a. Num a => a -> a -> a
* Node
ro)
mulInductionExprs InductionExpr
_ InductionExpr
IETop                                 = InductionExpr
IETop
mulInductionExprs InductionExpr
IETop InductionExpr
_                                 = InductionExpr
IETop
mulInductionExprs InductionExpr
_ InductionExpr
_                                     = InductionExpr
IEBottom

-- Combine two induction variable relationships using lattice 'join'.
joinInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
joinInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr
joinInductionExprs InductionExpr
ie1 InductionExpr
IETop = InductionExpr
ie1
joinInductionExprs InductionExpr
IETop InductionExpr
ie2 = InductionExpr
ie2
joinInductionExprs InductionExpr
ie1 InductionExpr
ie2
  | InductionExpr
ie1 InductionExpr -> InductionExpr -> Bool
forall a. Eq a => a -> a -> Bool
== InductionExpr
ie2               = InductionExpr
ie1
  | Bool
otherwise                = InductionExpr
IEBottom -- too difficult to combine

--------------------------------------------------

-- | Show some information about dataflow analyses.
showDataFlow :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String
showDataFlow :: ProgramFile (Analysis a) -> String
showDataFlow ProgramFile (Analysis a)
pf = ProgramUnit (Analysis a) -> String
perPU (ProgramUnit (Analysis a) -> String)
-> [ProgramUnit (Analysis a)] -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
uni ProgramFile (Analysis a)
pf
  where
    uni :: ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
uni = forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    perPU :: ProgramUnit (Analysis a) -> String
perPU ProgramUnit (Analysis a)
pu | Analysis { bBlocks :: forall a. Analysis a -> Maybe (BBGr (Analysis a))
bBlocks = Just BBGr (Analysis a)
gr } <- ProgramUnit (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu =
      String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BBGr (Analysis a) -> String
dfStr BBGr (Analysis a)
gr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
forall a. Show a => a -> String
show (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = Node -> Char -> String
forall a. Node -> a -> [a]
replicate (String -> Node
forall (t :: * -> *) a. Foldable t => t a -> Node
length String
p) Char
'-'
            dfStr :: BBGr (Analysis a) -> String
dfStr BBGr (Analysis a)
gr = (\ (String
l, String
x) -> Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) ((String, String) -> String) -> [(String, String)] -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [
                         (String
"callMap",      CallMap -> String
forall a. Show a => a -> String
show CallMap
cm)
                       , (String
"postOrder",    [Node] -> String
forall a. Show a => a -> String
show (OrderF (Analysis a)
forall a. OrderF a
postOrder BBGr (Analysis a)
gr))
                       , (String
"revPostOrder", [Node] -> String
forall a. Show a => a -> String
show (OrderF (Analysis a)
forall a. OrderF a
revPostOrder BBGr (Analysis a)
gr))
                       , (String
"revPreOrder",  [Node] -> String
forall a. Show a => a -> String
show (OrderF (Analysis a)
forall a. OrderF a
revPreOrder BBGr (Analysis a)
gr))
                       , (String
"dominators",   DomMap -> String
forall a. Show a => a -> String
show (BBGr (Analysis a) -> DomMap
forall a. BBGr a -> DomMap
dominators BBGr (Analysis a)
gr))
                       , (String
"iDominators",  IDomMap -> String
forall a. Show a => a -> String
show (BBGr (Analysis a) -> IDomMap
forall a. BBGr a -> IDomMap
iDominators BBGr (Analysis a)
gr))
                       , (String
"defMap",       DefMap -> String
forall a. Show a => a -> String
show DefMap
dm)
                       , (String
"lva",          [(Node, InOut (Set String))] -> String
forall a. Show a => a -> String
show (InOutMap (Set String) -> [(Node, InOut (Set String))]
forall a. IntMap a -> [(Node, a)]
IM.toList (InOutMap (Set String) -> [(Node, InOut (Set String))])
-> InOutMap (Set String) -> [(Node, InOut (Set String))]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> InOutMap (Set String)
lva BBGr (Analysis a)
gr))
                       , (String
"rd",           [(Node, (IntSet, IntSet))] -> String
forall a. Show a => a -> String
show (IntMap (IntSet, IntSet) -> [(Node, (IntSet, IntSet))]
forall a. IntMap a -> [(Node, a)]
IM.toList (IntMap (IntSet, IntSet) -> [(Node, (IntSet, IntSet))])
-> IntMap (IntSet, IntSet) -> [(Node, (IntSet, IntSet))]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> IntMap (IntSet, IntSet)
rd BBGr (Analysis a)
gr))
                       , (String
"backEdges",    IDomMap -> String
forall a. Show a => a -> String
show IDomMap
bedges)
                       , (String
"topsort",      [Node] -> String
forall a. Show a => a -> String
show (Gr (BB (Analysis a)) () -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
topsort (Gr (BB (Analysis a)) () -> [Node])
-> Gr (BB (Analysis a)) () -> [Node]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr))
                       , (String
"scc ",         [[Node]] -> String
forall a. Show a => a -> String
show (Gr (BB (Analysis a)) () -> [[Node]]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [[Node]]
scc (Gr (BB (Analysis a)) () -> [[Node]])
-> Gr (BB (Analysis a)) () -> [[Node]]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr))
                       , (String
"loopNodes",    [IntSet] -> String
forall a. Show a => a -> String
show (IDomMap -> Gr (BB (Analysis a)) () -> [IntSet]
forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> [IntSet]
loopNodes IDomMap
bedges (Gr (BB (Analysis a)) () -> [IntSet])
-> Gr (BB (Analysis a)) () -> [IntSet]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr))
                       , (String
"duMap",        DomMap -> String
forall a. Show a => a -> String
show (BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
genDUMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> IntMap (IntSet, IntSet)
rd BBGr (Analysis a)
gr)))
                       , (String
"udMap",        DomMap -> String
forall a. Show a => a -> String
show (BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet) -> DomMap
genUDMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> IntMap (IntSet, IntSet)
rd BBGr (Analysis a)
gr)))
                       , (String
"flowsTo",      [(Node, Node)] -> String
forall a. Show a => a -> String
show (Gr (Block (Analysis a)) () -> [(Node, Node)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> [(Node, Node)]
edges Gr (Block (Analysis a)) ()
flTo))
                       , (String
"varFlowsTo",   VarFlowsMap -> String
forall a. Show a => a -> String
show (DefMap -> Gr (Block (Analysis a)) () -> VarFlowsMap
forall a. Data a => DefMap -> FlowsGraph a -> VarFlowsMap
genVarFlowsToMap DefMap
dm (BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (IntSet, IntSet)
-> Gr (Block (Analysis a)) ()
forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (IntSet, IntSet)
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> IntMap (IntSet, IntSet)
rd BBGr (Analysis a)
gr))))
                       , (String
"ivMap",        InductionVarMap -> String
forall a. Show a => a -> String
show (IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap IDomMap
bedges BBGr (Analysis a)
gr))
                       , (String
"ivMapByAST",   InductionVarMap -> String
forall a. Show a => a -> String
show (IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMapByASTBlock IDomMap
bedges BBGr (Analysis a)
gr))
                       , (String
"constExpMap",  ConstExpMap -> String
forall a. Show a => a -> String
show (ProgramFile (Analysis a) -> ConstExpMap
forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap ProgramFile (Analysis a)
pf))
                       , (String
"entries",      [Node] -> String
forall a. Show a => a -> String
show (OrderF (Analysis a)
forall a. OrderF a
bbgrEntries BBGr (Analysis a)
gr))
                       , (String
"exits",        [Node] -> String
forall a. Show a => a -> String
show (OrderF (Analysis a)
forall a. OrderF a
bbgrExits BBGr (Analysis a)
gr))
                       ] where
                           bedges :: IDomMap
bedges = DomMap -> Gr (BB (Analysis a)) () -> IDomMap
forall (gr :: * -> * -> *) a b.
Graph gr =>
DomMap -> gr a b -> IDomMap
genBackEdgeMap (BBGr (Analysis a) -> DomMap
forall a. BBGr a -> DomMap
dominators BBGr (Analysis a)
gr) (Gr (BB (Analysis a)) () -> IDomMap)
-> Gr (BB (Analysis a)) () -> IDomMap
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr
                           flTo :: Gr (Block (Analysis a)) ()
flTo = BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (IntSet, IntSet)
-> Gr (Block (Analysis a)) ()
forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (IntSet, IntSet)
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> IntMap (IntSet, IntSet)
rd BBGr (Analysis a)
gr)

    perPU ProgramUnit (Analysis a)
pu = String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dfStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
forall a. Show a => a -> String
show (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = Node -> Char -> String
forall a. Node -> a -> [a]
replicate (String -> Node
forall (t :: * -> *) a. Foldable t => t a -> Node
length String
p) Char
'-'
            dfStr :: String
dfStr = (\ (String
l, String
x) -> Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) ((String, String) -> String) -> [(String, String)] -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [
                      (String
"constExpMap",  ConstExpMap -> String
forall a. Show a => a -> String
show (ProgramFile (Analysis a) -> ConstExpMap
forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap ProgramFile (Analysis a)
pf))
                    ]

    lva :: BBGr (Analysis a) -> InOutMap (Set String)
lva = BBGr (Analysis a) -> InOutMap (Set String)
forall a. Data a => BBGr (Analysis a) -> InOutMap (Set String)
liveVariableAnalysis
    bm :: BlockMap a
bm = ProgramFile (Analysis a) -> BlockMap a
forall a. Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap ProgramFile (Analysis a)
pf
    dm :: DefMap
dm = BlockMap a -> DefMap
forall a. Data a => BlockMap a -> DefMap
genDefMap BlockMap a
bm
    rd :: BBGr (Analysis a) -> IntMap (IntSet, IntSet)
rd = DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet)
forall a.
Data a =>
DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet)
reachingDefinitions DefMap
dm
    cm :: CallMap
cm = ProgramFile (Analysis a) -> CallMap
forall a. Data a => ProgramFile (Analysis a) -> CallMap
genCallMap ProgramFile (Analysis a)
pf

-- | Outputs a DOT-formatted graph showing flow-to data starting at
-- the given AST-Block node in the given Basic Block graph.
showFlowsDOT :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> BBGr (Analysis a) -> ASTBlockNode -> Bool -> String
showFlowsDOT :: ProgramFile (Analysis a)
-> BBGr (Analysis a) -> Node -> Bool -> String
showFlowsDOT ProgramFile (Analysis a)
pf BBGr (Analysis a)
bbgr Node
astBlockId Bool
isFrom = Writer String () -> String
forall w a. Writer w a -> w
execWriter (Writer String () -> String) -> Writer String () -> String
forall a b. (a -> b) -> a -> b
$ do
  let bm :: BlockMap a
bm = ProgramFile (Analysis a) -> BlockMap a
forall a. Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap ProgramFile (Analysis a)
pf
      dm :: DefMap
dm = BlockMap a -> DefMap
forall a. Data a => BlockMap a -> DefMap
genDefMap BlockMap a
bm
      flowsTo :: FlowsGraph a
flowsTo = BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (IntSet, IntSet)
-> FlowsGraph a
forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (IntSet, IntSet)
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
bbgr (DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet)
forall a.
Data a =>
DefMap -> BBGr (Analysis a) -> IntMap (IntSet, IntSet)
reachingDefinitions DefMap
dm BBGr (Analysis a)
bbgr)
      flows :: FlowsGraph a
flows | Bool
isFrom    = FlowsGraph a -> FlowsGraph a
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
grev FlowsGraph a
flowsTo
            | Bool
otherwise = FlowsGraph a
flowsTo
  String -> Writer String ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"strict digraph {\n"
  [Node] -> (Node -> Writer String ()) -> Writer String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Node] -> FlowsGraph a -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Node] -> gr a b -> [Node]
bfsn [Node
astBlockId] FlowsGraph a
flows) ((Node -> Writer String ()) -> Writer String ())
-> (Node -> Writer String ()) -> Writer String ()
forall a b. (a -> b) -> a -> b
$ \ Node
n -> do
    let pseudocode :: String
pseudocode = String
-> (Block (Analysis a) -> String)
-> Maybe (Block (Analysis a))
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"<N/A>" Block (Analysis a) -> String
forall a. Block a -> String
showBlock (Maybe (Block (Analysis a)) -> String)
-> Maybe (Block (Analysis a)) -> String
forall a b. (a -> b) -> a -> b
$ Node -> BlockMap a -> Maybe (Block (Analysis a))
forall a. Node -> IntMap a -> Maybe a
IM.lookup Node
n BlockMap a
bm
    String -> Writer String ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"node [shape=box,fontname=\"Courier New\"]\n"
    String -> Writer String ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> Writer String ()) -> String -> Writer String ()
forall a b. (a -> b) -> a -> b
$ String
"Bl" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[label=\"B" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\l" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pseudocode String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]\n"
    String -> Writer String ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> Writer String ()) -> String -> Writer String ()
forall a b. (a -> b) -> a -> b
$ String
"Bl" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> {"
    [Node] -> (Node -> Writer String ()) -> Writer String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (FlowsGraph a -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
suc FlowsGraph a
flows Node
n) ((Node -> Writer String ()) -> Writer String ())
-> (Node -> Writer String ()) -> Writer String ()
forall a b. (a -> b) -> a -> b
$ \ Node
m -> String -> Writer String ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String
" Bl" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
m)
    String -> Writer String ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"
  String -> Writer String ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"

--------------------------------------------------

-- | CallMap : program unit name -> { name of function or subroutine }
type CallMap = M.Map ProgramUnitName (S.Set Name)

-- | Create a call map showing the structure of the program.
genCallMap :: Data a => ProgramFile (Analysis a) -> CallMap
genCallMap :: ProgramFile (Analysis a) -> CallMap
genCallMap ProgramFile (Analysis a)
pf = (State CallMap () -> CallMap -> CallMap)
-> CallMap -> State CallMap () -> CallMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip State CallMap () -> CallMap -> CallMap
forall s a. State s a -> s -> s
Lazy.execState CallMap
forall k a. Map k a
M.empty (State CallMap () -> CallMap) -> State CallMap () -> CallMap
forall a b. (a -> b) -> a -> b
$ do
  let uP :: ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
uP = forall a. Data a => ProgramFile a -> [ProgramUnit a]
forall from to. Biplate from to => from -> [to]
universeBi :: Data a => ProgramFile a -> [ProgramUnit a]
  [ProgramUnit (Analysis a)]
-> (ProgramUnit (Analysis a) -> State CallMap ())
-> State CallMap ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
uP ProgramFile (Analysis a)
pf) ((ProgramUnit (Analysis a) -> State CallMap ())
 -> State CallMap ())
-> (ProgramUnit (Analysis a) -> State CallMap ())
-> State CallMap ()
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit (Analysis a)
pu -> do
    let n :: ProgramUnitName
n = ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu
    let uS :: Data a => ProgramUnit a -> [Statement a]
        uS :: ProgramUnit a -> [Statement a]
uS = ProgramUnit a -> [Statement a]
forall from to. Biplate from to => from -> [to]
universeBi
    let uE :: Data a => ProgramUnit a -> [Expression a]
        uE :: ProgramUnit a -> [Expression a]
uE = ProgramUnit a -> [Expression a]
forall from to. Biplate from to => from -> [to]
universeBi
    CallMap
m <- StateT CallMap Identity CallMap
forall s (m :: * -> *). MonadState s m => m s
get
    let ns :: [String]
ns = [ Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v | StCall Analysis a
_ SrcSpan
_ v :: Expression (Analysis a)
v@ExpValue{} Maybe (AList Argument (Analysis a))
_          <- ProgramUnit (Analysis a) -> [Statement (Analysis a)]
forall a. Data a => ProgramUnit a -> [Statement a]
uS ProgramUnit (Analysis a)
pu ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
             [ Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v | ExpFunctionCall Analysis a
_ SrcSpan
_ v :: Expression (Analysis a)
v@ExpValue{} Maybe (AList Argument (Analysis a))
_ <- ProgramUnit (Analysis a) -> [Expression (Analysis a)]
forall a. Data a => ProgramUnit a -> [Expression a]
uE ProgramUnit (Analysis a)
pu ]
    CallMap -> State CallMap ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (CallMap -> State CallMap ()) -> CallMap -> State CallMap ()
forall a b. (a -> b) -> a -> b
$ ProgramUnitName -> Set String -> CallMap -> CallMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ProgramUnitName
n ([String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList [String]
ns) CallMap
m

--------------------------------------------------

-- | Finds the transitive closure of a directed graph.
-- Given a graph G=(V,E), its transitive closure is the graph:
-- G* = (V,E*) where E*={(i,j): i,j in V and there is a path from i to j in G}
--tc :: (DynGraph gr) => gr a b -> gr a ()
--tc g = newEdges `insEdges` insNodes ln empty
--  where
--    ln       = labNodes g
--    newEdges = [ toLEdge (u, v) () | (u, _) <- ln, (_, v) <- bfen (outU g u) g ]
--    outU gr  = map toEdge . out gr

-- helper: iterate until predicate is satisfied; expects infinite list.
converge :: (a -> a -> Bool) -> [a] -> a
converge :: (a -> a -> Bool) -> [a] -> a
converge a -> a -> Bool
p (a
x:ys :: [a]
ys@(a
y:[a]
_))
  | a -> a -> Bool
p a
x a
y     = a
y
  | Bool
otherwise = (a -> a -> Bool) -> [a] -> a
forall a. (a -> a -> Bool) -> [a] -> a
converge a -> a -> Bool
p [a]
ys
converge a -> a -> Bool
_ [] = String -> a
forall a. HasCallStack => String -> a
error String
"converge: empty list"
converge a -> a -> Bool
_ [a
_] = String -> a
forall a. HasCallStack => String -> a
error String
"converge: finite list"

fromJustMsg :: String -> Maybe a -> a
fromJustMsg :: String -> Maybe a -> a
fromJustMsg String
_ (Just a
x) = a
x
fromJustMsg String
msg Maybe a
_      = String -> a
forall a. HasCallStack => String -> a
error String
msg

-- Local variables:
-- mode: haskell
-- haskell-program-name: "cabal repl"
-- End: