-- | 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 Control.Monad -- required for mtl-2.3 (GHC 9.6)

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 = ((BBNodeSet, BBNodeSet) -> BBNodeSet)
-> IntMap (BBNodeSet, BBNodeSet) -> DomMap
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map (BBNodeSet, BBNodeSet) -> BBNodeSet
forall a b. (a, b) -> b
snd (IntMap (BBNodeSet, BBNodeSet) -> DomMap)
-> IntMap (BBNodeSet, BBNodeSet) -> DomMap
forall a b. (a -> b) -> a -> b
$ BBGr a
-> (Int -> (BBNodeSet, BBNodeSet))
-> OrderF a
-> (OutF BBNodeSet -> OutF BBNodeSet)
-> (OutF BBNodeSet -> OutF BBNodeSet)
-> IntMap (BBNodeSet, BBNodeSet)
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 OrderF a
forall a. OrderF a
revPostOrder OutF BBNodeSet -> OutF BBNodeSet
inn OutF BBNodeSet -> OutF BBNodeSet
out
  where
    gr :: Gr (BB a) ()
gr        = BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
bbgr
    nodeSet :: BBNodeSet
nodeSet   = [Int] -> BBNodeSet
IS.fromList ([Int] -> BBNodeSet) -> [Int] -> BBNodeSet
forall a b. (a -> b) -> a -> b
$ Gr (BB a) () -> [Int]
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 :: OutF BBNodeSet -> OutF BBNodeSet
inn OutF BBNodeSet
outF Int
n
      | preNodes :: [Int]
preNodes@(Int
_:[Int]
_) <- Gr (BB a) () -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
pre Gr (BB a) ()
gr Int
n = (BBNodeSet -> BBNodeSet -> BBNodeSet) -> [BBNodeSet] -> BBNodeSet
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' BBNodeSet -> BBNodeSet -> BBNodeSet
IS.intersection ([BBNodeSet] -> BBNodeSet)
-> ([Int] -> [BBNodeSet]) -> [Int] -> BBNodeSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutF BBNodeSet -> [Int] -> [BBNodeSet]
forall a b. (a -> b) -> [a] -> [b]
map OutF BBNodeSet
outF ([Int] -> BBNodeSet) -> [Int] -> BBNodeSet
forall a b. (a -> b) -> a -> b
$ [Int]
preNodes
      | Bool
otherwise                  = BBNodeSet
IS.empty

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

-- | Reversed postordering.
revPostOrder :: OrderF a
revPostOrder :: forall a. OrderF a
revPostOrder = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> (BBGr a -> [Int]) -> BBGr a -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BBGr a -> [Int]
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 = (Tree Int -> [Int]) -> [Tree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Int -> [Int]
forall a. Tree a -> [a]
preorder ([Tree Int] -> [Int])
-> (Gr (BB a) () -> [Tree Int]) -> Gr (BB a) () -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Gr (BB a) () -> [Tree Int]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Tree Int]
dff (BBGr a -> [Int]
forall a. OrderF a
bbgrEntries BBGr a
gr) (Gr (BB a) () -> [Int]) -> Gr (BB a) () -> [Int]
forall a b. (a -> b) -> a -> b
$ BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr

-- | Reversed preordering.
revPreOrder :: OrderF a
revPreOrder :: forall a. OrderF a
revPreOrder = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> (BBGr a -> [Int]) -> BBGr a -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BBGr a -> [Int]
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 = (InOutMap t -> InOutMap t -> Bool) -> [InOutMap t] -> InOutMap t
forall a. (a -> a -> Bool) -> [a] -> a
converge InOutMap t -> InOutMap t -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([InOutMap t] -> InOutMap t) -> [InOutMap t] -> InOutMap t
forall a b. (a -> b) -> a -> b
$ (InOutMap t -> InOutMap t) -> InOutMap t -> [InOutMap t]
forall {t}. NFData t => (t -> t) -> t -> [t]
iterate' InOutMap t -> InOutMap t
step InOutMap t
initM
  where
    ordNodes :: [Int]
ordNodes     = OrderF a
order BBGr a
gr
    initM :: InOutMap t
initM        = [(Int, (t, t))] -> InOutMap t
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      = [(Int, (t, t))] -> InOutMap t
forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
n, (OutF t -> OutF t
inF ((t, t) -> t
forall a b. (a, b) -> b
snd ((t, t) -> t) -> (Int -> (t, t)) -> OutF t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InOutMap t -> Int -> (t, t)
forall {a}. IntMap a -> Int -> a
get' InOutMap t
m) Int
n, OutF t -> OutF t
outF ((t, t) -> t
forall a b. (a, b) -> a
fst ((t, t) -> t) -> (Int -> (t, t)) -> OutF t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InOutMap t -> Int -> (t, t)
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     = Name -> Maybe a -> a
forall a. Name -> Maybe a -> a
fromJustMsg (Name
"dataFlowSolver: get " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show Int
n) (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Int -> IntMap a -> Maybe a
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 t -> [t] -> [t]
forall a b. NFData a => a -> b -> b
`deepseq` t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: (t -> t) -> t -> [t]
iterate' t -> t
f (t -> t
f t
x)

-- Similar to above but return a list of states instead of just the final one.
--dataFlowSolver' :: Ord t => BBGr a            -- ^ basic block graph
--                        -> (Node -> InOut t) -- ^ initialisation for in and out dataflows
--                        -> OrderF a          -- ^ ordering function
--                        -> (OutF t -> InF t) -- ^ compute the in-flow given an out-flow function
--                        -> (InF t -> OutF t) -- ^ compute the out-flow given an in-flow function
--                        -> [InOutMap t]        -- ^ dataflow steps
--dataFlowSolver' gr initF order inF outF = iterate step initM
--  where
--    ordNodes = order gr
--    initM    = IM.fromList [ (n, initF n) | n <- ordNodes ]
--    step m   = IM.fromList [ (n, (inF (snd . get m) n, outF (fst . get m) n)) | n <- ordNodes ]
--    get m n  = fromJustMsg ("dataFlowSolver': get " ++ show (n)) $ IM.lookup n m

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

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

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

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

-- | Build a DefMap from the BlockMap. This allows us to quickly look
-- up the AST-block labels that wrote into the given variable.
genDefMap :: Data a => BlockMap a -> DefMap
genDefMap :: forall a. Data a => BlockMap a -> DefMap
genDefMap BlockMap a
bm = (BBNodeSet -> BBNodeSet -> BBNodeSet)
-> [(Name, BBNodeSet)] -> DefMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union [
                 (Name
y, OutF BBNodeSet
IS.singleton Int
i) | (Int
i, Block (Analysis a)
b) <- BlockMap a -> [(Int, Block (Analysis a))]
forall a. IntMap a -> [(Int, a)]
IM.toList BlockMap a
bm, Name
y <- Block (Analysis a) -> [Name]
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 = BBGr (Analysis a)
-> (Int -> InOut (Set Name))
-> OrderF (Analysis a)
-> (OutF (Set Name) -> OutF (Set Name))
-> (OutF (Set Name) -> OutF (Set Name))
-> InOutMap (Set Name)
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 (InOut (Set Name) -> Int -> InOut (Set Name)
forall a b. a -> b -> a
const (Set Name
forall a. Set a
S.empty, Set Name
forall a. Set a
S.empty)) OrderF (Analysis a)
forall a. OrderF a
revPreOrder OutF (Set Name) -> OutF (Set Name)
inn OutF (Set Name) -> OutF (Set Name)
out
  where
    inn :: OutF (Set Name) -> OutF (Set Name)
inn OutF (Set Name)
outF Int
b = (OutF (Set Name)
outF Int
b Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.\\ OutF (Set Name)
kill Int
b) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` OutF (Set Name)
gen Int
b
    out :: OutF (Set Name) -> OutF (Set Name)
out OutF (Set Name)
innF Int
b = [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [ OutF (Set Name)
innF Int
s | Int
s <- Gr (BB (Analysis a)) () -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
suc (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b ]
    kill :: OutF (Set Name)
kill Int
b     = BB (Analysis a) -> Set Name
forall a. Data a => [Block (Analysis a)] -> Set Name
bblockKill (Name -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. Name -> Maybe a -> a
fromJustMsg Name
"liveVariableAnalysis kill" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Int -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b)
    gen :: OutF (Set Name)
gen Int
b      = BB (Analysis a) -> Set Name
forall a. Data a => [Block (Analysis a)] -> Set Name
bblockGen (Name -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. Name -> Maybe a -> a
fromJustMsg Name
"liveVariableAnalysis gen" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Int -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
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 = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name)
-> ([Block (Analysis a)] -> [Name])
-> [Block (Analysis a)]
-> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block (Analysis a) -> [Name]) -> [Block (Analysis a)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block (Analysis a) -> [Name]
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 = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name)
-> ([([Name], [Name])] -> [Name]) -> [([Name], [Name])] -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name], [Name]) -> [Name]
forall a b. (a, b) -> a
fst (([Name], [Name]) -> [Name])
-> ([([Name], [Name])] -> ([Name], [Name]))
-> [([Name], [Name])]
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Name], [Name]) -> ([Name], [Name]) -> ([Name], [Name]))
-> ([Name], [Name]) -> [([Name], [Name])] -> ([Name], [Name])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Name], [Name]) -> ([Name], [Name]) -> ([Name], [Name])
forall {a}. Eq a => ([a], [a]) -> ([a], [a]) -> ([a], [a])
f ([], []) ([([Name], [Name])] -> Set Name) -> [([Name], [Name])] -> Set Name
forall a b. (a -> b) -> a -> b
$ (Block (Analysis a) -> ([Name], [Name]))
-> [Block (Analysis a)] -> [([Name], [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (Block (Analysis a) -> [Name]
forall a. Data a => Block (Analysis a) -> [Name]
blockGen (Block (Analysis a) -> [Name])
-> (Block (Analysis a) -> [Name])
-> Block (Analysis a)
-> ([Name], [Name])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Block (Analysis a) -> [Name]
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 [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
bbkill) [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`union` [a]
bbgen, [a]
kill [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`union` [a]
bbkill)

-- | "KILL" set for a single AST-block.
blockKill :: Data a => Block (Analysis a) -> [Name]
blockKill :: forall a. Data a => Block (Analysis a) -> [Name]
blockKill = Block (Analysis a) -> [Name]
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 = Block (Analysis a) -> [Name]
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) -> IntMap (BBNodeSet, BBNodeSet)
reachingDefinitions DefMap
dm BBGr (Analysis a)
gr = BBGr (Analysis a)
-> (Int -> (BBNodeSet, BBNodeSet))
-> OrderF (Analysis a)
-> (OutF BBNodeSet -> OutF BBNodeSet)
-> (OutF BBNodeSet -> OutF BBNodeSet)
-> IntMap (BBNodeSet, BBNodeSet)
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 ((BBNodeSet, BBNodeSet) -> Int -> (BBNodeSet, BBNodeSet)
forall a b. a -> b -> a
const (BBNodeSet
IS.empty, BBNodeSet
IS.empty)) OrderF (Analysis a)
forall a. OrderF a
revPostOrder OutF BBNodeSet -> OutF BBNodeSet
inn OutF BBNodeSet -> OutF BBNodeSet
out
  where
    inn :: OutF BBNodeSet -> OutF BBNodeSet
inn OutF BBNodeSet
outF Int
b = [BBNodeSet] -> BBNodeSet
forall (f :: * -> *). Foldable f => f BBNodeSet -> BBNodeSet
IS.unions [ OutF BBNodeSet
outF Int
s | Int
s <- Gr (BB (Analysis a)) () -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
pre (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b ]
    out :: OutF BBNodeSet -> OutF BBNodeSet
out OutF BBNodeSet
innF Int
b = BBNodeSet
gen BBNodeSet -> BBNodeSet -> BBNodeSet
`IS.union` (OutF BBNodeSet
innF Int
b BBNodeSet -> BBNodeSet -> BBNodeSet
IS.\\ BBNodeSet
kill)
      where (BBNodeSet
gen, BBNodeSet
kill) = DefMap -> BB (Analysis a) -> (BBNodeSet, BBNodeSet)
forall a.
Data a =>
DefMap -> [Block (Analysis a)] -> (BBNodeSet, BBNodeSet)
rdBblockGenKill DefMap
dm (Name -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. Name -> Maybe a -> a
fromJustMsg Name
"reachingDefinitions" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Int -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
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 = ((BBNodeSet, BBNodeSet)
 -> (BBNodeSet, BBNodeSet) -> (BBNodeSet, BBNodeSet))
-> (BBNodeSet, BBNodeSet)
-> [(BBNodeSet, BBNodeSet)]
-> (BBNodeSet, BBNodeSet)
forall b a. (b -> a -> b) -> b -> [a] -> b
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) ([(BBNodeSet, BBNodeSet)] -> (BBNodeSet, BBNodeSet))
-> [(BBNodeSet, BBNodeSet)] -> (BBNodeSet, BBNodeSet)
forall a b. (a -> b) -> a -> b
$ (Block (Analysis a) -> (BBNodeSet, BBNodeSet))
-> [Block (Analysis a)] -> [(BBNodeSet, BBNodeSet)]
forall a b. (a -> b) -> [a] -> [b]
map (Block (Analysis a) -> BBNodeSet
forall {a}. Data a => Block (Analysis a) -> BBNodeSet
gen (Block (Analysis a) -> BBNodeSet)
-> (Block (Analysis a) -> BBNodeSet)
-> Block (Analysis a)
-> (BBNodeSet, BBNodeSet)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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 | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Block (Analysis a) -> [Name]
forall a. Data a => Block (Analysis a) -> [Name]
allLhsVars Block (Analysis a)
b) = BBNodeSet
IS.empty
          | Bool
otherwise           = OutF BBNodeSet
IS.singleton OutF BBNodeSet
-> (Block (Analysis a) -> Int) -> Block (Analysis a) -> BBNodeSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Int -> Int
forall a. Name -> Maybe a -> a
fromJustMsg Name
"rdBblockGenKill" (Maybe Int -> Int)
-> (Block (Analysis a) -> Maybe Int) -> Block (Analysis a) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Analysis a -> Maybe Int)
-> (Block (Analysis a) -> Analysis a)
-> Block (Analysis a)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Analysis a
forall a. Block a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation (Block (Analysis a) -> BBNodeSet)
-> Block (Analysis a) -> BBNodeSet
forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b
    kill :: Block (Analysis a) -> BBNodeSet
kill = DefMap -> Block (Analysis a) -> BBNodeSet
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 = [BBNodeSet] -> BBNodeSet
forall (f :: * -> *). Foldable f => f BBNodeSet -> BBNodeSet
IS.unions [ BBNodeSet
IS.empty BBNodeSet -> Maybe BBNodeSet -> BBNodeSet
forall a. a -> Maybe a -> a
`fromMaybe` Name -> DefMap -> Maybe BBNodeSet
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
y DefMap
dm | Name
y <- Block (Analysis a) -> [Name]
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)
-> IntMap (BBNodeSet, BBNodeSet)
-> DomMap
genDUMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr IntMap (BBNodeSet, BBNodeSet)
rdefs = (BBNodeSet -> BBNodeSet -> BBNodeSet) -> [DomMap] -> DomMap
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 = [ (DomMap, BBNodeSet) -> DomMap
forall a b. (a, b) -> a
fst (((DomMap, BBNodeSet) -> Block (Analysis a) -> (DomMap, BBNodeSet))
-> (DomMap, BBNodeSet)
-> [Block (Analysis a)]
-> (DomMap, BBNodeSet)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (DomMap, BBNodeSet) -> Block (Analysis a) -> (DomMap, BBNodeSet)
inBBlock (DomMap
forall a. IntMap a
IM.empty, BBNodeSet
is) [Block (Analysis a)]
bs) |
               (Int
n, (BBNodeSet
is, BBNodeSet
_)) <- IntMap (BBNodeSet, BBNodeSet) -> [(Int, (BBNodeSet, BBNodeSet))]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (BBNodeSet, BBNodeSet)
rdefs,
               let Just [Block (Analysis a)]
bs = Gr [Block (Analysis a)] () -> Int -> Maybe [Block (Analysis a)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr [Block (Analysis a)] ()
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 = Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Block (Analysis a) -> Analysis a
forall a. Block a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b)
        bduMap :: DomMap
bduMap = (BBNodeSet -> BBNodeSet -> BBNodeSet)
-> [(Int, BBNodeSet)] -> DomMap
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union [ (Int
i', OutF 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 (Bool -> Bool) -> ([Name] -> Bool) -> [Name] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Name] -> Bool) -> ([Name] -> [Name]) -> [Name] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
intersect [Name]
uses ([Name] -> Bool) -> [Name] -> Bool
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> [Name]
forall a. Data a => Block (Analysis a) -> [Name]
blockVarDefs Block (Analysis a)
b'
          where Just Block (Analysis a)
b' = Int -> BlockMap a -> Maybe (Block (Analysis a))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i' BlockMap a
bm
        uses :: [Name]
uses   = Block (Analysis a) -> [Name]
forall a. Data a => Block (Analysis a) -> [Name]
blockVarUses Block (Analysis a)
b
        duMap' :: DomMap
duMap' = (BBNodeSet -> BBNodeSet -> BBNodeSet) -> DomMap -> DomMap -> DomMap
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' | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Block (Analysis a) -> [Name]
forall a. Data a => Block (Analysis a) -> [Name]
allLhsVars Block (Analysis a)
b') = BBNodeSet
IS.empty
               | Bool
otherwise           = OutF BBNodeSet
IS.singleton OutF BBNodeSet
-> (Block (Analysis a) -> Int) -> Block (Analysis a) -> BBNodeSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Int -> Int
forall a. Name -> Maybe a -> a
fromJustMsg Name
"genDUMap" (Maybe Int -> Int)
-> (Block (Analysis a) -> Maybe Int) -> Block (Analysis a) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Analysis a -> Maybe Int)
-> (Block (Analysis a) -> Analysis a)
-> Block (Analysis a)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Analysis a
forall a. Block a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation (Block (Analysis a) -> BBNodeSet)
-> Block (Analysis a) -> BBNodeSet
forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b'
        kill :: Block (Analysis a) -> BBNodeSet
kill   = DefMap -> Block (Analysis a) -> BBNodeSet
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` Block (Analysis a) -> BBNodeSet
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 = (BBNodeSet -> BBNodeSet -> BBNodeSet)
-> [(Int, BBNodeSet)] -> DomMap
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith BBNodeSet -> BBNodeSet -> BBNodeSet
IS.union [
    (Int
use, OutF BBNodeSet
IS.singleton Int
def) | (Int
def, BBNodeSet
uses) <- DomMap -> [(Int, BBNodeSet)]
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)
-> IntMap (BBNodeSet, BBNodeSet)
-> DomMap
genUDMap BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr = DomMap -> DomMap
duMapToUdMap (DomMap -> DomMap)
-> (IntMap (BBNodeSet, BBNodeSet) -> DomMap)
-> IntMap (BBNodeSet, BBNodeSet)
-> DomMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (BBNodeSet, BBNodeSet)
-> DomMap
forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (BBNodeSet, 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 = [LNode (Block (Analysis a))]
-> [LEdge ()] -> gr (Block (Analysis a)) ()
forall a b. [LNode a] -> [LEdge b] -> gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode (Block (Analysis a))]
nodes' [LEdge ()]
edges'
  where
    nodes' :: [LNode (Block (Analysis a))]
nodes' = [ (Int
i, Block (Analysis a)
iLabel) | Int
i <- DomMap -> [Int]
forall a. IntMap a -> [Int]
IM.keys DomMap
m [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (BBNodeSet -> [Int]) -> [BBNodeSet] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BBNodeSet -> [Int]
IS.toList (DomMap -> [BBNodeSet]
forall a. IntMap a -> [a]
IM.elems DomMap
m)
                          , let iLabel :: Block (Analysis a)
iLabel = Name -> Maybe (Block (Analysis a)) -> Block (Analysis a)
forall a. Name -> Maybe a -> a
fromJustMsg Name
"mapToGraph" (Int -> BlockMap a -> Maybe (Block (Analysis a))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i BlockMap a
bm) ]
    edges' :: [LEdge ()]
edges' = [ (Int
i, Int
j, ()) | (Int
i, BBNodeSet
js) <- DomMap -> [(Int, BBNodeSet)]
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)
-> IntMap (BBNodeSet, BBNodeSet)
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
gr = BlockMap a -> DomMap -> Gr (Block (Analysis a)) ()
forall (gr :: * -> * -> *) a.
DynGraph gr =>
BlockMap a -> DomMap -> gr (Block (Analysis a)) ()
mapToGraph BlockMap a
bm (DomMap -> Gr (Block (Analysis a)) ())
-> (IntMap (BBNodeSet, BBNodeSet) -> DomMap)
-> IntMap (BBNodeSet, BBNodeSet)
-> Gr (Block (Analysis a)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (BBNodeSet, BBNodeSet)
-> DomMap
forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (BBNodeSet, 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 = (Set Name -> Set Name -> Set Name)
-> [(Name, Set Name)] -> VarFlowsMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.union [ (Int -> Name
conv Int
u, OutF (Set Name)
sconv Int
v) | (Int
u, Int
v) <- FlowsGraph a -> [(Int, Int)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [(Int, Int)]
edges FlowsGraph a
fg ]
  where
    sconv :: OutF (Set Name)
sconv Int
i | Just Name
v  <- Int -> IntMap Name -> Maybe Name
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i IntMap Name
revDM = Name -> Set Name
forall a. a -> Set a
S.singleton Name
v
            | Bool
otherwise                    = Set Name
forall a. Set a
S.empty
    conv :: Int -> Name
conv Int
i | Just Name
v  <- Int -> IntMap Name -> Maybe Name
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i IntMap Name
revDM = Name
v
           | Bool
otherwise                    = Name -> Name
forall a. HasCallStack => Name -> a
error (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name
"genVarFlowsToMap: convert failed, i=" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
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 = (Name -> Name -> Name) -> [(Int, Name)] -> IntMap Name
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith (((Name, Name) -> Name) -> Name -> Name -> Name
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Name, Name) -> Name
forall a b. (a, b) -> a
fst) [ (Int
i, Name
v) | (Name
v, BBNodeSet
is) <- DefMap -> [(Name, BBNodeSet)]
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) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
31::Integer)

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

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

-- | 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 information about 'constant expressions'.
    ceMap :: ConstExpMap
ceMap = [(Int, Maybe FValue)] -> ConstExpMap
forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
label, Expression (Analysis a) -> Maybe FValue
doExpr Expression (Analysis a)
e) | Expression (Analysis a)
e <- ProgramFile (Analysis a) -> [Expression (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf, Just Int
label <- [Expression (Analysis a) -> Maybe Int
forall {a}. Expression (Analysis a) -> Maybe Int
labelOf Expression (Analysis a)
e] ]

    -- Initial map of parameter declarations
    pvMap :: M.Map Name Repr.FValue
    pvMap :: Map Name FValue
pvMap = State (Map Name FValue) () -> Map Name FValue -> Map Name FValue
forall s a. State s a -> s -> s
execState ([Statement (Analysis a)] -> State (Map Name FValue) ()
recursivelyProcessDecls [Statement (Analysis a)]
declarations) Map Name FValue
forall k a. Map k a
M.empty

    -- Gather all the declarations in order
    declarations :: [Statement (Analysis a)]
    declarations :: [Statement (Analysis a)]
declarations =
      ((Statement (Analysis a) -> Bool)
 -> [Statement (Analysis a)] -> [Statement (Analysis a)])
-> [Statement (Analysis a)]
-> (Statement (Analysis a) -> Bool)
-> [Statement (Analysis a)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Statement (Analysis a) -> Bool)
-> [Statement (Analysis a)] -> [Statement (Analysis a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ProgramFile (Analysis a) -> [Statement (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf :: [Statement (Analysis a)]) ((Statement (Analysis a) -> Bool) -> [Statement (Analysis a)])
-> (Statement (Analysis a) -> Bool) -> [Statement (Analysis a)]
forall a b. (a -> b) -> a -> b
$
          \case
              StDeclaration{} -> Bool
True
              StParameter{}   -> Bool
True
              Statement (Analysis a)
_               -> Bool
False

    recursivelyProcessDecls :: [Statement (Analysis a)] -> State (M.Map Name Repr.FValue) ()
    recursivelyProcessDecls :: [Statement (Analysis a)] -> State (Map Name FValue) ()
recursivelyProcessDecls [] = () -> State (Map Name FValue) ()
forall a. a -> StateT (Map Name FValue) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    recursivelyProcessDecls (Statement (Analysis a)
stmt:[Statement (Analysis a)]
stmts) = do
      let internalDecls :: [(Name, Expression (Analysis a))]
internalDecls =
            case Statement (Analysis a)
stmt of
              (StDeclaration Analysis a
_ SrcSpan
_ (TypeSpec Analysis a
_ SrcSpan
_ BaseType
_ Maybe (Selector (Analysis a))
_) Maybe (AList Attribute (Analysis a))
_ AList Declarator (Analysis a)
_) ->
                -- Gather up all the declarations that are contain in this StDeclaration
                -- (there could be many)
                [ (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v, Expression (Analysis a)
e)
                   | (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v DeclaratorType (Analysis a)
_ Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
e)) <- Statement (Analysis a) -> [Declarator (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
stmt :: [Declarator (Analysis a)]
                    , AttrParameter Analysis a
_ SrcSpan
_ <- Statement (Analysis a) -> [Attribute (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
stmt :: [Attribute (Analysis a)] ]

              StParameter{} ->
                [(Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v, Expression (Analysis a)
e) | (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v DeclaratorType (Analysis a)
ScalarDecl Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
e)) <- Statement (Analysis a) -> [Declarator (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi Statement (Analysis a)
stmt ]
              Statement (Analysis a)
_ -> []
      -- Now process these decls
      [(Name, Expression (Analysis a))]
-> ((Name, Expression (Analysis a)) -> State (Map Name FValue) ())
-> State (Map Name FValue) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, Expression (Analysis a))]
internalDecls (\(Name
v, Expression (Analysis a)
e) -> (Map Name FValue -> Map Name FValue) -> State (Map Name FValue) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Map Name FValue
map ->
        case Map Name FValue -> Expression (Analysis a) -> Maybe FValue
getE0 Map Name FValue
map Expression (Analysis a)
e of
          Just FValue
evalExpr -> Name -> FValue -> Map Name FValue -> Map Name FValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
v FValue
evalExpr Map Name FValue
map
          Maybe FValue
Nothing       -> Map Name FValue
map))
      [Statement (Analysis a)] -> State (Map Name FValue) ()
recursivelyProcessDecls [Statement (Analysis a)]
stmts

    -- Evaluate an expression down to a value
    getE0 :: M.Map Name Repr.FValue -> Expression (Analysis a) -> Maybe (Repr.FValue)
    getE0 :: Map Name FValue -> Expression (Analysis a) -> Maybe FValue
getE0 Map Name FValue
pvMap Expression (Analysis a)
e = (Error -> Maybe FValue)
-> ((FValue, [Name]) -> Maybe FValue)
-> Either Error (FValue, [Name])
-> Maybe FValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe FValue -> Error -> Maybe FValue
forall a b. a -> b -> a
const Maybe FValue
forall a. Maybe a
Nothing) (FValue -> Maybe FValue
forall a. a -> Maybe a
Just (FValue -> Maybe FValue)
-> ((FValue, [Name]) -> FValue) -> (FValue, [Name]) -> Maybe FValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FValue, [Name]) -> FValue
forall a b. (a, b) -> a
fst) (Map Name FValue
-> FEvalValuePure FValue -> Either Error (FValue, [Name])
forall a.
Map Name FValue -> FEvalValuePure a -> Either Error (a, [Name])
Repr.runEvalFValuePure Map Name FValue
pvMap (Expression (Analysis a) -> FEvalValuePure FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
Repr.evalExpr Expression (Analysis a)
e))

    -- Lookup an expression in the constants maps
    getE :: Expression (Analysis a) -> Maybe Repr.FValue
    getE :: Expression (Analysis a) -> Maybe FValue
getE = Maybe (Maybe FValue) -> Maybe FValue
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe FValue) -> Maybe FValue)
-> (Expression (Analysis a) -> Maybe (Maybe FValue))
-> Expression (Analysis a)
-> Maybe FValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> ConstExpMap -> Maybe (Maybe FValue))
-> ConstExpMap -> Int -> Maybe (Maybe FValue)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ConstExpMap -> Maybe (Maybe FValue)
forall a. Int -> IntMap a -> Maybe a
IM.lookup ConstExpMap
ceMap (Int -> Maybe (Maybe FValue))
-> (Expression (Analysis a) -> Maybe Int)
-> Expression (Analysis a)
-> Maybe (Maybe FValue)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Expression (Analysis a) -> Maybe Int
forall {a}. Expression (Analysis a) -> Maybe Int
labelOf)

    labelOf :: Expression (Analysis a) -> Maybe Int
labelOf = Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Analysis a -> Maybe Int)
-> (Expression (Analysis a) -> Analysis a)
-> Expression (Analysis a)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Analysis a) -> Analysis a
forall a. Expression a -> a
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 Map Name FValue
-> FEvalValuePure FValue -> Either Error (FValue, [Name])
forall a.
Map Name FValue -> FEvalValuePure a -> Either Error (a, [Name])
Repr.runEvalFValuePure Map Name FValue
pvMap (Expression (Analysis a) -> FEvalValuePure FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
Repr.evalExpr Expression (Analysis a)
e) of
          Left Error
_err -> Maybe FValue
forall a. Maybe a
Nothing
          Right (FValue
a, [Name]
_msgs) -> FValue -> Maybe FValue
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 = ProgramFile (Analysis a) -> ConstExpMap
forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap
genConstExpMap ProgramFile (Analysis a)
pf
    -- transform both the AST and the basic block graph
    pf' :: ProgramFile (Analysis a)
pf'   = (BBGr (Analysis a) -> BBGr (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
transformBB ((Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> BBGr (Analysis a) -> BBGr (Analysis a)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (([Block (Analysis a)] -> [Block (Analysis a)])
-> Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
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))) (ProgramFile (Analysis a) -> ProgramFile (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall a b. (a -> b) -> a -> b
$ (Expression (Analysis a) -> Expression (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Expression (Analysis a) -> Expression (Analysis a)
insertConstExp ProgramFile (Analysis a)
pf
    -- insert info about constExp into Expression annotation
    insertConstExp :: Expression (Analysis a) -> Expression (Analysis a)
    insertConstExp :: Expression (Analysis a) -> Expression (Analysis a)
insertConstExp Expression (Analysis a)
e = ((Analysis a -> Analysis a)
 -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a)
-> (Analysis a -> Analysis a)
-> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Analysis a -> Analysis a)
-> Expression (Analysis a) -> Expression (Analysis a)
forall a. (a -> a) -> Expression a -> Expression a
forall (f :: * -> *) a. Annotated f => (a -> a) -> f a -> f a
modifyAnnotation Expression (Analysis a)
e ((Analysis a -> Analysis a) -> Expression (Analysis a))
-> (Analysis a -> Analysis a) -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ \ Analysis a
a ->
      Analysis a
a { constExp = constExp a `mplus` join (flip IM.lookup ceMap =<< insLabel (getAnnotation e)) }
    -- utility functions for transforming expressions tucked away inside of the basic block graph
    transformBB :: (BBGr (Analysis a) -> BBGr (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
    transformBB :: (BBGr (Analysis a) -> BBGr (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
transformBB = (BBGr (Analysis a) -> BBGr (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi
    transformExpr :: (Expression (Analysis a) -> Expression (Analysis a)) ->
                     [Block (Analysis a)] -> [Block (Analysis a)]
    transformExpr :: (Expression (Analysis a) -> Expression (Analysis a))
-> [Block (Analysis a)] -> [Block (Analysis a)]
transformExpr = (Expression (Analysis a) -> Expression (Analysis a))
-> [Block (Analysis a)] -> [Block (Analysis a)]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi

-- | Annotate AST with constant-expression information based on given
-- ParameterVarMap.
analyseParameterVars :: forall a. Data a => ParameterVarMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseParameterVars :: forall a.
Data a =>
Map Name FValue
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseParameterVars Map Name FValue
pvm = (Expression (Analysis a) -> Expression (Analysis a))
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Expression (Analysis a) -> Expression (Analysis a)
expr
  where
    expr :: Expression (Analysis a) -> Expression (Analysis a)
    expr :: Expression (Analysis a) -> Expression (Analysis a)
expr e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ ValVariable{})
      | Just FValue
con <- Name -> Map Name FValue -> Maybe FValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e) Map Name FValue
pvm = ((Analysis a -> Analysis a)
 -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a)
-> (Analysis a -> Analysis a)
-> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Analysis a -> Analysis a)
-> Expression (Analysis a) -> Expression (Analysis a)
forall a. (a -> a) -> Expression a -> Expression a
forall (f :: * -> *) a. Annotated f => (a -> a) -> f a -> f a
modifyAnnotation Expression (Analysis a)
e ((Analysis a -> Analysis a) -> Expression (Analysis a))
-> (Analysis a -> Analysis a) -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ \ Analysis a
a -> Analysis a
a { constExp = Just 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 = [(Int, Int)] -> IDomMap
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, Int)] -> IDomMap)
-> (gr a b -> [(Int, Int)]) -> gr a b -> IDomMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Int) -> Bool
isBackEdge ([(Int, Int)] -> [(Int, Int)])
-> (gr a b -> [(Int, Int)]) -> gr a b -> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. gr a b -> [(Int, Int)]
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` Name -> Maybe BBNodeSet -> BBNodeSet
forall a. Name -> Maybe a -> a
fromJustMsg Name
"genBackEdgeMap" (Int
s Int -> DomMap -> Maybe BBNodeSet
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
nInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Int -> gr a b -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> [Int]
sccWith Int
n gr a b
gr) ([Int] -> gr a b -> [Int]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Int]
rdfs [Int
m] (Int -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> gr a b
delNode Int
n gr a b
gr))) | (Int
m, Int
n) <- IDomMap -> [(Int, Int)]
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 = [(Int, BBNodeSet)] -> DomMap
forall a. [(Int, a)] -> IntMap a
IM.fromList [
    (Int
n, [Int] -> BBNodeSet
IS.fromList (Int
nInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
intersect (Int -> gr a b -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> [Int]
sccWith Int
n gr a b
gr) ([Int] -> gr a b -> [Int]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Int]
rdfs [Int
m] (Int -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b. Graph gr => Int -> gr a b -> gr a b
delNode Int
n gr a b
gr)))) | (Int
m, Int
n) <- IDomMap -> [(Int, Int)]
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 ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int
n Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ gr a b -> [[Int]]
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 = (Set Name -> Set Name -> Set Name)
-> [(Int, Set Name)] -> InductionVarMap
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.union [
    (Int
n, Name -> Set Name
forall a. a -> Set a
S.singleton Name
v) | (Int
_, Int
n)      <- IDomMap -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
IM.toList IDomMap
bedges
                       , let Just BB (Analysis a)
bs = Gr (BB (Analysis a)) () -> Int -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
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           <- Block (Analysis a) -> [Name]
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 = IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars

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

-- | Generate an induction variable map that is indexed by the labels
-- on AST-blocks within those loops.
genInductionVarMapByASTBlock :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMapByASTBlock
genInductionVarMapByASTBlock :: forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMapByASTBlock IDomMap
bedges BBGr (Analysis a)
gr = InductionVarMap -> InductionVarMap
loopsToLabs (InductionVarMap -> InductionVarMap)
-> (BBGr (Analysis a) -> InductionVarMap)
-> BBGr (Analysis a)
-> InductionVarMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
genInductionVarMap IDomMap
bedges (BBGr (Analysis a) -> InductionVarMap)
-> BBGr (Analysis a) -> InductionVarMap
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a)
gr
  where
    lnMap :: DomMap
lnMap       = IDomMap -> Gr [Block (Analysis a)] () -> DomMap
forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> DomMap
genLoopNodeMap IDomMap
bedges (Gr [Block (Analysis a)] () -> DomMap)
-> Gr [Block (Analysis a)] () -> DomMap
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr [Block (Analysis a)] ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr
    get' :: OutF BBNodeSet
get'        = BBNodeSet -> Maybe BBNodeSet -> BBNodeSet
forall a. a -> Maybe a -> a
fromMaybe (Name -> BBNodeSet
forall a. HasCallStack => Name -> a
error Name
"missing loop-header node") (Maybe BBNodeSet -> BBNodeSet)
-> (Int -> Maybe BBNodeSet) -> OutF BBNodeSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> DomMap -> Maybe BBNodeSet)
-> DomMap -> Int -> Maybe BBNodeSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> DomMap -> Maybe BBNodeSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup DomMap
lnMap
    astLabels :: Int -> [Int]
astLabels Int
n = [ Int
i | Block (Analysis a)
b <- (Maybe [Block (Analysis a)] -> [Block (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (Gr [Block (Analysis a)] () -> Int -> Maybe [Block (Analysis a)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr [Block (Analysis a)] ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
n)
                      , let Just Int
i = Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Block (Analysis a) -> Analysis a
forall a. Block a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) ]
    loopsToLabs :: InductionVarMap -> InductionVarMap
loopsToLabs         = (Set Name -> Set Name -> Set Name)
-> [(Int, Set Name)] -> InductionVarMap
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.union ([(Int, Set Name)] -> InductionVarMap)
-> (InductionVarMap -> [(Int, Set Name)])
-> InductionVarMap
-> InductionVarMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Set Name) -> [(Int, Set Name)])
-> [(Int, Set Name)] -> [(Int, Set Name)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, Set Name) -> [(Int, Set Name)]
loopToLabs ([(Int, Set Name)] -> [(Int, Set Name)])
-> (InductionVarMap -> [(Int, Set Name)])
-> InductionVarMap
-> [(Int, Set Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InductionVarMap -> [(Int, Set Name)]
forall a. IntMap a -> [(Int, a)]
IM.toList
    loopToLabs :: (Int, Set Name) -> [(Int, Set Name)]
loopToLabs (Int
n, Set Name
ivs) = ((Int -> (Int, Set Name)) -> [Int] -> [(Int, Set Name)]
forall a b. (a -> b) -> [a] -> [b]
map (,Set Name
ivs) ([Int] -> [(Int, Set Name)])
-> (Int -> [Int]) -> Int -> [(Int, Set Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
astLabels) (Int -> [(Int, Set Name)]) -> [Int] -> [(Int, Set Name)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BBNodeSet -> [Int]
IS.toList (OutF 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 -> Name -> Name
[InductionExpr] -> Name -> Name
InductionExpr -> Name
(Int -> InductionExpr -> Name -> Name)
-> (InductionExpr -> Name)
-> ([InductionExpr] -> Name -> Name)
-> Show InductionExpr
forall a.
(Int -> a -> Name -> Name)
-> (a -> Name) -> ([a] -> Name -> Name) -> Show a
$cshowsPrec :: Int -> InductionExpr -> Name -> Name
showsPrec :: Int -> InductionExpr -> Name -> Name
$cshow :: InductionExpr -> Name
show :: InductionExpr -> Name
$cshowList :: [InductionExpr] -> Name -> Name
showList :: [InductionExpr] -> Name -> Name
Show, InductionExpr -> InductionExpr -> Bool
(InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool) -> Eq InductionExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InductionExpr -> InductionExpr -> Bool
== :: InductionExpr -> InductionExpr -> Bool
$c/= :: InductionExpr -> InductionExpr -> Bool
/= :: InductionExpr -> InductionExpr -> Bool
Eq, Eq InductionExpr
Eq InductionExpr =>
(InductionExpr -> InductionExpr -> Ordering)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> Bool)
-> (InductionExpr -> InductionExpr -> InductionExpr)
-> (InductionExpr -> InductionExpr -> InductionExpr)
-> Ord InductionExpr
InductionExpr -> InductionExpr -> Bool
InductionExpr -> InductionExpr -> Ordering
InductionExpr -> InductionExpr -> InductionExpr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: InductionExpr -> InductionExpr -> Ordering
compare :: InductionExpr -> InductionExpr -> Ordering
$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
>= :: InductionExpr -> InductionExpr -> Bool
$cmax :: InductionExpr -> InductionExpr -> InductionExpr
max :: InductionExpr -> InductionExpr -> InductionExpr
$cmin :: InductionExpr -> InductionExpr -> InductionExpr
min :: InductionExpr -> InductionExpr -> InductionExpr
Ord, Typeable, (forall x. InductionExpr -> Rep InductionExpr x)
-> (forall x. Rep InductionExpr x -> InductionExpr)
-> Generic InductionExpr
forall x. Rep InductionExpr x -> InductionExpr
forall x. InductionExpr -> Rep InductionExpr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InductionExpr -> Rep InductionExpr x
from :: forall x. InductionExpr -> Rep InductionExpr x
$cto :: forall x. Rep InductionExpr x -> InductionExpr
to :: forall x. Rep InductionExpr x -> InductionExpr
Generic, Typeable InductionExpr
Typeable InductionExpr =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> InductionExpr -> c InductionExpr)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c InductionExpr)
-> (InductionExpr -> Constr)
-> (InductionExpr -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c InductionExpr))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c InductionExpr))
-> ((forall b. Data b => b -> b) -> InductionExpr -> InductionExpr)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> InductionExpr -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> InductionExpr -> r)
-> (forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> InductionExpr -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr)
-> Data InductionExpr
InductionExpr -> Constr
InductionExpr -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> InductionExpr -> c InductionExpr
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> InductionExpr -> c InductionExpr
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c InductionExpr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c InductionExpr
$ctoConstr :: InductionExpr -> Constr
toConstr :: InductionExpr -> Constr
$cdataTypeOf :: InductionExpr -> DataType
dataTypeOf :: InductionExpr -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c InductionExpr)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c InductionExpr)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c InductionExpr)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c InductionExpr)
$cgmapT :: (forall b. Data b => b -> b) -> InductionExpr -> InductionExpr
gmapT :: (forall b. Data b => b -> b) -> InductionExpr -> InductionExpr
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> InductionExpr -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> InductionExpr -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> InductionExpr -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> InductionExpr -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> InductionExpr -> m InductionExpr
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> InductionExpr -> m 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 -> Name -> Name
[IEFlow] -> Name -> Name
IEFlow -> Name
(Int -> IEFlow -> Name -> Name)
-> (IEFlow -> Name) -> ([IEFlow] -> Name -> Name) -> Show IEFlow
forall a.
(Int -> a -> Name -> Name)
-> (a -> Name) -> ([a] -> Name -> Name) -> Show a
$cshowsPrec :: Int -> IEFlow -> Name -> Name
showsPrec :: Int -> IEFlow -> Name -> Name
$cshow :: IEFlow -> Name
show :: IEFlow -> Name
$cshowList :: [IEFlow] -> Name -> Name
showList :: [IEFlow] -> Name -> Name
Show, IEFlow -> IEFlow -> Bool
(IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool) -> Eq IEFlow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IEFlow -> IEFlow -> Bool
== :: IEFlow -> IEFlow -> Bool
$c/= :: IEFlow -> IEFlow -> Bool
/= :: IEFlow -> IEFlow -> Bool
Eq, Eq IEFlow
Eq IEFlow =>
(IEFlow -> IEFlow -> Ordering)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> Bool)
-> (IEFlow -> IEFlow -> IEFlow)
-> (IEFlow -> IEFlow -> IEFlow)
-> Ord IEFlow
IEFlow -> IEFlow -> Bool
IEFlow -> IEFlow -> Ordering
IEFlow -> IEFlow -> IEFlow
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IEFlow -> IEFlow -> Ordering
compare :: IEFlow -> IEFlow -> Ordering
$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
>= :: IEFlow -> IEFlow -> Bool
$cmax :: IEFlow -> IEFlow -> IEFlow
max :: IEFlow -> IEFlow -> IEFlow
$cmin :: IEFlow -> IEFlow -> IEFlow
min :: IEFlow -> IEFlow -> IEFlow
Ord, Typeable, (forall x. IEFlow -> Rep IEFlow x)
-> (forall x. Rep IEFlow x -> IEFlow) -> Generic IEFlow
forall x. Rep IEFlow x -> IEFlow
forall x. IEFlow -> Rep IEFlow x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IEFlow -> Rep IEFlow x
from :: forall x. IEFlow -> Rep IEFlow x
$cto :: forall x. Rep IEFlow x -> IEFlow
to :: forall x. Rep IEFlow x -> IEFlow
Generic, Typeable IEFlow
Typeable IEFlow =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> IEFlow -> c IEFlow)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c IEFlow)
-> (IEFlow -> Constr)
-> (IEFlow -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c IEFlow))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c IEFlow))
-> ((forall b. Data b => b -> b) -> IEFlow -> IEFlow)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> IEFlow -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> IEFlow -> r)
-> (forall u. (forall d. Data d => d -> u) -> IEFlow -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> IEFlow -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> IEFlow -> m IEFlow)
-> Data IEFlow
IEFlow -> Constr
IEFlow -> DataType
(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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> IEFlow -> c IEFlow
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> IEFlow -> c IEFlow
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c IEFlow
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c IEFlow
$ctoConstr :: IEFlow -> Constr
toConstr :: IEFlow -> Constr
$cdataTypeOf :: IEFlow -> DataType
dataTypeOf :: IEFlow -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c IEFlow)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c IEFlow)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c IEFlow)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c IEFlow)
$cgmapT :: (forall b. Data b => b -> b) -> IEFlow -> IEFlow
gmapT :: (forall b. Data b => b -> b) -> IEFlow -> IEFlow
$cgmapQl :: 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
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> IEFlow -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> IEFlow -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> IEFlow -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> IEFlow -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> IEFlow -> u
$cgmapM :: forall (m :: * -> *).
Monad 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
$cgmapMp :: 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
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> IEFlow -> m IEFlow
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> IEFlow -> m 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 = M.insert v ie (ieFlowVars flow) }

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

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

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

-- | For every expression in a loop, try to derive its relationship to
-- a basic induction variable.
genDerivedInductionMap :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> DerivedInductionMap
genDerivedInductionMap :: forall a.
Data a =>
IDomMap -> BBGr (Analysis a) -> DerivedInductionMap
genDerivedInductionMap IDomMap
bedges BBGr (Analysis a)
gr = IEFlow -> DerivedInductionMap
ieFlowExprs (IEFlow -> DerivedInductionMap)
-> (InOutMap IEFlow -> IEFlow)
-> InOutMap IEFlow
-> DerivedInductionMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IEFlow] -> IEFlow
joinIEFlows ([IEFlow] -> IEFlow)
-> (InOutMap IEFlow -> [IEFlow]) -> InOutMap IEFlow -> IEFlow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IEFlow, IEFlow) -> IEFlow) -> [(IEFlow, IEFlow)] -> [IEFlow]
forall a b. (a -> b) -> [a] -> [b]
map (IEFlow, IEFlow) -> IEFlow
forall a b. (a, b) -> b
snd ([(IEFlow, IEFlow)] -> [IEFlow])
-> (InOutMap IEFlow -> [(IEFlow, IEFlow)])
-> InOutMap IEFlow
-> [IEFlow]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InOutMap IEFlow -> [(IEFlow, IEFlow)]
forall a. IntMap a -> [a]
IMS.elems (InOutMap IEFlow -> [(IEFlow, IEFlow)])
-> (InOutMap IEFlow -> InOutMap IEFlow)
-> InOutMap IEFlow
-> [(IEFlow, IEFlow)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> (IEFlow, IEFlow) -> Bool)
-> InOutMap IEFlow -> InOutMap IEFlow
forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IMS.filterWithKey Int -> (IEFlow, IEFlow) -> Bool
inLoop (InOutMap IEFlow -> DerivedInductionMap)
-> InOutMap IEFlow -> DerivedInductionMap
forall a b. (a -> b) -> a -> b
$ InOutMap IEFlow
inOutMaps
  where
    bivMap :: InductionVarMap
bivMap = IDomMap -> BBGr (Analysis a) -> InductionVarMap
forall a. Data a => IDomMap -> BBGr (Analysis a) -> InductionVarMap
basicInductionVars IDomMap
bedges BBGr (Analysis a)
gr -- basic indvars indexed by loop header node
    loopNodeSet :: BBNodeSet
loopNodeSet = [BBNodeSet] -> BBNodeSet
forall (f :: * -> *). Foldable f => f BBNodeSet -> BBNodeSet
IS.unions (IDomMap -> Gr (BB (Analysis a)) () -> [BBNodeSet]
forall (gr :: * -> * -> *) a b.
Graph gr =>
IDomMap -> gr a b -> [BBNodeSet]
loopNodes IDomMap
bedges (Gr (BB (Analysis a)) () -> [BBNodeSet])
-> Gr (BB (Analysis a)) () -> [BBNodeSet]
forall a b. (a -> b) -> a -> b
$ BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) -- set of nodes within a loop
    inLoop :: 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
_ <- Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Expression (Analysis a) -> Analysis a
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
rhs), IEFlow
flow'' <- Name -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertVar (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
lv) (IEFlow -> Expression (Analysis a) -> InductionExpr
forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExprMemo IEFlow
flow' Expression (Analysis a)
rhs) IEFlow
flow'
        -> IEFlow -> Expression (Analysis a) -> IEFlow
stepExpr IEFlow
flow'' Expression (Analysis a)
lv
      Block (Analysis a)
_ -> IEFlow
flow'
      where
        -- flow' = foldl' stepExpr flow (universeBi b)
        flow' :: IEFlow
flow' = State IEFlow (Block (Analysis a)) -> IEFlow -> IEFlow
forall s a. State s a -> s -> s
execState ((Expression (Analysis a) -> State IEFlow (Expression (Analysis a)))
-> Block (Analysis a) -> State IEFlow (Block (Analysis a))
trans (\ Expression (Analysis a)
e -> Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e State IEFlow InductionExpr
-> State IEFlow (Expression (Analysis a))
-> State IEFlow (Expression (Analysis a))
forall a b.
StateT IEFlow Identity a
-> StateT IEFlow Identity b -> StateT IEFlow Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expression (Analysis a) -> State IEFlow (Expression (Analysis a))
forall a. a -> StateT IEFlow Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression (Analysis a)
e) Block (Analysis a)
b) IEFlow
flow -- monadic version
        trans :: (Expression (Analysis a) -> State IEFlow (Expression (Analysis a)))
-> Block (Analysis a) -> State IEFlow (Block (Analysis a))
trans = (Expression (Analysis a) -> State IEFlow (Expression (Analysis a)))
-> Block (Analysis a) -> State IEFlow (Block (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM :: (Expression (Analysis a) -> State IEFlow (Expression (Analysis a))) -> Block (Analysis a) -> State IEFlow (Block (Analysis a))


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

    out :: InF IEFlow -> OutF IEFlow
    out :: InF IEFlow -> InF IEFlow
out InF IEFlow
inF Int
node = IEFlow
flow'
      where
        flow :: IEFlow
flow = [IEFlow] -> IEFlow
joinIEFlows [(IEFlow, IEFlow) -> IEFlow
forall a b. (a, b) -> a
fst (Int -> (IEFlow, IEFlow)
initF Int
node), InF IEFlow
inF Int
node]
        flow' :: IEFlow
flow' = (IEFlow -> Block (Analysis a) -> IEFlow)
-> IEFlow -> BB (Analysis a) -> IEFlow
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IEFlow -> Block (Analysis a) -> IEFlow
step IEFlow
flow (Name -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. Name -> Maybe a -> a
fromJustMsg (Name
"analyseDerivedIE out(" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show Int
node Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
")") (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Int -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
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 <- Gr (BB (Analysis a)) () -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
pre (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
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 Int -> InductionVarMap -> Maybe (Set Name)
forall a. Int -> IntMap a -> Maybe a
IMS.lookup Int
node InductionVarMap
bivMap of
                   Just Set Name
set -> (Map Name InductionExpr -> DerivedInductionMap -> IEFlow
IEFlow ([(Name, InductionExpr)] -> Map Name InductionExpr
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 <- Set Name -> [Name]
forall a. Set a -> [a]
S.toList Set Name
set ]) DerivedInductionMap
forall a. IntMap a
IMS.empty, IEFlow
emptyIEFlow)
                   Maybe (Set Name)
Nothing  -> (IEFlow
emptyIEFlow, IEFlow
emptyIEFlow)

    inOutMaps :: InOutMap IEFlow
inOutMaps = BBGr (Analysis a)
-> (Int -> (IEFlow, IEFlow))
-> OrderF (Analysis a)
-> (InF IEFlow -> InF IEFlow)
-> (InF IEFlow -> InF IEFlow)
-> InOutMap IEFlow
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 OrderF (Analysis a)
forall a. OrderF a
revPostOrder InF IEFlow -> InF IEFlow
inn InF IEFlow -> InF IEFlow
out

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

-- Compute the relationship between the given expression and a basic
-- induction variable, if possible.
derivedInductionExpr :: Data a => IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr :: 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
_))   -> InductionExpr -> Maybe InductionExpr -> InductionExpr
forall a. a -> Maybe a -> a
fromMaybe InductionExpr
IETop (Maybe InductionExpr -> InductionExpr)
-> Maybe InductionExpr -> InductionExpr
forall a b. (a -> b) -> a -> b
$ Name -> Map Name InductionExpr -> Maybe InductionExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> Name
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 (Int -> InductionExpr) -> Int -> InductionExpr
forall a b. (a -> b) -> a -> b
$ Name -> Int
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 = IEFlow -> Expression (Analysis a) -> InductionExpr
forall a.
Data a =>
IEFlow -> Expression (Analysis a) -> InductionExpr
derivedInductionExpr IEFlow
flow

-- Monadic version using State.
derivedInductionExprM :: Data a => Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM :: forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e = do
  IEFlow
flow <- StateT IEFlow Identity IEFlow
forall s (m :: * -> *). MonadState s m => m s
get
  let derive :: Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e' | Just Int
label <- Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Expression (Analysis a) -> Analysis a
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e')
                , Just InductionExpr
iexpr <- Int -> DerivedInductionMap -> Maybe InductionExpr
forall a. Int -> IntMap a -> Maybe a
IMS.lookup Int
label (IEFlow -> DerivedInductionMap
ieFlowExprs IEFlow
flow) = InductionExpr -> State IEFlow InductionExpr
forall a. a -> StateT IEFlow Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InductionExpr
iexpr
                | Bool
otherwise = Expression (Analysis a) -> State IEFlow InductionExpr
forall a.
Data a =>
Expression (Analysis a) -> State IEFlow InductionExpr
derivedInductionExprM Expression (Analysis a)
e'
  InductionExpr
ie <- case Expression (Analysis a)
e of
        v :: Expression (Analysis a)
v@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_))   -> InductionExpr -> State IEFlow InductionExpr
forall a. a -> StateT IEFlow Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InductionExpr -> State IEFlow InductionExpr)
-> (Maybe InductionExpr -> InductionExpr)
-> Maybe InductionExpr
-> State IEFlow InductionExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InductionExpr -> Maybe InductionExpr -> InductionExpr
forall a. a -> Maybe a -> a
fromMaybe InductionExpr
IETop (Maybe InductionExpr -> State IEFlow InductionExpr)
-> Maybe InductionExpr -> State IEFlow InductionExpr
forall a b. (a -> b) -> a -> b
$ Name -> Map Name InductionExpr -> Maybe InductionExpr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> Name
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))
_) -> InductionExpr -> State IEFlow InductionExpr
forall a. a -> StateT IEFlow Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InductionExpr -> State IEFlow InductionExpr)
-> InductionExpr -> State IEFlow InductionExpr
forall a b. (a -> b) -> a -> b
$ Name -> Int -> Int -> InductionExpr
IELinear Name
"" Int
0 (Int -> InductionExpr) -> Int -> InductionExpr
forall a b. (a -> b) -> a -> b
$ Name -> Int
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 (InductionExpr -> InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr
-> StateT IEFlow Identity (InductionExpr -> InductionExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 StateT IEFlow Identity (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall a b.
StateT IEFlow Identity (a -> b)
-> StateT IEFlow Identity a -> StateT IEFlow Identity b
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 (InductionExpr -> InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr
-> StateT IEFlow Identity (InductionExpr -> InductionExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 StateT IEFlow Identity (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall a b.
StateT IEFlow Identity (a -> b)
-> StateT IEFlow Identity a -> StateT IEFlow Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (InductionExpr -> InductionExpr
negInductionExpr (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e2)
        ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
Multiplication Expression (Analysis a)
e1 Expression (Analysis a)
e2 -> InductionExpr -> InductionExpr -> InductionExpr
mulInductionExprs (InductionExpr -> InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr
-> StateT IEFlow Identity (InductionExpr -> InductionExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Analysis a) -> State IEFlow InductionExpr
derive Expression (Analysis a)
e1 StateT IEFlow Identity (InductionExpr -> InductionExpr)
-> State IEFlow InductionExpr -> State IEFlow InductionExpr
forall a b.
StateT IEFlow Identity (a -> b)
-> StateT IEFlow Identity a -> StateT IEFlow Identity b
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)
_                                  -> InductionExpr -> State IEFlow InductionExpr
forall a. a -> StateT IEFlow Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InductionExpr -> State IEFlow InductionExpr)
-> InductionExpr -> State IEFlow InductionExpr
forall a b. (a -> b) -> a -> b
$ InductionExpr
IETop -- unsure
  let Just Int
label = Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Expression (Analysis a) -> Analysis a
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)
  IEFlow -> StateT IEFlow Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (IEFlow -> StateT IEFlow Identity ())
-> IEFlow -> StateT IEFlow Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> InductionExpr -> IEFlow -> IEFlow
ieFlowInsertExpr Int
label InductionExpr
ie IEFlow
flow
  InductionExpr -> State IEFlow InductionExpr
forall a. a -> StateT IEFlow Identity a
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
rn                = Name -> Int -> Int -> InductionExpr
IELinear Name
ln (Int
lc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rc) (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ro)
  | Int
lc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0                 = Name -> Int -> Int -> InductionExpr
IELinear Name
rn Int
rc (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ro)
  | Int
rc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0                 = Name -> Int -> Int -> InductionExpr
IELinear Name
ln Int
lc (Int
lo Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
lo) (Int
ro Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ro) (Int
lo Int -> Int -> Int
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 InductionExpr -> InductionExpr -> Bool
forall a. Eq a => a -> a -> Bool
== InductionExpr
ie2               = InductionExpr
ie1
  | Bool
otherwise                = InductionExpr
IEBottom -- too difficult to combine

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

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

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

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

-- | Outputs a DOT-formatted graph showing flow-to data starting at
-- the given AST-Block node in the given Basic Block graph.
showFlowsDOT :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> BBGr (Analysis a) -> ASTBlockNode -> Bool -> String
showFlowsDOT :: 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 = Writer Name () -> Name
forall w a. Writer w a -> w
execWriter (Writer Name () -> Name) -> Writer Name () -> Name
forall a b. (a -> b) -> a -> b
$ do
  let bm :: BlockMap a
bm = ProgramFile (Analysis a) -> BlockMap a
forall a. Data a => ProgramFile (Analysis a) -> BlockMap a
genBlockMap ProgramFile (Analysis a)
pf
      dm :: DefMap
dm = BlockMap a -> DefMap
forall a. Data a => BlockMap a -> DefMap
genDefMap BlockMap a
bm
      flowsTo :: FlowsGraph a
flowsTo = BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (BBNodeSet, BBNodeSet)
-> FlowsGraph a
forall a.
Data a =>
BlockMap a
-> DefMap
-> BBGr (Analysis a)
-> IntMap (BBNodeSet, BBNodeSet)
-> FlowsGraph a
genFlowsToGraph BlockMap a
bm DefMap
dm BBGr (Analysis a)
bbgr (DefMap -> BBGr (Analysis a) -> IntMap (BBNodeSet, BBNodeSet)
forall a.
Data a =>
DefMap -> BBGr (Analysis a) -> IntMap (BBNodeSet, BBNodeSet)
reachingDefinitions DefMap
dm BBGr (Analysis a)
bbgr)
      flows :: FlowsGraph a
flows | Bool
isFrom    = FlowsGraph a -> FlowsGraph a
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
grev FlowsGraph a
flowsTo
            | Bool
otherwise = FlowsGraph a
flowsTo
  Name -> Writer Name ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Name
"strict digraph {\n"
  [Int] -> (Int -> Writer Name ()) -> Writer Name ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> FlowsGraph a -> [Int]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[Int] -> gr a b -> [Int]
bfsn [Int
astBlockId] FlowsGraph a
flows) ((Int -> Writer Name ()) -> Writer Name ())
-> (Int -> Writer Name ()) -> Writer Name ()
forall a b. (a -> b) -> a -> b
$ \ Int
n -> do
    let pseudocode :: Name
pseudocode = Name
-> (Block (Analysis a) -> Name)
-> Maybe (Block (Analysis a))
-> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
"<N/A>" Block (Analysis a) -> Name
forall a. Block a -> Name
showBlock (Maybe (Block (Analysis a)) -> Name)
-> Maybe (Block (Analysis a)) -> Name
forall a b. (a -> b) -> a -> b
$ Int -> BlockMap a -> Maybe (Block (Analysis a))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
n BlockMap a
bm
    Name -> Writer Name ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Name
"node [shape=box,fontname=\"Courier New\"]\n"
    Name -> Writer Name ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Name -> Writer Name ()) -> Name -> Writer Name ()
forall a b. (a -> b) -> a -> b
$ Name
"Bl" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show Int
n Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"[label=\"B" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show Int
n Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\\l" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
pseudocode Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\"]\n"
    Name -> Writer Name ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Name -> Writer Name ()) -> Name -> Writer Name ()
forall a b. (a -> b) -> a -> b
$ Name
"Bl" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show Int
n Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" -> {"
    [Int] -> (Int -> Writer Name ()) -> Writer Name ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (FlowsGraph a -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
suc FlowsGraph a
flows Int
n) ((Int -> Writer Name ()) -> Writer Name ())
-> (Int -> Writer Name ()) -> Writer Name ()
forall a b. (a -> b) -> a -> b
$ \ Int
m -> Name -> Writer Name ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Name
" Bl" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show Int
m)
    Name -> Writer Name ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Name
"}\n"
  Name -> Writer Name ()
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 = (State CallMap () -> CallMap -> CallMap)
-> CallMap -> State CallMap () -> CallMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip State CallMap () -> CallMap -> CallMap
forall s a. State s a -> s -> s
Lazy.execState CallMap
forall k a. Map k a
M.empty (State CallMap () -> CallMap) -> State CallMap () -> CallMap
forall a b. (a -> b) -> a -> b
$ do
  let uP :: ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
uP = ProgramFile a -> [ProgramUnit a]
forall {a}. Data a => ProgramFile a -> [ProgramUnit a]
forall from to. Biplate from to => from -> [to]
universeBi :: Data a => ProgramFile a -> [ProgramUnit a]
  [ProgramUnit (Analysis a)]
-> (ProgramUnit (Analysis a) -> State CallMap ())
-> State CallMap ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
uP ProgramFile (Analysis a)
pf) ((ProgramUnit (Analysis a) -> State CallMap ())
 -> State CallMap ())
-> (ProgramUnit (Analysis a) -> State CallMap ())
-> State CallMap ()
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit (Analysis a)
pu -> do
    let n :: ProgramUnitName
n = ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu
    let uS :: Data a => ProgramUnit a -> [Statement a]
        uS :: forall a. Data a => ProgramUnit a -> [Statement a]
uS = ProgramUnit a -> [Statement a]
forall from to. Biplate from to => from -> [to]
universeBi
    let uE :: Data a => ProgramUnit a -> [Expression a]
        uE :: forall a. Data a => ProgramUnit a -> [Expression a]
uE = ProgramUnit a -> [Expression a]
forall from to. Biplate from to => from -> [to]
universeBi
    CallMap
m <- StateT CallMap Identity CallMap
forall s (m :: * -> *). MonadState s m => m s
get
    let ns :: [Name]
ns = [ Expression (Analysis a) -> Name
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)
_          <- ProgramUnit (Analysis a) -> [Statement (Analysis a)]
forall a. Data a => ProgramUnit a -> [Statement a]
uS ProgramUnit (Analysis a)
pu ] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
             [ Expression (Analysis a) -> Name
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)
_ <- ProgramUnit (Analysis a) -> [Expression (Analysis a)]
forall a. Data a => ProgramUnit a -> [Expression a]
uE ProgramUnit (Analysis a)
pu ]
    CallMap -> State CallMap ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (CallMap -> State CallMap ()) -> CallMap -> State CallMap ()
forall a b. (a -> b) -> a -> b
$ ProgramUnitName -> Set Name -> CallMap -> CallMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ProgramUnitName
n ([Name] -> Set Name
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 = (a -> a -> Bool) -> [a] -> a
forall a. (a -> a -> Bool) -> [a] -> a
converge a -> a -> Bool
p [a]
ys
converge a -> a -> Bool
_ [] = Name -> a
forall a. HasCallStack => Name -> a
error Name
"converge: empty list"
converge a -> a -> Bool
_ [a
_] = Name -> 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
_      = Name -> a
forall a. HasCallStack => Name -> a
error Name
msg

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