-- | 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
  , ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars
  , genBlockMap, genDefMap, BlockMap, DefMap
  , genCallMap, CallMap
  , loopNodes, genBackEdgeMap, sccWith, BackEdgeMap
  , genLoopNodeMap, LoopNodeMap
  , genInductionVarMap, InductionVarMap
  , genInductionVarMapByASTBlock, InductionVarMapByASTBlock
  , genDerivedInductionMap, DerivedInductionMap, InductionExpr(..)
  , showDataFlow, showFlowsDOT
  , BBNodeMap, BBNodeSet, ASTBlockNodeMap, ASTBlockNodeSet, ASTExprNodeMap, ASTExprNodeSet
) where

import Prelude hiding (init)
import Data.Generics.Uniplate.Data
import GHC.Generics
import Data.Data
import qualified Control.Monad.State.Lazy as Lazy
import Control.Monad.State.Strict
import Control.DeepSeq
import Control.Arrow ((&&&))
import Text.PrettyPrint.GenericPretty (Out)
import Language.Fortran.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)

import qualified Language.Fortran.Repr as Repr
import qualified Language.Fortran.Repr.Eval.Value as Repr

--------------------------------------------------
-- 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

-- | The map of all parameter variables and their corresponding values
type ParameterVarMap = M.Map Name Repr.FValue

-- | The map of all expressions and whether they are undecided (not
-- present in map), a constant value ('Just'), or probably not
-- constant ('Nothing').
type ConstExpMap = ASTExprNodeMap (Maybe Repr.FValue)

-- | 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 FValue)
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 FValue
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 FValue
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 Repr.FValue
    getV :: Expression (Analysis a) -> Maybe FValue
getV Expression (Analysis a)
e = forall a. Analysis a -> Maybe FValue
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 FValue)
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 FValue
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 Repr.FValue
    getE :: Expression (Analysis a) -> Maybe FValue
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 Repr.FValue
    doExpr :: Expression (Analysis a) -> Maybe FValue
doExpr Expression (Analysis a)
e =
        -- TODO constants may use other constants! but genConstExpMap needs more
        -- changes to support that
        case forall a.
Map Name FValue -> FEvalValuePure a -> Either Error (a, [Name])
Repr.runEvalFValuePure forall a. Monoid a => a
mempty (forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
Repr.evalExpr Expression (Analysis a)
e) of
          Left Error
_err -> forall a. Maybe a
Nothing
          Right (FValue
a, [Name]
_msgs) -> forall a. a -> Maybe a
Just FValue
a

-- | 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 FValue
constExp = forall a. Analysis a -> Maybe FValue
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 =>
Map Name FValue
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseParameterVars Map Name FValue
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 FValue
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) Map Name FValue
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 FValue
constExp = forall a. a -> Maybe a
Just FValue
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: