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

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, constantFolding
  , 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.Analysis
import Language.Fortran.Analysis.BBlocks (showBlock, ASTBlockNode, ASTExprNode)
import Language.Fortran.AST
import Language.Fortran.AST.Literal.Real
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 :: forall a. BBGr a -> DomMap
dominators BBGr a
bbgr = forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Int -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr a
bbgr Int -> (BBNodeSet, BBNodeSet)
init forall a. OrderF a
revPostOrder (Int -> BBNodeSet) -> Int -> BBNodeSet
inn (Int -> BBNodeSet) -> Int -> BBNodeSet
out
  where
    gr :: Gr (BB a) ()
gr        = forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
bbgr
    nodeSet :: BBNodeSet
nodeSet   = [Int] -> BBNodeSet
IS.fromList forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
nodes Gr (BB a) ()
gr
    init :: Int -> (BBNodeSet, BBNodeSet)
init Int
_    = (BBNodeSet
nodeSet, BBNodeSet
nodeSet)

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

    out :: (Int -> BBNodeSet) -> Int -> BBNodeSet
out Int -> BBNodeSet
inF Int
n                      = Int -> BBNodeSet -> BBNodeSet
IS.insert Int
n forall a b. (a -> b) -> a -> b
$ Int -> BBNodeSet
inF Int
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 :: forall a. BBGr a -> IDomMap
iDominators BBGr a
gr = forall (f :: * -> *) a. Foldable f => f (IntMap a) -> IntMap a
IM.unions [ forall a. [(Int, a)] -> IntMap a
IM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> [(Int, Int)]
iDom Int
n forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr | Int
n <- 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 :: forall a. OrderF a
postOrder BBGr a
gr = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [a]
postorder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Tree Int]
dff (forall a. OrderF a
bbgrEntries BBGr a
gr) forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr

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

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

-- | Reversed preordering.
revPreOrder :: OrderF a
revPreOrder :: forall a. OrderF a
revPreOrder = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Int -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr a
gr Int -> (t, t)
initF OrderF a
order OutF t -> OutF t
inF OutF t -> OutF t
outF = forall a. (a -> a -> Bool) -> [a] -> a
converge forall a. Eq a => a -> a -> Bool
(==) forall a b. (a -> b) -> a -> b
$ forall {t}. NFData t => (t -> t) -> t -> [t]
iterate' InOutMap t -> InOutMap t
step InOutMap t
initM
  where
    ordNodes :: [Int]
ordNodes     = OrderF a
order BBGr a
gr
    initM :: InOutMap t
initM        = forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
n, Int -> (t, t)
initF Int
n) | Int
n <- [Int]
ordNodes ]
    step :: InOutMap t -> InOutMap t
step !InOutMap t
m      = forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
n, (OutF t -> OutF t
inF (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. IntMap a -> Int -> a
get' InOutMap t
m) Int
n, OutF t -> OutF t
outF (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. IntMap a -> Int -> a
get' InOutMap t
m) Int
n)) | Int
n <- [Int]
ordNodes ]
    get' :: IntMap a -> Int -> a
get' IntMap a
m Int
n     = forall a. Name -> Maybe a -> a
fromJustMsg (Name
"dataFlowSolver: get " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Int
n) forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n IntMap a
m
    iterate' :: (t -> t) -> t -> [t]
iterate' t -> t
f t
x = t
x forall a b. NFData a => a -> b -> b
`deepseq` t
x 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 :: forall a. Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap ProgramFile (Analysis a)
pf = forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
i, Block (Analysis a)
b) | BBGr (Analysis a)
gr         <- forall a. Data a => ProgramFile (Analysis a) -> [BBGr (Analysis a)]
uni ProgramFile (Analysis a)
pf
                                      , (Int
_, BB (Analysis a)
bs)    <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr
                                      , Block (Analysis a)
b          <- BB (Analysis a)
bs
                                      , let Just Int
i = forall a. Analysis a -> Maybe Int
insLabel (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) ]
  where
    uni :: Data a => ProgramFile (Analysis a) -> [BBGr (Analysis a)]
    uni :: forall a. Data a => ProgramFile (Analysis a) -> [BBGr (Analysis a)]
uni = 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 :: forall a. Data a => BlockMap a -> DefMap
genDefMap BlockMap a
bm = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union [
                 (Name
y, Int -> BBNodeSet
IS.singleton Int
i) | (Int
i, Block (Analysis a)
b) <- forall a. IntMap a -> [(Int, a)]
IM.toList BlockMap a
bm, Name
y <- forall a. Data a => Block (Analysis a) -> [Name]
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 :: forall a. Data a => BBGr (Analysis a) -> InOutMap (Set Name)
liveVariableAnalysis BBGr (Analysis a)
gr = forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Int -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr (Analysis a)
gr (forall a b. a -> b -> a
const (forall a. Set a
S.empty, forall a. Set a
S.empty)) forall a. OrderF a
revPreOrder (Int -> Set Name) -> Int -> Set Name
inn (Int -> Set Name) -> Int -> Set Name
out
  where
    inn :: (Int -> Set Name) -> Int -> Set Name
inn Int -> Set Name
outF Int
b = (Int -> Set Name
outF Int
b forall a. Ord a => Set a -> Set a -> Set a
S.\\ Int -> Set Name
kill Int
b) forall a. Ord a => Set a -> Set a -> Set a
`S.union` Int -> Set Name
gen Int
b
    out :: (Int -> Set Name) -> Int -> Set Name
out Int -> Set Name
innF Int
b = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [ Int -> Set Name
innF Int
s | Int
s <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
suc (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b ]
    kill :: Int -> Set Name
kill Int
b     = forall a. Data a => [Block (Analysis a)] -> Set Name
bblockKill (forall a. Name -> Maybe a -> a
fromJustMsg Name
"liveVariableAnalysis kill" forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b)
    gen :: Int -> Set Name
gen Int
b      = forall a. Data a => [Block (Analysis a)] -> Set Name
bblockGen (forall a. Name -> Maybe a -> a
fromJustMsg Name
"liveVariableAnalysis gen" forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b)

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

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

-- | "GEN" set for a single AST-block.
blockGen :: Data a => Block (Analysis a) -> [Name]
blockGen :: forall a. Data a => Block (Analysis a) -> [Name]
blockGen = forall a. Data a => Block (Analysis a) -> [Name]
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 :: forall a.
Data a =>
DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet
reachingDefinitions DefMap
dm BBGr (Analysis a)
gr = forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Int -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver BBGr (Analysis a)
gr (forall a b. a -> b -> a
const (BBNodeSet
IS.empty, BBNodeSet
IS.empty)) forall a. OrderF a
revPostOrder (Int -> BBNodeSet) -> Int -> BBNodeSet
inn (Int -> BBNodeSet) -> Int -> BBNodeSet
out
  where
    inn :: (Int -> BBNodeSet) -> Int -> BBNodeSet
inn Int -> BBNodeSet
outF Int
b = forall (f :: * -> *). Foldable f => f BBNodeSet -> BBNodeSet
IS.unions [ Int -> BBNodeSet
outF Int
s | Int
s <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
pre (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b ]
    out :: (Int -> BBNodeSet) -> Int -> BBNodeSet
out Int -> BBNodeSet
innF Int
b = BBNodeSet
gen BBNodeSet -> BBNodeSet -> BBNodeSet
`IS.union` (Int -> BBNodeSet
innF Int
b BBNodeSet -> BBNodeSet -> BBNodeSet
IS.\\ BBNodeSet
kill)
      where (BBNodeSet
gen, BBNodeSet
kill) = forall a.
Data a =>
DefMap -> [Block (Analysis a)] -> (BBNodeSet, BBNodeSet)
rdBblockGenKill DefMap
dm (forall a. Name -> Maybe a -> a
fromJustMsg Name
"reachingDefinitions" forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b)

-- Compute the "GEN" and "KILL" sets for a given basic block.
rdBblockGenKill :: Data a => DefMap -> [Block (Analysis a)] -> (ASTBlockNodeSet, ASTBlockNodeSet)
rdBblockGenKill :: forall a.
Data a =>
DefMap -> [Block (Analysis a)] -> (BBNodeSet, BBNodeSet)
rdBblockGenKill DefMap
dm [Block (Analysis a)]
bs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (BBNodeSet, BBNodeSet)
-> (BBNodeSet, BBNodeSet) -> (BBNodeSet, BBNodeSet)
f (BBNodeSet
IS.empty, BBNodeSet
IS.empty) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. Data a => Block (Analysis a) -> BBNodeSet
gen forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Block (Analysis a) -> BBNodeSet
kill) [Block (Analysis a)]
bs
  where
    gen :: Block (Analysis a) -> BBNodeSet
gen Block (Analysis a)
b | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Data a => Block (Analysis a) -> [Name]
allLhsVars Block (Analysis a)
b) = BBNodeSet
IS.empty
          | Bool
otherwise           = Int -> BBNodeSet
IS.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Name -> Maybe a -> a
fromJustMsg Name
"rdBblockGenKill" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Analysis a -> Maybe Int
insLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b
    kill :: Block (Analysis a) -> BBNodeSet
kill = forall a. Data a => DefMap -> Block (Analysis a) -> BBNodeSet
rdDefs DefMap
dm
    f :: (BBNodeSet, BBNodeSet)
-> (BBNodeSet, BBNodeSet) -> (BBNodeSet, BBNodeSet)
f (BBNodeSet
bbgen, BBNodeSet
bbkill) (BBNodeSet
gen', BBNodeSet
kill') =
      ((BBNodeSet
bbgen BBNodeSet -> BBNodeSet -> BBNodeSet
IS.\\ BBNodeSet
kill') BBNodeSet -> BBNodeSet -> BBNodeSet
`IS.union` BBNodeSet
gen', (BBNodeSet
bbkill BBNodeSet -> BBNodeSet -> BBNodeSet
IS.\\ BBNodeSet
gen') BBNodeSet -> BBNodeSet -> BBNodeSet
`IS.union` BBNodeSet
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 :: forall a. Data a => DefMap -> Block (Analysis a) -> BBNodeSet
rdDefs DefMap
dm Block (Analysis a)
b = forall (f :: * -> *). Foldable f => f BBNodeSet -> BBNodeSet
IS.unions [ BBNodeSet
IS.empty forall a. a -> Maybe a -> a
`fromMaybe` forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
y DefMap
dm | Name
y <- forall a. Data a => Block (Analysis a) -> [Name]
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 :: forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet -> DomMap
genDUMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr InOutMap BBNodeSet
rdefs = forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IM.unionsWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union [DomMap]
duMaps
  where
    -- duMaps for each bblock
    duMaps :: [DomMap]
duMaps = [ forall a b. (a, b) -> a
fst (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (DomMap, BBNodeSet) -> Block (Analysis a) -> (DomMap, BBNodeSet)
inBBlock (forall a. IntMap a
IM.empty, BBNodeSet
is) BB (Analysis a)
bs) |
               (Int
n, (BBNodeSet
is, BBNodeSet
_)) <- forall a. IntMap a -> [(Int, a)]
IM.toList InOutMap BBNodeSet
rdefs,
               let Just BB (Analysis a)
bs = forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
n ]
    -- internal analysis within bblock; fold over list of AST-blocks
    inBBlock :: (DomMap, BBNodeSet) -> Block (Analysis a) -> (DomMap, BBNodeSet)
inBBlock (DomMap
duMap, BBNodeSet
inSet) Block (Analysis a)
b = (DomMap
duMap', BBNodeSet
inSet')
      where
        Just Int
i = forall a. Analysis a -> Maybe Int
insLabel (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b)
        bduMap :: DomMap
bduMap = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union [ (Int
i', Int -> BBNodeSet
IS.singleton Int
i) | Int
i' <- BBNodeSet -> [Int]
IS.toList BBNodeSet
inSet, Int -> Bool
overlap Int
i' ]
        -- asks: does AST-block at label i' define anything used by AST-block b?
        overlap :: Int -> Bool
overlap Int
i' = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
intersect [Name]
uses forall a b. (a -> b) -> a -> b
$ forall a. Data a => Block (Analysis a) -> [Name]
blockVarDefs Block (Analysis a)
b'
          where Just Block (Analysis a)
b' = forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i' BlockMap a
bm
        uses :: [Name]
uses   = forall a. Data a => Block (Analysis a) -> [Name]
blockVarUses Block (Analysis a)
b
        duMap' :: DomMap
duMap' = forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union DomMap
duMap DomMap
bduMap
        gen :: Block (Analysis a) -> BBNodeSet
gen Block (Analysis a)
b' | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Data a => Block (Analysis a) -> [Name]
allLhsVars Block (Analysis a)
b') = BBNodeSet
IS.empty
               | Bool
otherwise           = Int -> BBNodeSet
IS.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Name -> Maybe a -> a
fromJustMsg Name
"genDUMap" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Analysis a -> Maybe Int
insLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b'
        kill :: Block (Analysis a) -> BBNodeSet
kill   = forall a. Data a => DefMap -> Block (Analysis a) -> BBNodeSet
rdDefs DefMap
dm
        inSet' :: BBNodeSet
inSet' = (BBNodeSet
inSet BBNodeSet -> BBNodeSet -> BBNodeSet
IS.\\ Block (Analysis a) -> BBNodeSet
kill Block (Analysis a)
b) BBNodeSet -> BBNodeSet -> BBNodeSet
`IS.union` forall {a}. Data a => Block (Analysis a) -> BBNodeSet
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 = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union [
    (Int
use, Int -> BBNodeSet
IS.singleton Int
def) | (Int
def, BBNodeSet
uses) <- forall a. IntMap a -> [(Int, a)]
IM.toList DomMap
duMap, Int
use <- BBNodeSet -> [Int]
IS.toList BBNodeSet
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 :: forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet -> DomMap
genUDMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr = DomMap -> DomMap
duMapToUdMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet -> 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 :: forall (gr :: * -> * -> *) a.
DynGraph gr =>
BlockMap a -> DomMap -> gr (Block (Analysis a)) ()
mapToGraph BlockMap a
bm DomMap
m = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(Int, Block (Analysis a))]
nodes' [(Int, Int, ())]
edges'
  where
    nodes' :: [(Int, Block (Analysis a))]
nodes' = [ (Int
i, Block (Analysis a)
iLabel) | Int
i <- forall a. IntMap a -> [Int]
IM.keys DomMap
m forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BBNodeSet -> [Int]
IS.toList (forall a. IntMap a -> [a]
IM.elems DomMap
m)
                          , let iLabel :: Block (Analysis a)
iLabel = forall a. Name -> Maybe a -> a
fromJustMsg Name
"mapToGraph" (forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i BlockMap a
bm) ]
    edges' :: [(Int, Int, ())]
edges' = [ (Int
i, Int
j, ()) | (Int
i, BBNodeSet
js) <- forall a. IntMap a -> [(Int, a)]
IM.toList DomMap
m
                         , Int
j       <- BBNodeSet -> [Int]
IS.toList BBNodeSet
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 :: forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> InOutMap BBNodeSet
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr = forall (gr :: * -> * -> *) a.
DynGraph gr =>
BlockMap a -> DomMap -> gr (Block (Analysis a)) ()
mapToGraph BlockMap a
bm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet -> 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 :: forall a. Data a => DefMap -> FlowsGraph a -> VarFlowsMap
genVarFlowsToMap DefMap
dm FlowsGraph a
fg = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Ord a => Set a -> Set a -> Set a
S.union [ (Int -> Name
conv Int
u, Int -> Set Name
sconv Int
v) | (Int
u, Int
v) <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [(Int, Int)]
edges FlowsGraph a
fg ]
  where
    sconv :: Int -> Set Name
sconv Int
i | Just Name
v  <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i IntMap Name
revDM = forall a. a -> Set a
S.singleton Name
v
            | Bool
otherwise                    = forall a. Set a
S.empty
    conv :: Int -> Name
conv Int
i | Just Name
v  <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i IntMap Name
revDM = Name
v
           | Bool
otherwise                    = forall a. HasCallStack => Name -> a
error forall a b. (a -> b) -> a -> b
$ Name
"genVarFlowsToMap: convert failed, i=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Int
i
    -- planning to make revDM a surjection, after I flatten-out Fortran functions
    revDM :: IntMap Name
revDM = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a, b) -> a
fst) [ (Int
i, Name
v) | (Name
v, BBNodeSet
is) <- forall k a. Map k a -> [(k, a)]
M.toList DefMap
dm, Int
i <- BBNodeSet -> [Int]
IS.toList BBNodeSet
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) forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
31::Integer)

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

inBounds :: Integer -> Bool
inBounds :: Integer -> Bool
inBounds Integer
x = Integer
minConst forall a. Ord a => a -> a -> Bool
<= Integer
x Bool -> Bool -> Bool
&& Integer
x 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 forall a. Num a => a -> a -> a
+ Integer
y) -> Integer -> Constant
ConstInt (Integer
x forall a. Num a => a -> a -> a
+ Integer
y)
    BinaryOp
Subtraction    | Integer -> Bool
inBounds (Integer
x forall a. Num a => a -> a -> a
- Integer
y) -> Integer -> Constant
ConstInt (Integer
x forall a. Num a => a -> a -> a
- Integer
y)
    BinaryOp
Multiplication | Integer -> Bool
inBounds (Integer
x forall a. Num a => a -> a -> a
* Integer
y) -> Integer -> Constant
ConstInt (Integer
x forall a. Num a => a -> a -> a
* Integer
y)
    BinaryOp
Division       | Integer
y forall a. Eq a => a -> a -> Bool
/= Integer
0           -> Integer -> Constant
ConstInt (Integer
x forall a. Integral a => a -> a -> a
`div` Integer
y)
    -- gfortran appears to do real exponentiation (allowing negative exponent)
    -- and cast back to integer via floor() (?) as required
    -- but we keep it simple & stick with Haskell-style integer exponentiation
    BinaryOp
Exponentiation | Integer
y forall a. Ord a => a -> a -> Bool
>= Integer
0           -> Integer -> Constant
ConstInt (Integer
x forall a b. (Num a, Integral b) => a -> b -> a
^ 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 :: forall a. Data a => 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 Name (Maybe Constant)
pvMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
      [ (forall a. Expression (Analysis a) -> Name
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)
_) <- forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf :: [Statement (Analysis a)]
      , AttrParameter Analysis a
_ SrcSpan
_ <- forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
st :: [Attribute (Analysis a)]
      , (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v DeclaratorType (Analysis a)
ScalarDecl Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
e)) <- forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
st ] forall a. [a] -> [a] -> [a]
++
      [ (forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v, Expression (Analysis a) -> Maybe Constant
getE Expression (Analysis a)
e)
      | st :: Statement (Analysis a)
st@StParameter{} <- forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf :: [Statement (Analysis a)]
      , (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v DeclaratorType (Analysis a)
ScalarDecl Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
e)) <- 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 = forall a. Analysis a -> Maybe Constant
constExp (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e) forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Name (Maybe Constant)
pvMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Expression (Analysis a) -> Name
varName forall a b. (a -> b) -> a -> b
$ Expression (Analysis a)
e)

    -- Generate map of information about 'constant expressions'.
    ceMap :: ConstExpMap
ceMap = forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
label, Expression (Analysis a) -> Maybe Constant
doExpr Expression (Analysis a)
e) | Expression (Analysis a)
e <- forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf, Just Int
label <- [forall {a}. Expression (Analysis a) -> Maybe Int
labelOf Expression (Analysis a)
e] ]
    getE :: Expression (Analysis a) -> Maybe Constant
    getE :: Expression (Analysis a) -> Maybe Constant
getE = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> IntMap a -> Maybe a
IM.lookup ConstExpMap
ceMap forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall {a}. Expression (Analysis a) -> Maybe Int
labelOf)
    labelOf :: Expression (Analysis a) -> Maybe Int
labelOf = forall a. Analysis a -> Maybe Int
insLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 Name
intStr Maybe (KindParam (Analysis a))
_) -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Constant
ConstInt forall a b. (a -> b) -> a -> b
$ forall a. Read a => Name -> a
read Name
intStr
      ExpValue Analysis a
_ SrcSpan
_ (ValReal RealLit
r Maybe (KindParam (Analysis a))
_)    -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Constant
ConstUninterpReal (RealLit -> Name
prettyHsRealLit RealLit
r) -- TODO
      ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_)  -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnaryOp -> Constant -> Constant
ConstUnary UnaryOp
unOp 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)
_ -> 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 :: forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseConstExps ProgramFile (Analysis a)
pf = ProgramFile (Analysis a)
pf'
  where
    ceMap :: ConstExpMap
ceMap = 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 (forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap ((Expression (Analysis a) -> Expression (Analysis a))
-> [Block (Analysis a)] -> [Block (Analysis a)]
transformExpr Expression (Analysis a) -> Expression (Analysis a)
insertConstExp))) forall a b. (a -> b) -> a -> b
$ 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Annotated f => (a -> a) -> f a -> f a
modifyAnnotation Expression (Analysis a)
e forall a b. (a -> b) -> a -> b
$ \ Analysis a
a ->
      Analysis a
a { constExp :: Maybe Constant
constExp = forall a. Analysis a -> Maybe Constant
constExp Analysis a
a forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> IntMap a -> Maybe a
IM.lookup ConstExpMap
ceMap forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Analysis a -> Maybe Int
insLabel (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 = 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))
-> [Block (Analysis a)] -> [Block (Analysis a)]
transformExpr = 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 :: forall a.
Data a =>
ParameterVarMap
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseParameterVars ParameterVarMap
pvm = 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e) ParameterVarMap
pvm = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Annotated f => (a -> a) -> f a -> f a
modifyAnnotation Expression (Analysis a)
e forall a b. (a -> b) -> a -> b
$ \ Analysis a
a -> Analysis a
a { constExp :: Maybe Constant
constExp = 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 :: forall (gr :: * -> * -> *) a b.
Graph gr =>
DomMap -> gr a b -> IDomMap
genBackEdgeMap DomMap
domMap = forall a. [(Int, a)] -> IntMap a
IM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Int) -> Bool
isBackEdge forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [(Int, Int)]
edges
  where
    isBackEdge :: (Int, Int) -> Bool
isBackEdge (Int
s, Int
t) = Int
t Int -> BBNodeSet -> Bool
`IS.member` forall a. Name -> Maybe a -> a
fromJustMsg Name
"genBackEdgeMap" (Int
s forall a. Int -> 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 :: forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> [BBNodeSet]
loopNodes IDomMap
bedges gr a b
gr = [
    [Int] -> BBNodeSet
IS.fromList (Int
nforall a. a -> [a] -> [a]
:forall a. Eq a => [a] -> [a] -> [a]
intersect (forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> [Int]
sccWith Int
n gr a b
gr) (forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Int]
rdfs [Int
m] (forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> gr a b
delNode Int
n gr a b
gr))) | (Int
m, Int
n) <- forall a. IntMap a -> [(Int, 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 :: forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> DomMap
genLoopNodeMap IDomMap
bedges gr a b
gr = forall a. [(Int, a)] -> IntMap a
IM.fromList [
    (Int
n, [Int] -> BBNodeSet
IS.fromList (Int
nforall a. a -> [a] -> [a]
:forall a. Eq a => [a] -> [a] -> [a]
intersect (forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> [Int]
sccWith Int
n gr a b
gr) (forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Int]
rdfs [Int
m] (forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> gr a b
delNode Int
n gr a b
gr)))) | (Int
m, Int
n) <- forall a. IntMap a -> [(Int, a)]
IM.toList IDomMap
bedges
  ]

-- | The strongly connected component containing a given node.
sccWith :: (Graph gr) => Node -> gr a b -> [Node]
sccWith :: forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> [Int]
sccWith Int
n gr a b
g = case forall a. (a -> Bool) -> [a] -> [a]
filter (Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [[Int]]
scc gr a b
g of
  []  -> []
  [Int]
c:[[Int]]
_ -> [Int]
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 :: forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars IDomMap
bedges BBGr (Analysis a)
gr = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith forall a. Ord a => Set a -> Set a -> Set a
S.union [
    (Int
n, forall a. a -> Set a
S.singleton Name
v) | (Int
_, Int
n)      <- forall a. IntMap a -> [(Int, a)]
IM.toList IDomMap
bedges
                       , let Just BB (Analysis a)
bs = forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
n
                       , b :: Block (Analysis a)
b@BlDo{}    <- BB (Analysis a)
bs
                       , Name
v           <- forall a. Data a => Block (Analysis a) -> [Name]
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 :: forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap = 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 :: forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMapByASTBlock IDomMap
bedges BBGr (Analysis a)
gr = InductionVarMap -> InductionVarMap
loopsToLabs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap IDomMap
bedges forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a)
gr
  where
    lnMap :: DomMap
lnMap       = forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> DomMap
genLoopNodeMap IDomMap
bedges forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr
    get' :: Int -> BBNodeSet
get'        = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => Name -> a
error Name
"missing loop-header node") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> IntMap a -> Maybe a
IM.lookup DomMap
lnMap
    astLabels :: Int -> [Int]
astLabels Int
n = [ Int
i | Block (Analysis a)
b <- (forall from to. Biplate from to => from -> [to]
universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
n)
                      , let Just Int
i = forall a. Analysis a -> Maybe Int
insLabel (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) ]
    loopsToLabs :: InductionVarMap -> InductionVarMap
loopsToLabs         = forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith forall a. Ord a => Set a -> Set a -> Set a
S.union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, Set Name) -> [(Int, Set Name)]
loopToLabs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IM.toList
    loopToLabs :: (Int, Set Name) -> [(Int, Set Name)]
loopToLabs (Int
n, Set Name
ivs) = (forall a b. (a -> b) -> [a] -> [b]
map (,Set Name
ivs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
astLabels) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BBNodeSet -> [Int]
IS.toList (Int -> BBNodeSet
get' Int
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 (Int -> InductionExpr -> ShowS
[InductionExpr] -> ShowS
InductionExpr -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [InductionExpr] -> ShowS
$cshowList :: [InductionExpr] -> ShowS
show :: InductionExpr -> Name
$cshow :: InductionExpr -> Name
showsPrec :: Int -> InductionExpr -> ShowS
$cshowsPrec :: Int -> InductionExpr -> ShowS
Show, InductionExpr -> InductionExpr -> Bool
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
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
Ord, Typeable, 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
InductionExpr -> DataType
InductionExpr -> Constr
(forall b. Data b => b -> b) -> InductionExpr -> 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. Int -> (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. Int -> (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)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> InductionExpr -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> InductionExpr -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u]
gmapQr :: forall r r'.
(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 :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data)
instance NFData InductionExpr
type DerivedInductionMap = ASTExprNodeMap InductionExpr

data IEFlow = IEFlow { IEFlow -> Map Name InductionExpr
ieFlowVars :: M.Map Name InductionExpr, IEFlow -> DerivedInductionMap
ieFlowExprs :: !DerivedInductionMap }
  deriving (Int -> IEFlow -> ShowS
[IEFlow] -> ShowS
IEFlow -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [IEFlow] -> ShowS
$cshowList :: [IEFlow] -> ShowS
show :: IEFlow -> Name
$cshow :: IEFlow -> Name
showsPrec :: Int -> IEFlow -> ShowS
$cshowsPrec :: Int -> IEFlow -> ShowS
Show, IEFlow -> IEFlow -> Bool
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
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
Ord, Typeable, 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
IEFlow -> DataType
IEFlow -> Constr
(forall b. Data b => b -> b) -> IEFlow -> 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. Int -> (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. Int -> (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)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
MonadPlus m =>
(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 (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> IEFlow -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> IEFlow -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> IEFlow -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> IEFlow -> [u]
gmapQr :: forall r r'.
(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 :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data)
instance NFData IEFlow

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

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

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

joinIEFlows :: [IEFlow] -> IEFlow
joinIEFlows :: [IEFlow] -> IEFlow
joinIEFlows [IEFlow]
flows = Map Name InductionExpr -> DerivedInductionMap -> IEFlow
IEFlow Map Name InductionExpr
flowV DerivedInductionMap
flowE
  where
    flowV :: Map Name InductionExpr
flowV = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith InductionExpr -> InductionExpr -> InductionExpr
joinInductionExprs (forall a b. (a -> b) -> [a] -> [b]
map IEFlow -> Map Name InductionExpr
ieFlowVars [IEFlow]
flows)
    flowE :: DerivedInductionMap
flowE = forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IMS.unionsWith InductionExpr -> InductionExpr -> InductionExpr
joinInductionExprs (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 :: forall a.
Data a =>
IDomMap -> BBGr (Analysis a) -> DerivedInductionMap
genDerivedInductionMap IDomMap
bedges BBGr (Analysis a)
gr = IEFlow -> DerivedInductionMap
ieFlowExprs forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IEFlow] -> IEFlow
joinIEFlows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [a]
IMS.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IMS.filterWithKey Int -> (IEFlow, IEFlow) -> Bool
inLoop forall a b. (a -> b) -> a -> b
$ InOutMap IEFlow
inOutMaps
  where
    bivMap :: InductionVarMap
bivMap = forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars IDomMap
bedges BBGr (Analysis a)
gr -- basic indvars indexed by loop header node
    loopNodeSet :: BBNodeSet
loopNodeSet = forall (f :: * -> *). Foldable f => f BBNodeSet -> BBNodeSet
IS.unions (forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> [BBNodeSet]
loopNodes IDomMap
bedges forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) -- set of nodes within a loop
    inLoop :: Int -> (IEFlow, IEFlow) -> Bool
inLoop Int
i (IEFlow, IEFlow)
_ = Int
i Int -> BBNodeSet -> Bool
`IS.member` BBNodeSet
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 Name
_)) Expression (Analysis a)
rhs)
        | Maybe Int
_ <- forall a. Analysis a -> Maybe Int
insLabel (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
rhs), IEFlow
flow'' <- Name -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertVar (forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
lv) (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' = 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 -> forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 = 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 = Int -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr Int
label InductionExpr
ie IEFlow
flow
      where
        ie :: InductionExpr
ie = forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr IEFlow
flow Expression (Analysis a)
e
        label :: Int
label = forall a. Name -> Maybe a -> a
fromJustMsg Name
"stepExpr" forall a b. (a -> b) -> a -> b
$ forall a. Analysis a -> Maybe Int
insLabel (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 Int
node = IEFlow
flow'
      where
        flow :: IEFlow
flow = [IEFlow] -> IEFlow
joinIEFlows [forall a b. (a, b) -> a
fst (Int -> (IEFlow, IEFlow)
initF Int
node), InF IEFlow
inF Int
node]
        flow' :: IEFlow
flow' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IEFlow -> Block (Analysis a) -> IEFlow
step IEFlow
flow (forall a. Name -> Maybe a -> a
fromJustMsg (Name
"analyseDerivedIE out(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Int
node forall a. [a] -> [a] -> [a]
++ Name
")") forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
node)

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

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

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

derivedInductionExprMemo :: Data a => IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExprMemo :: forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExprMemo IEFlow
flow Expression (Analysis a)
e
  | Just Int
label <- forall a. Analysis a -> Maybe Int
insLabel (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)
  , Just InductionExpr
iexpr <- forall a. Int -> IntMap a -> Maybe a
IMS.lookup Int
label (IEFlow -> DerivedInductionMap
ieFlowExprs IEFlow
flow) = InductionExpr
iexpr
  | Bool
otherwise = 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 :: forall a.
Data a =>
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 Name
_))   -> forall a. a -> Maybe a -> a
fromMaybe InductionExpr
IETop forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v) (IEFlow -> Map Name InductionExpr
ieFlowVars IEFlow
flow)
  ExpValue Analysis a
_ SrcSpan
_ (ValInteger Name
intStr Maybe (KindParam (Analysis a))
_) -> Name -> Int -> Int -> InductionExpr
IELinear Name
"" Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Read a => Name -> a
read Name
intStr
  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 = 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 :: forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e = do
  IEFlow
flow <- forall s (m :: * -> *). MonadState s m => m s
get
  let derive :: Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e' | Just Int
label <- forall a. Analysis a -> Maybe Int
insLabel (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e')
                , Just InductionExpr
iexpr <- forall a. Int -> IntMap a -> Maybe a
IMS.lookup Int
label (IEFlow -> DerivedInductionMap
ieFlowExprs IEFlow
flow) = forall (f :: * -> *) a. Applicative f => a -> f a
pure InductionExpr
iexpr
                | Bool
otherwise = 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 Name
_))   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe InductionExpr
IETop forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v) (IEFlow -> Map Name InductionExpr
ieFlowVars IEFlow
flow)
        ExpValue Analysis a
_ SrcSpan
_ (ValInteger Name
intStr Maybe (KindParam (Analysis a))
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Int -> Int -> InductionExpr
IELinear Name
"" Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Read a => Name -> a
read Name
intStr
        ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Addition Expression (Analysis a)
e1 Expression (Analysis a)
e2       -> InductionExpr -> InductionExpr -> InductionExpr
addInductionExprs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (InductionExpr -> InductionExpr
negInductionExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e2
        Expression (Analysis a)
_                                  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ InductionExpr
IETop -- unsure
  let Just Int
label = forall a. Analysis a -> Maybe Int
insLabel (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ Int -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr Int
label InductionExpr
ie IEFlow
flow
  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 Name
ln Int
lc Int
lo) (IELinear Name
rn Int
rc Int
ro)
  | Name
ln forall a. Eq a => a -> a -> Bool
== Name
rn                = Name -> Int -> Int -> InductionExpr
IELinear Name
ln (Int
lc forall a. Num a => a -> a -> a
+ Int
rc) (Int
lo forall a. Num a => a -> a -> a
+ Int
ro)
  | Int
lc forall a. Eq a => a -> a -> Bool
== Int
0                 = Name -> Int -> Int -> InductionExpr
IELinear Name
rn Int
rc (Int
lo forall a. Num a => a -> a -> a
+ Int
ro)
  | Int
rc forall a. Eq a => a -> a -> Bool
== Int
0                 = Name -> Int -> Int -> InductionExpr
IELinear Name
ln Int
lc (Int
lo forall a. Num a => a -> a -> a
+ Int
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 Name
n Int
c Int
o) = Name -> Int -> Int -> InductionExpr
IELinear Name
n (-Int
c) (-Int
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 Name
"" Int
_ Int
lo) (IELinear Name
rn Int
rc Int
ro) = Name -> Int -> Int -> InductionExpr
IELinear Name
rn (Int
rc forall a. Num a => a -> a -> a
* Int
lo) (Int
ro forall a. Num a => a -> a -> a
* Int
lo)
mulInductionExprs (IELinear Name
ln Int
lc Int
lo) (IELinear Name
"" Int
_ Int
ro) = Name -> Int -> Int -> InductionExpr
IELinear Name
ln (Int
lc forall a. Num a => a -> a -> a
* Int
ro) (Int
lo forall a. Num a => a -> a -> a
* Int
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 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 :: forall a.
(Data a, Out a, Show a) =>
ProgramFile (Analysis a) -> Name
showDataFlow ProgramFile (Analysis a)
pf = ProgramUnit (Analysis a) -> Name
perPU 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 from to. Biplate from to => from -> [to]
universeBi :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    perPU :: ProgramUnit (Analysis a) -> Name
perPU ProgramUnit (Analysis a)
pu | Analysis { bBlocks :: forall a. Analysis a -> Maybe (BBGr (Analysis a))
bBlocks = Just BBGr (Analysis a)
gr } <- forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu =
      Name
dashes forall a. [a] -> [a] -> [a]
++ Name
"\n" forall a. [a] -> [a] -> [a]
++ Name
p forall a. [a] -> [a] -> [a]
++ Name
"\n" forall a. [a] -> [a] -> [a]
++ Name
dashes forall a. [a] -> [a] -> [a]
++ Name
"\n" forall a. [a] -> [a] -> [a]
++ BBGr (Analysis a) -> Name
dfStr BBGr (Analysis a)
gr forall a. [a] -> [a] -> [a]
++ Name
"\n\n"
      where p :: Name
p = Name
"| Program Unit " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show (forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) forall a. [a] -> [a] -> [a]
++ Name
" |"
            dashes :: Name
dashes = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length Name
p) Char
'-'
            dfStr :: BBGr (Analysis a) -> Name
dfStr BBGr (Analysis a)
gr = (\ (Name
l, Name
x) -> Char
'\n'forall a. a -> [a] -> [a]
:Name
l forall a. [a] -> [a] -> [a]
++ Name
": " forall a. [a] -> [a] -> [a]
++ Name
x) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [
                         (Name
"callMap",      forall a. Show a => a -> Name
show CallMap
cm)
                       , (Name
"postOrder",    forall a. Show a => a -> Name
show (forall a. OrderF a
postOrder BBGr (Analysis a)
gr))
                       , (Name
"revPostOrder", forall a. Show a => a -> Name
show (forall a. OrderF a
revPostOrder BBGr (Analysis a)
gr))
                       , (Name
"revPreOrder",  forall a. Show a => a -> Name
show (forall a. OrderF a
revPreOrder BBGr (Analysis a)
gr))
                       , (Name
"dominators",   forall a. Show a => a -> Name
show (forall a. BBGr a -> DomMap
dominators BBGr (Analysis a)
gr))
                       , (Name
"iDominators",  forall a. Show a => a -> Name
show (forall a. BBGr a -> IDomMap
iDominators BBGr (Analysis a)
gr))
                       , (Name
"defMap",       forall a. Show a => a -> Name
show DefMap
dm)
                       , (Name
"lva",          forall a. Show a => a -> Name
show (forall a. IntMap a -> [(Int, a)]
IM.toList forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> InOutMap (Set Name)
lva BBGr (Analysis a)
gr))
                       , (Name
"rd",           forall a. Show a => a -> Name
show (forall a. IntMap a -> [(Int, a)]
IM.toList forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> InOutMap BBNodeSet
rd BBGr (Analysis a)
gr))
                       , (Name
"backEdges",    forall a. Show a => a -> Name
show IDomMap
bedges)
                       , (Name
"topsort",      forall a. Show a => a -> Name
show (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
topsort forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr))
                       , (Name
"scc ",         forall a. Show a => a -> Name
show (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [[Int]]
scc forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr))
                       , (Name
"loopNodes",    forall a. Show a => a -> Name
show (forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> [BBNodeSet]
loopNodes IDomMap
bedges forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr))
                       , (Name
"duMap",        forall a. Show a => a -> Name
show (forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet -> DomMap
genDUMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> InOutMap BBNodeSet
rd BBGr (Analysis a)
gr)))
                       , (Name
"udMap",        forall a. Show a => a -> Name
show (forall a.
Data a =>
BlockMap a
-> DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet -> DomMap
genUDMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> InOutMap BBNodeSet
rd BBGr (Analysis a)
gr)))
                       , (Name
"flowsTo",      forall a. Show a => a -> Name
show (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [(Int, Int)]
edges FlowsGraph a
flTo))
                       , (Name
"varFlowsTo",   forall a. Show a => a -> Name
show (forall a. Data a => DefMap -> FlowsGraph a -> VarFlowsMap
genVarFlowsToMap DefMap
dm (forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> InOutMap BBNodeSet
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> InOutMap BBNodeSet
rd BBGr (Analysis a)
gr))))
                       , (Name
"ivMap",        forall a. Show a => a -> Name
show (forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap IDomMap
bedges BBGr (Analysis a)
gr))
                       , (Name
"ivMapByAST",   forall a. Show a => a -> Name
show (forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMapByASTBlock IDomMap
bedges BBGr (Analysis a)
gr))
                       , (Name
"constExpMap",  forall a. Show a => a -> Name
show (forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap ProgramFile (Analysis a)
pf))
                       , (Name
"entries",      forall a. Show a => a -> Name
show (forall a. OrderF a
bbgrEntries BBGr (Analysis a)
gr))
                       , (Name
"exits",        forall a. Show a => a -> Name
show (forall a. OrderF a
bbgrExits BBGr (Analysis a)
gr))
                       ] where
                           bedges :: IDomMap
bedges = forall (gr :: * -> * -> *) a b.
Graph gr =>
DomMap -> gr a b -> IDomMap
genBackEdgeMap (forall a. BBGr a -> DomMap
dominators BBGr (Analysis a)
gr) forall a b. (a -> b) -> a -> b
$ forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr
                           flTo :: FlowsGraph a
flTo = forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> InOutMap BBNodeSet
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr (BBGr (Analysis a) -> InOutMap BBNodeSet
rd BBGr (Analysis a)
gr)

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

    lva :: BBGr (Analysis a) -> InOutMap (Set Name)
lva = forall a. Data a => BBGr (Analysis a) -> InOutMap (Set Name)
liveVariableAnalysis
    bm :: BlockMap a
bm = forall a. Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap ProgramFile (Analysis a)
pf
    dm :: DefMap
dm = forall a. Data a => BlockMap a -> DefMap
genDefMap BlockMap a
bm
    rd :: BBGr (Analysis a) -> InOutMap BBNodeSet
rd = forall a.
Data a =>
DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet
reachingDefinitions DefMap
dm
    cm :: CallMap
cm = 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 :: forall a.
(Data a, Out a, Show a) =>
ProgramFile (Analysis a)
-> BBGr (Analysis a) -> Int -> Bool -> Name
showFlowsDOT ProgramFile (Analysis a)
pf BBGr (Analysis a)
bbgr Int
astBlockId Bool
isFrom = forall w a. Writer w a -> w
execWriter forall a b. (a -> b) -> a -> b
$ do
  let bm :: BlockMap a
bm = forall a. Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap ProgramFile (Analysis a)
pf
      dm :: DefMap
dm = forall a. Data a => BlockMap a -> DefMap
genDefMap BlockMap a
bm
      flowsTo :: FlowsGraph a
flowsTo = forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> InOutMap BBNodeSet
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
bbgr (forall a.
Data a =>
DefMap -> BBGr (Analysis a) -> InOutMap BBNodeSet
reachingDefinitions DefMap
dm BBGr (Analysis a)
bbgr)
      flows :: FlowsGraph a
flows | Bool
isFrom    = forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
grev FlowsGraph a
flowsTo
            | Bool
otherwise = FlowsGraph a
flowsTo
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Name
"strict digraph {\n"
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Int]
bfsn [Int
astBlockId] FlowsGraph a
flows) forall a b. (a -> b) -> a -> b
$ \ Int
n -> do
    let pseudocode :: Name
pseudocode = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
"<N/A>" forall a. Block a -> Name
showBlock forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n BlockMap a
bm
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Name
"node [shape=box,fontname=\"Courier New\"]\n"
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Name
"Bl" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Int
n forall a. [a] -> [a] -> [a]
++ Name
"[label=\"B" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Int
n forall a. [a] -> [a] -> [a]
++ Name
"\\l" forall a. [a] -> [a] -> [a]
++ Name
pseudocode forall a. [a] -> [a] -> [a]
++ Name
"\"]\n"
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Name
"Bl" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Int
n forall a. [a] -> [a] -> [a]
++ Name
" -> {"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
suc FlowsGraph a
flows Int
n) forall a b. (a -> b) -> a -> b
$ \ Int
m -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Name
" Bl" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> Name
show Int
m)
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Name
"}\n"
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Name
"}\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 :: forall a. Data a => ProgramFile (Analysis a) -> CallMap
genCallMap ProgramFile (Analysis a)
pf = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
Lazy.execState forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$ do
  let uP :: ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
uP = forall from to. Biplate from to => from -> [to]
universeBi :: Data a => ProgramFile a -> [ProgramUnit a]
  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) forall a b. (a -> b) -> a -> b
$ \ ProgramUnit (Analysis a)
pu -> do
    let n :: ProgramUnitName
n = forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu
    let uS :: Data a => ProgramUnit a -> [Statement a]
        uS :: forall a. Data a => ProgramUnit a -> [Statement a]
uS = forall from to. Biplate from to => from -> [to]
universeBi
    let uE :: Data a => ProgramUnit a -> [Expression a]
        uE :: forall a. Data a => ProgramUnit a -> [Expression a]
uE = forall from to. Biplate from to => from -> [to]
universeBi
    CallMap
m <- forall s (m :: * -> *). MonadState s m => m s
get
    let ns :: [Name]
ns = [ forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v | StCall Analysis a
_ SrcSpan
_ v :: Expression (Analysis a)
v@ExpValue{} AList Argument (Analysis a)
_          <- forall a. Data a => ProgramUnit a -> [Statement a]
uS ProgramUnit (Analysis a)
pu ] forall a. [a] -> [a] -> [a]
++
             [ forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v | ExpFunctionCall Analysis a
_ SrcSpan
_ v :: Expression (Analysis a)
v@ExpValue{} AList Argument (Analysis a)
_ <- forall a. Data a => ProgramUnit a -> [Expression a]
uE ProgramUnit (Analysis a)
pu ]
    forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ProgramUnitName
n (forall a. Ord a => [a] -> Set a
S.fromList [Name]
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 :: forall a. (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 = forall a. (a -> a -> Bool) -> [a] -> a
converge a -> a -> Bool
p [a]
ys
converge a -> a -> Bool
_ [] = forall a. HasCallStack => Name -> a
error Name
"converge: empty list"
converge a -> a -> Bool
_ [a
_] = forall a. HasCallStack => Name -> a
error Name
"converge: finite list"

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

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