-- | Analyse a program file and create basic blocks.

module Language.Fortran.Analysis.BBlocks
  ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap, ASTBlockNode, ASTExprNode
  , genSuperBBGr, SuperBBGr(..), showSuperBBGr, superBBGrToDOT, findLabeledBBlock, showBlock )
where

import Prelude hiding (exp)
import Data.Generics.Uniplate.Data hiding (transform)
import Data.Char (toLower)
import Data.Data
import Data.List (unfoldr, foldl')
import Control.Monad
import Control.Monad.State.Lazy hiding (fix)
import Control.Monad.Writer hiding (fix)
import Text.PrettyPrint.GenericPretty (pretty, Out)
import Text.PrettyPrint               (render)
import Language.Fortran.Analysis
import Language.Fortran.AST hiding (setName)
import Language.Fortran.AST.Literal.Real
import Language.Fortran.Util.Position
import Language.Fortran.PrettyPrint
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Data.Graph.Inductive
import Data.List (intercalate)
import Data.Maybe
import Data.Functor.Identity
import qualified Data.List.NonEmpty as NE

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

-- | Insert basic block graphs into each program unit's analysis
analyseBBlocks :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks :: forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks ProgramFile (Analysis a)
pf = forall s a. State s a -> s -> a
evalState (ProgramFile (Analysis a)
-> StateT ASTExprNode Identity (ProgramFile (Analysis a))
analyse (forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseAllLhsVars ProgramFile (Analysis a)
pf)) ASTExprNode
1
  where
    analyse :: ProgramFile (Analysis a)
-> StateT ASTExprNode Identity (ProgramFile (Analysis a))
analyse = forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocksInBBGr forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => TransFunc ProgramUnit ProgramFile a
trans forall a.
Data a =>
ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprs forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocks
    trans :: Data a => TransFunc ProgramUnit ProgramFile a
    trans :: forall a. Data a => TransFunc ProgramUnit ProgramFile a
trans = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi

-- | A mapping of program unit names to bblock graphs.
type BBlockMap a = M.Map ProgramUnitName (BBGr a)

-- | Create a mapping of (non-module) program unit names to their
-- associated bblock graph.
genBBlockMap :: Data a => ProgramFile (Analysis a) -> BBlockMap (Analysis a)
genBBlockMap :: forall a.
Data a =>
ProgramFile (Analysis a) -> BBlockMap (Analysis a)
genBBlockMap ProgramFile (Analysis a)
pf = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
    (forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu, BBGr (Analysis a)
gr) | ProgramUnit (Analysis a)
pu <- forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs ProgramFile (Analysis a)
pf, Just BBGr (Analysis a)
gr <- [forall a. Analysis a -> Maybe (BBGr (Analysis a))
bBlocks (forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu)]
  ]
  where
    getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    getPUs :: forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs = forall from to. Biplate from to => from -> [to]
universeBi

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

type ASTBlockNode = Int

-- Insert unique labels on each AST-block for easier look-up later.
labelBlocks :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a))
labelBlocks :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocks = forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Block ProgramFile a
transform forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock
  where
    eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a))
    eachBlock :: forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock Block (Analysis a)
b = do
      ASTExprNode
n <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode
n forall a. Num a => a -> a -> a
+ ASTExprNode
1)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) { insLabel :: Maybe ASTExprNode
insLabel = forall a. a -> Maybe a
Just ASTExprNode
n }) Block (Analysis a)
b
    transform :: Data a => TransFuncM (State ASTBlockNode) Block ProgramFile a
    transform :: forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Block ProgramFile a
transform = forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

-- A version of labelBlocks that works on all AST-blocks inside of a
-- basic-block graph that have not already been labelled with
-- numbers. The reason that this function must exist is because
-- additional AST-blocks are generated within the process of creating
-- basic-block graphs, and must also be labelled.
labelBlocksInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a))
labelBlocksInBBGr :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocksInBBGr = forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transform (forall (m :: * -> *) a1 a2.
Monad m =>
(Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2)
bbgrMapM (forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock)))
  where
    eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a))
    eachBlock :: forall a.
Data a =>
Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock Block (Analysis a)
b
      | a :: Analysis a
a@Analysis { insLabel :: forall a. Analysis a -> Maybe ASTExprNode
insLabel = Maybe ASTExprNode
Nothing } <- forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b = do
          ASTExprNode
n <- forall s (m :: * -> *). MonadState s m => m s
get
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ASTExprNode
n forall a. Num a => a -> a -> a
+ ASTExprNode
1
          forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { insLabel :: Maybe ASTExprNode
insLabel = forall a. a -> Maybe a
Just ASTExprNode
n }) Block (Analysis a)
b
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
b
    transform :: Data a => (BBGr a -> State ASTBlockNode (BBGr a)) ->
                           ProgramFile a -> State ASTBlockNode (ProgramFile a)
    transform :: forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transform = forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

-- Sets the label on each Index within a Block to match the Block, for
-- later look-up.
labelWithinBlocks :: forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks :: forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks = Block (Analysis a) -> Block (Analysis a)
perBlock'
  where
    perBlock' :: Block (Analysis a) -> Block (Analysis a)
    perBlock' :: Block (Analysis a) -> Block (Analysis a)
perBlock' Block (Analysis a)
b =
      case Block (Analysis a)
b of
        BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e Statement (Analysis a)
st               -> forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a SrcSpan
s (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e) (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Statement (Analysis a)
st)
        BlIf        Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
mn NonEmpty (Expression (Analysis a), [Block (Analysis a)])
bs Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el  ->
          forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> NonEmpty (Expression a, [Block a])
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlIf      Analysis a
a SrcSpan
s (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ASTExprNode
-> (Expression (Analysis a), [Block (Analysis a)])
-> (Expression (Analysis a), [Block (Analysis a)])
fillIf Maybe ASTExprNode
i) NonEmpty (Expression (Analysis a), [Block (Analysis a)])
bs) Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el
        BlCase      Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
mn Expression (Analysis a)
e2 [(AList Index (Analysis a), [Block (Analysis a)])]
bs Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el ->
          forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [(AList Index a, [Block a])]
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlCase    Analysis a
a SrcSpan
s (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Expression (Analysis a)
e2) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ASTExprNode
-> (AList Index (Analysis a), [Block (Analysis a)])
-> (AList Index (Analysis a), [Block (Analysis a)])
fillCaseClause Maybe ASTExprNode
i) [(AList Index (Analysis a), [Block (Analysis a)])]
bs) Maybe [Block (Analysis a)]
mb Maybe (Expression (Analysis a))
el
        BlDo        Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
mn Maybe (Expression (Analysis a))
tl Maybe (DoSpecification (Analysis a))
e2 [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el  -> forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDo        Analysis a
a SrcSpan
s (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn Maybe (Expression (Analysis a))
tl (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (DoSpecification (Analysis a))
e2) [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el
        BlDoWhile   Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
n Maybe (Expression (Analysis a))
tl Expression (Analysis a)
e2 [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el   -> forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDoWhile   Analysis a
a SrcSpan
s (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
n Maybe (Expression (Analysis a))
tl (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Expression (Analysis a)
e2) [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
el
        Block (Analysis a)
_                             -> Block (Analysis a)
b
      where i :: Maybe ASTExprNode
i = forall a. Analysis a -> Maybe ASTExprNode
insLabel forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b

    mfill
        :: forall f. (Data (f (Analysis a)))
        => Maybe ASTBlockNode -> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
    mfill :: forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode
-> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))
mfill Maybe ASTExprNode
i  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i)

    fillCaseClause :: Maybe ASTExprNode
-> (AList Index (Analysis a), [Block (Analysis a)])
-> (AList Index (Analysis a), [Block (Analysis a)])
fillCaseClause Maybe ASTExprNode
i (AList Index (Analysis a)
rs, [Block (Analysis a)]
b) = (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i AList Index (Analysis a)
rs, [Block (Analysis a)]
b)
    fillIf :: Maybe ASTExprNode
-> (Expression (Analysis a), [Block (Analysis a)])
-> (Expression (Analysis a), [Block (Analysis a)])
fillIf Maybe ASTExprNode
i (Expression (Analysis a)
e, [Block (Analysis a)]
b) = (forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Expression (Analysis a)
e, [Block (Analysis a)]
b)

    fill
        :: forall f. (Data (f (Analysis a)))
        => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a)
    fill :: forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
Nothing  = forall a. a -> a
id
    fill (Just ASTExprNode
i) = (Index (Analysis a) -> Index (Analysis a))
-> f (Analysis a) -> f (Analysis a)
transform Index (Analysis a) -> Index (Analysis a)
perIndex
      where
        transform :: (Index (Analysis a) -> Index (Analysis a)) -> f (Analysis a) -> f (Analysis a)
        transform :: (Index (Analysis a) -> Index (Analysis a))
-> f (Analysis a) -> f (Analysis a)
transform = forall from to. Biplate from to => (to -> to) -> from -> from
transformBi

        perIndex :: (Index (Analysis a) -> Index (Analysis a))
        perIndex :: Index (Analysis a) -> Index (Analysis a)
perIndex Index (Analysis a)
x = forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Index (Analysis a)
x) { insLabel :: Maybe ASTExprNode
insLabel = forall a. a -> Maybe a
Just ASTExprNode
i }) Index (Analysis a)
x

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

type ASTExprNode = Int

-- Insert unique labels on each expression for easier look-up later.
labelExprs :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a))
labelExprs :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprs = forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Expression ProgramFile a
transform forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr
  where
    eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))
    eachExpr :: forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr Expression (Analysis a)
e = do
      ASTExprNode
n <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode
n forall a. Num a => a -> a -> a
+ ASTExprNode
1)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e) { insLabel :: Maybe ASTExprNode
insLabel = forall a. a -> Maybe a
Just ASTExprNode
n }) Expression (Analysis a)
e
    transform :: Data a => TransFuncM (State ASTExprNode) Expression ProgramFile a
    transform :: forall a.
Data a =>
TransFuncM (StateT ASTExprNode Identity) Expression ProgramFile a
transform = forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

-- A version of labelExprs that works on all expressions inside of a
-- basic-block graph that have not already been labelled with
-- numbers. The reason that this function must exist is because
-- additional expressions are generated within the process of creating
-- basic-block graphs, and must also be labelled.
labelExprsInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr :: forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr = forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transformBB (forall (m :: * -> *) a1 a2.
Monad m =>
(Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2)
bbgrMapM (forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' (forall a.
Data a =>
(Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
transformExpr forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr)))
  where
    eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))
    eachExpr :: forall a.
Data a =>
Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr Expression (Analysis a)
e
      | a :: Analysis a
a@Analysis { insLabel :: forall a. Analysis a -> Maybe ASTExprNode
insLabel = Maybe ASTExprNode
Nothing } <- forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e = do
          ASTExprNode
n <- forall s (m :: * -> *). MonadState s m => m s
get
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ ASTExprNode
n forall a. Num a => a -> a -> a
+ ASTExprNode
1
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { insLabel :: Maybe ASTExprNode
insLabel = forall a. a -> Maybe a
Just ASTExprNode
n }) Expression (Analysis a)
e
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
e
    transformBB :: Data a => (BBGr a -> State ASTExprNode (BBGr a)) ->
                             ProgramFile a -> State ASTExprNode (ProgramFile a)
    transformBB :: forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transformBB = forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM
    transformExpr :: Data a => (Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))) ->
                               [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
    transformExpr :: forall a.
Data a =>
(Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
transformExpr = forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM

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

-- Analyse each program unit
toBBlocksPerPU :: Data a => ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU :: forall a.
Data a =>
ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU ProgramUnit (Analysis a)
pu
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block (Analysis a)]
bs   = ProgramUnit (Analysis a)
pu
  | Bool
otherwise = ProgramUnit (Analysis a)
pu'
  where
    bs :: [Block (Analysis a)]
bs  =
      case ProgramUnit (Analysis a)
pu of
        PUMain Analysis a
_ SrcSpan
_ Maybe String
_ [Block (Analysis a)]
bs' Maybe [ProgramUnit (Analysis a)]
_ -> [Block (Analysis a)]
bs';
        PUSubroutine Analysis a
_ SrcSpan
_ PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
_ [Block (Analysis a)]
bs' Maybe [ProgramUnit (Analysis a)]
_ -> [Block (Analysis a)]
bs';
        PUFunction Analysis a
_ SrcSpan
_ Maybe (TypeSpec (Analysis a))
_ PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
bs' Maybe [ProgramUnit (Analysis a)]
_ -> [Block (Analysis a)]
bs'
        ProgramUnit (Analysis a)
_ -> []
    bbs :: BBState (Analysis a)
bbs = forall a b. BBlocker a b -> BBState a
execBBlocker (forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs)
    fix :: Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
fix = forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
delUnreachable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> Map String ASTExprNode
-> gr [Block (Analysis a)] ()
-> gr [Block (Analysis a)] ()
insExitEdges ProgramUnit (Analysis a)
pu Map String ASTExprNode
lm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b.
DynGraph gr =>
gr [Block a] b -> gr [Block a] b
delInvalidExits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insEntryEdges ProgramUnit (Analysis a)
pu
    gr :: BBGr (Analysis a)
gr  = forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
fix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges (forall a. BBState a -> [LEdge ()]
newEdges BBState (Analysis a)
bbs)) forall a b. (a -> b) -> a -> b
$ forall a. BBState a -> BBGr a
bbGraph BBState (Analysis a)
bbs
    gr' :: BBGr (Analysis a)
gr' = BBGr (Analysis a)
gr { bbgrEntries :: [ASTExprNode]
bbgrEntries = [ASTExprNode
0], bbgrExits :: [ASTExprNode]
bbgrExits = [-ASTExprNode
1] } -- conventional entry/exit blocks
    pu' :: ProgramUnit (Analysis a)
pu' = forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu) { bBlocks :: Maybe (BBGr (Analysis a))
bBlocks = forall a. a -> Maybe a
Just BBGr (Analysis a)
gr' }) ProgramUnit (Analysis a)
pu
    lm :: Map String ASTExprNode
lm  = forall a. BBState a -> Map String ASTExprNode
labelMap BBState (Analysis a)
bbs

-- Create node 0 "the start node" and link it
-- for now assume only one entry
insEntryEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insEntryEdges :: forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insEntryEdges ProgramUnit (Analysis a)
pu = forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge (ASTExprNode
0, ASTExprNode
1, ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
0, [Block (Analysis a)]
bs)
  where
    bs :: [Block (Analysis a)]
bs = forall a.
Data a =>
ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments ProgramUnit (Analysis a)
pu Bool
False

-- create assignments of the form "x = f[1]" or "f[1] = x" at the
-- entry/exit bblocks.
genInOutAssignments :: Data a => ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments :: forall a.
Data a =>
ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments ProgramUnit (Analysis a)
pu Bool
exit
  | Bool
exit, PUFunction{} <- ProgramUnit (Analysis a)
pu = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Block (Analysis a)
genAssign (forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
noSrcSpan String
fnforall a. a -> [a] -> [a]
:[Expression (Analysis a)]
vs) [(Integer
0::Integer)..]
  | Bool
otherwise                = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Block (Analysis a)
genAssign [Expression (Analysis a)]
vs [(Integer
1::Integer)..]
  where
    Named String
fn      = forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu
    name :: Integer -> String
name Integer
i        = String
fn forall a. [a] -> [a] -> [a]
++ String
"[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i forall a. [a] -> [a] -> [a]
++ String
"]"
    a0 :: Analysis a
a0            = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis [forall a. Analysis a -> a
prevAnnotation Analysis a
a]
    (Analysis a
a, SrcSpan
s, [Expression (Analysis a)]
vs)    = case ProgramUnit (Analysis a)
pu of
      PUFunction Analysis a
_ SrcSpan
_ Maybe (TypeSpec (Analysis a))
_ PrefixSuffix (Analysis a)
_ String
_ (Just (AList Analysis a
a' SrcSpan
s' [Expression (Analysis a)]
vs')) Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_ -> (Analysis a
a', SrcSpan
s', [Expression (Analysis a)]
vs')
      PUSubroutine Analysis a
_ SrcSpan
_ PrefixSuffix (Analysis a)
_ String
_ (Just (AList Analysis a
a' SrcSpan
s' [Expression (Analysis a)]
vs')) [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_   -> (Analysis a
a', SrcSpan
s', [Expression (Analysis a)]
vs')
      PUFunction Analysis a
a' SrcSpan
s' Maybe (TypeSpec (Analysis a))
_ PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
Nothing Maybe (Expression (Analysis a))
_ [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_               -> (Analysis a
a', SrcSpan
s', [])
      PUSubroutine Analysis a
a' SrcSpan
s' PrefixSuffix (Analysis a)
_ String
_ Maybe (AList Expression (Analysis a))
Nothing [Block (Analysis a)]
_ Maybe [ProgramUnit (Analysis a)]
_                 -> (Analysis a
a', SrcSpan
s', [])
      ProgramUnit (Analysis a)
_                                                -> (forall a. HasCallStack => String -> a
error String
"genInOutAssignments", forall a. HasCallStack => String -> a
error String
"genInOutAssignments", [])
    genAssign :: Expression (Analysis a) -> Integer -> Block (Analysis a)
genAssign Expression (Analysis a)
v Integer
i = forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$ forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s forall a. Maybe a
Nothing (forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a0 SrcSpan
s Expression (Analysis a)
vl Expression (Analysis a)
vr)
      where
        (Expression (Analysis a)
vl, Expression (Analysis a)
vr) = if Bool
exit then (Expression (Analysis a)
v', Expression (Analysis a)
v) else (Expression (Analysis a)
v, Expression (Analysis a)
v')
        v' :: Expression (Analysis a)
v'       = case Expression (Analysis a)
v of
          ExpValue Analysis a
_ SrcSpan
s' (ValVariable String
_) -> forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s' (Integer -> String
name Integer
i)
          Expression (Analysis a)
_               -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unhandled genAssign case: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a b. a -> b -> a
const ()) Expression (Analysis a)
v)

-- Remove exit edges for bblocks where standard construction doesn't apply.
delInvalidExits :: DynGraph gr => gr [Block a] b -> gr [Block a] b
delInvalidExits :: forall (gr :: * -> * -> *) a b.
DynGraph gr =>
gr [Block a] b -> gr [Block a] b
delInvalidExits gr [Block a] b
gr = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[(ASTExprNode, ASTExprNode)] -> gr a b -> gr a b
delEdges gr [Block a] b
gr forall a b. (a -> b) -> a -> b
$ do
  ASTExprNode
n  <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes gr [Block a] b
gr
  [Block a]
bs <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab gr [Block a] b
gr ASTExprNode
n
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. [Block a] -> Bool
isFinalBlockCtrlXfer [Block a]
bs
  LEdge b
le <- forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr [Block a] b
gr ASTExprNode
n
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. LEdge b -> (ASTExprNode, ASTExprNode)
toEdge LEdge b
le

-- Insert exit edges for bblocks with special handling.
insExitEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> M.Map String Node -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insExitEdges :: forall a (gr :: * -> * -> *).
(Data a, DynGraph gr) =>
ProgramUnit (Analysis a)
-> Map String ASTExprNode
-> gr [Block (Analysis a)] ()
-> gr [Block (Analysis a)] ()
insExitEdges ProgramUnit (Analysis a)
pu Map String ASTExprNode
lm gr [Block (Analysis a)] ()
gr = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges (forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (-ASTExprNode
1, [Block (Analysis a)]
bs) gr [Block (Analysis a)] ()
gr) forall a b. (a -> b) -> a -> b
$ do
  ASTExprNode
n <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes gr [Block (Analysis a)] ()
gr
  [Block (Analysis a)]
bs' <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab gr [Block (Analysis a)] ()
gr ASTExprNode
n
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr [Block (Analysis a)] ()
gr ASTExprNode
n) Bool -> Bool -> Bool
|| forall a. [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer [Block (Analysis a)]
bs'
  ASTExprNode
n' <- forall a1 a2. Num a1 => Map String a1 -> [Block a2] -> [a1]
examineFinalBlock Map String ASTExprNode
lm [Block (Analysis a)]
bs'
  forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
n', ())
  where
    bs :: [Block (Analysis a)]
bs = forall a.
Data a =>
ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments ProgramUnit (Analysis a)
pu Bool
True

-- Given a list of ControlPairs for a StRead, return (if any exists)
-- the expression accompanying an END or ERR, respectively
getReadCtrlXfers :: [ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers :: forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}.
(Maybe (Expression a), Maybe (Expression a))
-> ControlPair a -> (Maybe (Expression a), Maybe (Expression a))
handler (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
  where
    handler :: (Maybe (Expression a), Maybe (Expression a))
-> ControlPair a -> (Maybe (Expression a), Maybe (Expression a))
handler r :: (Maybe (Expression a), Maybe (Expression a))
r@(Maybe (Expression a)
r1, Maybe (Expression a)
r2) (ControlPair a
_ SrcSpan
_ Maybe String
ms Expression a
e) = case Maybe String
ms of
      Maybe String
Nothing -> (Maybe (Expression a), Maybe (Expression a))
r
      Just String
s  ->
        case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
          String
"end" -> (forall a. a -> Maybe a
Just Expression a
e, Maybe (Expression a)
r2)
          String
"err" -> (Maybe (Expression a)
r1, forall a. a -> Maybe a
Just Expression a
e)
          String
_     -> (Maybe (Expression a), Maybe (Expression a))
r

-- Find target of Goto statements (Return statements default target to -1).
examineFinalBlock :: Num a1 => M.Map String a1 -> [Block a2] -> [a1]
examineFinalBlock :: forall a1 a2. Num a1 => Map String a1 -> [Block a2] -> [a1]
examineFinalBlock Map String a1
lm bs :: [Block a2]
bs@(Block a2
_:[Block a2]
_)
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StGotoUnconditional a2
_ SrcSpan
_ Expression a2
k) <- forall a. [a] -> a
last [Block a2]
bs = [forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k]
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StGotoAssigned a2
_ SrcSpan
_ Expression a2
_ Maybe (AList Expression a2)
ks)   <- forall a. [a] -> a
last [Block a2]
bs = forall a b. (a -> b) -> [a] -> [b]
map (forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (t :: * -> *) a. AList t a -> [t a]
aStrip Maybe (AList Expression a2)
ks)
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StGotoComputed a2
_ SrcSpan
_ AList Expression a2
ks Expression a2
_)   <- forall a. [a] -> a
last [Block a2]
bs = forall a b. (a -> b) -> [a] -> [b]
map (forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm) (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression a2
ks)
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ StReturn{}            <- forall a. [a] -> a
last [Block a2]
bs = [-a1
1]
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StIfArithmetic a2
_ SrcSpan
_ Expression a2
_ Expression a2
k1 Expression a2
k2 Expression a2
k3) <- forall a. [a] -> a
last [Block a2]
bs =
      [forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k1, forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k2, forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k3]
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ (StRead a2
_ SrcSpan
_ AList ControlPair a2
cs Maybe (AList Expression a2)
_) <- forall a. [a] -> a
last [Block a2]
bs =
      let (Maybe (Expression a2)
me, Maybe (Expression a2)
mr) = forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList ControlPair a2
cs
          f :: Maybe (Expression a2) -> [a1]
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a b. (a -> b) -> a -> b
$ \Expression a2
v -> [forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
v]
      in  Maybe (Expression a2) -> [a1]
f Maybe (Expression a2)
me forall a. [a] -> [a] -> [a]
++ Maybe (Expression a2) -> [a1]
f Maybe (Expression a2)
mr
examineFinalBlock Map String a1
_ [Block a2]
_                                        = [-a1
1]

-- True iff the final block in the list is an explicit control transfer.
isFinalBlockCtrlXfer :: [Block a] -> Bool
isFinalBlockCtrlXfer :: forall a. [Block a] -> Bool
isFinalBlockCtrlXfer bs :: [Block a]
bs@(Block a
_:[Block a]
_)
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoUnconditional{} <- forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoAssigned{}      <- forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StReturn{}            <- forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StIfArithmetic{}      <- forall a. [a] -> a
last [Block a]
bs = Bool
True
  -- Note that StGotoComputed is not handled here since it
  -- is not an explicit control transfer if the expression
  -- does not index into one of the labels, in which case
  -- it acts as a StContinue
isFinalBlockCtrlXfer [Block a]
_                                 = Bool
False

-- True iff the final block in the list has an control transfer
-- with exceptional circumstances, like a StGotoComputed or a StRead
isFinalBlockExceptionalCtrlXfer :: [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer :: forall a. [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer bs :: [Block a]
bs@(Block a
_:[Block a]
_)
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoComputed{} <- forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StRead{}         <- forall a. [a] -> a
last [Block a]
bs = Bool
True
isFinalBlockExceptionalCtrlXfer [Block a]
_                   = Bool
False

-- Drop any '0' that appear at the beginning of a label since
-- labels like "40" and "040" are considered equivalent.
dropLeadingZeroes :: String -> String
dropLeadingZeroes :: String -> String
dropLeadingZeroes = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'0')

lookupBBlock :: Num a1 => M.Map String a1 -> Expression a2 -> a1
lookupBBlock :: forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
a =
  case Expression a2
a of
    ExpValue a2
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam a2)
_) -> (-a1
1) forall a. a -> Maybe a -> a
`fromMaybe` forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> String
dropLeadingZeroes String
l) Map String a1
lm
-- This occurs if a variable is being used for a label, e.g., from a Fortran 77 ASSIGN statement
    ExpValue a2
_ SrcSpan
_ (ValVariable String
l) -> (-a1
1) forall a. a -> Maybe a -> a
`fromMaybe` forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
l Map String a1
lm
    Expression a2
_ -> forall a. HasCallStack => String -> a
error String
"unhandled lookupBBlock"

-- Seek out empty bblocks with a single entrance and a single exit
-- edge, and remove them, re-establishing the edges without them.
delEmptyBBlocks :: (Foldable t, DynGraph gr) => gr (t a) b -> gr (t a) b
delEmptyBBlocks :: forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks gr (t a) b
gr
  | (ASTExprNode
n, ASTExprNode
s, ASTExprNode
t, b
l):[(ASTExprNode, ASTExprNode, ASTExprNode, b)]
_ <- [(ASTExprNode, ASTExprNode, ASTExprNode, b)]
candidates = forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge (ASTExprNode
s, ASTExprNode
t, b
l) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> gr a b
delNode ASTExprNode
n forall a b. (a -> b) -> a -> b
$ gr (t a) b
gr
  | Bool
otherwise                    = gr (t a) b
gr
  where
    -- recompute candidate nodes each iteration
    candidates :: [(ASTExprNode, ASTExprNode, ASTExprNode, b)]
candidates = do
      let emptyBBs :: [(ASTExprNode, t a)]
emptyBBs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr (t a) b
gr)
      let adjs :: [(ASTExprNode, [LEdge b], [LEdge b])]
adjs     = forall a b. (a -> b) -> [a] -> [b]
map (\ (ASTExprNode
n, t a
_) -> (ASTExprNode
n, forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
inn gr (t a) b
gr ASTExprNode
n, forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr (t a) b
gr ASTExprNode
n)) [(ASTExprNode, t a)]
emptyBBs
      (ASTExprNode
n, [(ASTExprNode
s,ASTExprNode
_,b
l)], [(ASTExprNode
_,ASTExprNode
t,b
_)]) <- [(ASTExprNode, [LEdge b], [LEdge b])]
adjs
      forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
s, ASTExprNode
t, b
l)

-- Delete unreachable nodes.
delUnreachable :: DynGraph gr => gr a b -> gr a b
delUnreachable :: forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
delUnreachable gr a b
gr = forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[ASTExprNode] -> gr a b -> gr a b
subgraph (forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> [ASTExprNode]
reachable ASTExprNode
0 gr a b
gr) gr a b
gr

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

-- Running state during basic block analyser.
data BBState a = BBS { forall a. BBState a -> BBGr a
bbGraph  :: BBGr a
                     , forall a. BBState a -> BB a
curBB    :: BB a
                     , forall a. BBState a -> ASTExprNode
curNode  :: Node
                     , forall a. BBState a -> Map String ASTExprNode
labelMap :: M.Map String Node
                     , forall a. BBState a -> [ASTExprNode]
nums     :: [Int]
                     , forall a. BBState a -> [ASTExprNode]
tempNums :: [Int]
                     , forall a. BBState a -> [LEdge ()]
newEdges :: [LEdge ()] }

-- Initial state
bbs0 :: BBState a
bbs0 :: forall a. BBState a
bbs0 = BBS { bbGraph :: BBGr a
bbGraph = forall a. BBGr a
bbgrEmpty, curBB :: BB a
curBB = [], curNode :: ASTExprNode
curNode = ASTExprNode
1
           , labelMap :: Map String ASTExprNode
labelMap = forall k a. Map k a
M.empty, nums :: [ASTExprNode]
nums = [ASTExprNode
2..], tempNums :: [ASTExprNode]
tempNums = [ASTExprNode
0..]
           , newEdges :: [LEdge ()]
newEdges = [] }

-- Monad
type BBlocker a = State (BBState a)

-- Monad entry function.
execBBlocker :: BBlocker a b -> BBState a
execBBlocker :: forall a b. BBlocker a b -> BBState a
execBBlocker = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState forall a. BBState a
bbs0

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

-- Handle a list of blocks (typically from ProgramUnit or nested inside a BlDo, BlIf, etc).
processBlocks :: Data a => [Block (Analysis a)] -> BBlocker (Analysis a) (Node, Node)
-- precondition: curNode is not yet in the graph && will label the first block
-- postcondition: final bblock is in the graph labeled as endN && curNode == endN
-- returns start and end nodes for basic block graph corresponding to parameter bs
processBlocks :: forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs = do
  ASTExprNode
startN <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> ASTExprNode
curNode
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
perBlock [Block (Analysis a)]
bs
  ASTExprNode
endN   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> ASTExprNode
curNode
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState (Analysis a)
st -> BBState (Analysis a)
st { bbGraph :: BBGr (Analysis a)
bbGraph = forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
endN, forall a. [a] -> [a]
reverse (forall a. BBState a -> BB a
curBB BBState (Analysis a)
st))) (forall a. BBState a -> BBGr a
bbGraph BBState (Analysis a)
st)
                      , curBB :: [Block (Analysis a)]
curBB   = [] }
  forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
startN, ASTExprNode
endN)

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

msnoc :: Maybe a -> [a] -> [a]
msnoc :: forall a. Maybe a -> [a] -> [a]
msnoc Maybe a
Nothing  [a]
xs = [a]
xs
msnoc (Just a
x) [a]
xs = [a]
xs forall a. Semigroup a => a -> a -> a
<> [a
x]

-- Handle an AST-block element
perBlock :: Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
-- invariant: curNode corresponds to curBB, and is not yet in the graph
-- invariant: curBB is in reverse order
perBlock :: forall a. Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
perBlock b :: Block (Analysis a)
b@(BlIf Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ NonEmpty (Expression (Analysis a), [Block (Analysis a)])
clauses Maybe [Block (Analysis a)]
elseBlock Maybe (Expression (Analysis a))
_) = do
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  NonEmpty (Expression (Analysis a))
_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst NonEmpty (Expression (Analysis a), [Block (Analysis a)])
clauses) forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls
  forall a. Block a -> BBlocker a ()
addToBBlock forall a b. (a -> b) -> a -> b
$ forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b
  (ASTExprNode
ifN, ASTExprNode
_) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- go through nested AST-blocks
  let bss :: [[Block (Analysis a)]]
bss = forall a. Maybe a -> [a] -> [a]
msnoc Maybe [Block (Analysis a)]
elseBlock forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Expression (Analysis a), [Block (Analysis a)])
clauses
  [(ASTExprNode, ASTExprNode)]
startEnds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Block (Analysis a)]]
bss forall a b. (a -> b) -> a -> b
$ \ [Block (Analysis a)]
bs -> do
    (ASTExprNode
thenN, ASTExprNode
endN) <- forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
    ASTExprNode
_ <- forall a. BBlocker a ASTExprNode
genBBlock
    forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
thenN, ASTExprNode
endN)

  -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN
  ASTExprNode
nxtN   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> ASTExprNode
curNode
  let es :: [LEdge ()]
es  = [(ASTExprNode, ASTExprNode)]
startEnds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (ASTExprNode
thenN, ASTExprNode
endN) -> [(ASTExprNode
ifN, ASTExprNode
thenN, ()), (ASTExprNode
endN, ASTExprNode
nxtN, ())]
  -- if there is no "Else"-statement then we need an edge from ifN -> nxtN
  forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges forall a b. (a -> b) -> a -> b
$ case Maybe [Block (Analysis a)]
elseBlock of Maybe [Block (Analysis a)]
Nothing -> (ASTExprNode
ifN, ASTExprNode
nxtN, ())forall a. a -> [a] -> [a]
:[LEdge ()]
es -- es
                                  Just{}  -> [LEdge ()]
es

perBlock b :: Block (Analysis a)
b@(BlCase Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Expression (Analysis a)
_ [(AList Index (Analysis a), [Block (Analysis a)])]
clauses Maybe [Block (Analysis a)]
defCase Maybe (Expression (Analysis a))
_) = do
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  forall a. Block a -> BBlocker a ()
addToBBlock forall a b. (a -> b) -> a -> b
$ forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b
  (ASTExprNode
selectN, ASTExprNode
_) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- go through nested AST-blocks
  let bss :: [[Block (Analysis a)]]
bss = forall a. Maybe a -> [a] -> [a]
msnoc Maybe [Block (Analysis a)]
defCase forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(AList Index (Analysis a), [Block (Analysis a)])]
clauses
  [(ASTExprNode, ASTExprNode)]
startEnds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Block (Analysis a)]]
bss forall a b. (a -> b) -> a -> b
$ \ [Block (Analysis a)]
bs -> do
    (ASTExprNode
caseN, ASTExprNode
endN) <- forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
    ASTExprNode
_ <- forall a. BBlocker a ASTExprNode
genBBlock
    forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
caseN, ASTExprNode
endN)

  -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN
  ASTExprNode
nxtN   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> ASTExprNode
curNode
  let es :: [LEdge ()]
es  = [(ASTExprNode, ASTExprNode)]
startEnds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (ASTExprNode
caseN, ASTExprNode
endN) -> [(ASTExprNode
selectN, ASTExprNode
caseN, ()), (ASTExprNode
endN, ASTExprNode
nxtN, ())]
  -- if there is no "CASE DEFAULT"-statement then we need an edge from selectN -> nxtN
  forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges forall a b. (a -> b) -> a -> b
$ case Maybe [Block (Analysis a)]
defCase of Maybe [Block (Analysis a)]
Nothing -> (ASTExprNode
selectN, ASTExprNode
nxtN, ())forall a. a -> [a] -> [a]
:[LEdge ()]
es
                                Just{}  -> [LEdge ()]
es

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StGotoComputed Analysis a
_ SrcSpan
_ AList Expression (Analysis a)
_ Expression (Analysis a)
exp)) = do
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Expression (Analysis a)
_ <- forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
exp
  forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b
  (ASTExprNode
gotoN, ASTExprNode
nxtN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
gotoN, ASTExprNode
nxtN, ())]

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
a SrcSpan
ss Maybe (Expression (Analysis a))
_ (StIfLogical Analysis a
_ SrcSpan
_ Expression (Analysis a)
exp Statement (Analysis a)
stm)) = do
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Expression (Analysis a)
_ <- forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
exp
  forall a. Block a -> BBlocker a ()
addToBBlock forall a b. (a -> b) -> a -> b
$ forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b

  -- start a bblock for the nested statement inside the If
  (ASTExprNode
ifN, ASTExprNode
thenN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- build pseudo-AST-block to contain nested statement
  (ASTExprNode, ASTExprNode)
_ <- forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a{ insLabel :: Maybe ASTExprNode
insLabel = forall a. Maybe a
Nothing } SrcSpan
ss forall a. Maybe a
Nothing Statement (Analysis a)
stm]
  ASTExprNode
_ <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> ASTExprNode
curNode

  -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN
  ASTExprNode
nxtN <- forall a. BBlocker a ASTExprNode
genBBlock
  forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
ifN, ASTExprNode
thenN, ()), (ASTExprNode
ifN, ASTExprNode
nxtN, ()), (ASTExprNode
thenN, ASTExprNode
nxtN, ())]

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StIfArithmetic{}) =
  -- Treat an arithmetic if similarly to a goto
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b :: Block (Analysis a)
b@(BlDo Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Maybe (Expression (Analysis a))
_ (Just DoSpecification (Analysis a)
spec) [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
_) = do
  let DoSpecification Analysis a
_ SrcSpan
_ (StExpressionAssign Analysis a
_ SrcSpan
_ Expression (Analysis a)
_ Expression (Analysis a)
e1) Expression (Analysis a)
e2 Maybe (Expression (Analysis a))
me3 = DoSpecification (Analysis a)
spec
  Expression (Analysis a)
_  <- forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e1
  Expression (Analysis a)
_  <- forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e2
  Maybe (Expression (Analysis a))
_  <- case Maybe (Expression (Analysis a))
me3 of Just Expression (Analysis a)
e3 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e3; Maybe (Expression (Analysis a))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock forall a. Maybe a
Nothing Block (Analysis a)
b [Block (Analysis a)]
bs
perBlock b :: Block (Analysis a)
b@(BlDo Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Maybe (Expression (Analysis a))
_ Maybe (DoSpecification (Analysis a))
Nothing [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
_) = forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock forall a. Maybe a
Nothing Block (Analysis a)
b [Block (Analysis a)]
bs
perBlock b :: Block (Analysis a)
b@(BlDoWhile Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ Maybe (Expression (Analysis a))
_ Expression (Analysis a)
exp [Block (Analysis a)]
bs Maybe (Expression (Analysis a))
_) = forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock (forall a. a -> Maybe a
Just Expression (Analysis a)
exp) Block (Analysis a)
b [Block (Analysis a)]
bs
perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StReturn{}) =
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StGotoUnconditional{}) =
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b' :: Block (Analysis a)
b'@(BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l (StCall Analysis a
a' SrcSpan
s' cn :: Expression (Analysis a)
cn@ExpValue{} AList Argument (Analysis a)
aargs)) = do
    case forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument (Analysis a)
aargs of
      []  -> do
        (ASTExprNode
prevN, ASTExprNode
callN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
        -- put StCall in a bblock by itself
        forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b'
        (ASTExprNode
_, ASTExprNode
nextN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
        forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [ (ASTExprNode
prevN, ASTExprNode
callN, ()), (ASTExprNode
callN, ASTExprNode
nextN, ()) ]
      Argument (Analysis a)
_:[Argument (Analysis a)]
_ -> do
        let a0 :: Analysis a
a0 = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis forall a b. (a -> b) -> a -> b
$ [forall a. Analysis a -> a
prevAnnotation Analysis a
a]
        let exps :: [Expression (Analysis a)]
exps = forall a b. (a -> b) -> [a] -> [b]
map forall a. Argument a -> Expression a
argExtractExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. AList t a -> [t a]
aStrip forall a b. (a -> b) -> a -> b
$ AList Argument (Analysis a)
aargs
        (ASTExprNode
prevN, ASTExprNode
formalN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

        -- create bblock that assigns formal parameters (n[1], n[2], ...)
        case Maybe (Expression (Analysis a))
l of
          Just (ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
l' Maybe (KindParam (Analysis a))
_)) -> forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l' ASTExprNode
formalN -- label goes here, if present
          Maybe (Expression (Analysis a))
_                                   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        let name :: Integer -> String
name Integer
i   = forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
cn forall a. [a] -> [a] -> [a]
++ String
"[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i forall a. [a] -> [a] -> [a]
++ String
"]"
        let formal :: Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal (ExpValue Analysis a
a'' SrcSpan
s'' (ValVariable String
_)) Integer
i = forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a''{ insLabel :: Maybe ASTExprNode
insLabel = forall a. Maybe a
Nothing } SrcSpan
s'' (Integer -> String
name Integer
i)
            formal Expression (Analysis a)
e Integer
i                                  = forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a''{ insLabel :: Maybe ASTExprNode
insLabel = forall a. Maybe a
Nothing } SrcSpan
s'' (Integer -> String
name Integer
i)
              where a'' :: Analysis a
a'' = forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e; s'' :: SrcSpan
s'' = forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) -> do
          Expression (Analysis a)
e' <- forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e -- may generate additional bblocks
          let b :: Block (Analysis a)
b = forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a{ insLabel :: Maybe ASTExprNode
insLabel = forall a. Maybe a
Nothing } SrcSpan
s Maybe (Expression (Analysis a))
l (forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e' Integer
i) Expression (Analysis a)
e')
          forall a. Block a -> BBlocker a ()
addToBBlock forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 Block (Analysis a)
b

        (ASTExprNode
formalN', ASTExprNode
dummyCallN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
        -- formalN' may differ from formalN when additional bblocks were
        -- generated by processFunctionCalls.

        let dummyArgs :: [Argument (Analysis a)]
dummyArgs = forall a b. (a -> b) -> [a] -> [b]
map (\Expression (Analysis a)
e -> forall a.
a -> SrcSpan -> Maybe String -> ArgumentExpression a -> Argument a
Argument Analysis a
a0 SrcSpan
s' forall a. Maybe a
Nothing (forall a. Expression a -> ArgumentExpression a
ArgExpr Expression (Analysis a)
e))
                            (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal [Expression (Analysis a)]
exps [(Integer
1::Integer)..])

        -- create "dummy call" bblock with dummy parameters in the StCall AST-node.
        forall a. Block a -> BBlocker a ()
addToBBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$ forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a SrcSpan
s forall a. Maybe a
Nothing (forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Statement a
StCall Analysis a
a' SrcSpan
s' Expression (Analysis a)
cn (forall (t :: * -> *) a. Spanned (t a) => a -> [t a] -> AList t a
fromList Analysis a
a0 [Argument (Analysis a)]
dummyArgs))
        (ASTExprNode
_, ASTExprNode
returnedN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

        -- re-assign the variables using the values of the formal parameters, if possible
        -- (because call-by-reference)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) ->
          -- this is only possible for l-expressions
          (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Expression a -> Bool
isLExpr Expression (Analysis a)
e) forall a b. (a -> b) -> a -> b
$
            forall a. Block a -> BBlocker a ()
addToBBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$
              forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a{ insLabel :: Maybe ASTExprNode
insLabel = forall a. Maybe a
Nothing } SrcSpan
s Maybe (Expression (Analysis a))
l (forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' Expression (Analysis a)
e (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e Integer
i)))
        (ASTExprNode
_, ASTExprNode
nextN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

        -- connect the bblocks
        forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [ (ASTExprNode
prevN, ASTExprNode
formalN, ()), (ASTExprNode
formalN', ASTExprNode
dummyCallN, ())
                    , (ASTExprNode
dummyCallN, ASTExprNode
returnedN, ()), (ASTExprNode
returnedN, ASTExprNode
nextN, ()) ]

perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StRead Analysis a
_ SrcSpan
_ AList ControlPair (Analysis a)
cs Maybe (AList Expression (Analysis a))
_)) = do
  let (Maybe (Expression (Analysis a))
end, Maybe (Expression (Analysis a))
err) = forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList ControlPair (Analysis a)
cs

  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Block (Analysis a)
b' <- forall from to (m :: * -> *).
(Biplate from to, Applicative m) =>
(to -> m to) -> from -> m from
descendBiM forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Block (Analysis a)
b
  forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b'

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (Expression (Analysis a))
end Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe (Expression (Analysis a))
err) forall a b. (a -> b) -> a -> b
$ do
    (ASTExprNode
readN, ASTExprNode
nxtN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
    forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
readN, ASTExprNode
nxtN, ())]

perBlock Block (Analysis a)
b = do
  forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Block (Analysis a)
b' <- forall from to (m :: * -> *).
(Biplate from to, Applicative m) =>
(to -> m to) -> from -> m from
descendBiM forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Block (Analysis a)
b
  forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b'

--------------------------------------------------
-- helper monadic combinators

-- Do-block helper
perDoBlock :: Data a => Maybe (Expression (Analysis a)) -> Block (Analysis a) -> [Block (Analysis a)] -> BBlocker (Analysis a) ()
perDoBlock :: forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock Maybe (Expression (Analysis a))
repeatExpr Block (Analysis a)
b [Block (Analysis a)]
bs = do
  (ASTExprNode
n, ASTExprNode
doN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  case forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLabel Block (Analysis a)
b of
    Just (ExpValue Analysis a
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam (Analysis a))
_)) -> forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l ASTExprNode
doN
    Maybe (Expression (Analysis a))
_                                  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  case Maybe (Expression (Analysis a))
repeatExpr of Just Expression (Analysis a)
e -> forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e); Maybe (Expression (Analysis a))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall a. Block a -> BBlocker a ()
addToBBlock forall a b. (a -> b) -> a -> b
$ forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b
  (ASTExprNode, ASTExprNode)
_ <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  -- process nested bblocks inside of do-statement
  (ASTExprNode
startN, ASTExprNode
endN) <- forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
  ASTExprNode
n' <- forall a. BBlocker a ASTExprNode
genBBlock
  -- connect all the new bblocks with edges, link to subsequent bblock labeled n'
  forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
n, ASTExprNode
doN, ()), (ASTExprNode
doN, ASTExprNode
n', ()), (ASTExprNode
doN, ASTExprNode
startN, ()), (ASTExprNode
endN, ASTExprNode
doN, ())]

-- Maintains perBlock invariants while potentially starting a new
-- bblock in case of a label.
processLabel :: Block a -> BBlocker a ()
processLabel :: forall a. Block a -> BBlocker a ()
processLabel Block a
b | Just (ExpValue a
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam a)
_)) <- forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLabel Block a
b = do
  (ASTExprNode
n, ASTExprNode
n') <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l ASTExprNode
n'
  forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [(ASTExprNode
n, ASTExprNode
n', ())]
processLabel Block a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Inserts into labelMap
insertLabel :: MonadState (BBState a) m => String -> Node -> m ()
insertLabel :: forall a (m :: * -> *).
MonadState (BBState a) m =>
String -> ASTExprNode -> m ()
insertLabel String
l ASTExprNode
n = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { labelMap :: Map String ASTExprNode
labelMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (String -> String
dropLeadingZeroes String
l) ASTExprNode
n (forall a. BBState a -> Map String ASTExprNode
labelMap BBState a
st) }

-- Puts an AST block into the current bblock.
addToBBlock :: Block a -> BBlocker a ()
addToBBlock :: forall a. Block a -> BBlocker a ()
addToBBlock Block a
b = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { curBB :: BB a
curBB = Block a
bforall a. a -> [a] -> [a]
:forall a. BBState a -> BB a
curBB BBState a
st }

-- Closes down the current bblock and opens a new one.
closeBBlock :: BBlocker a (Node, Node)
closeBBlock :: forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock = do
  ASTExprNode
n  <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> ASTExprNode
curNode
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { bbGraph :: BBGr a
bbGraph = forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
n, forall a. [a] -> [a]
reverse (forall a. BBState a -> BB a
curBB BBState a
st))) (forall a. BBState a -> BBGr a
bbGraph BBState a
st), curBB :: BB a
curBB = [] }
  ASTExprNode
n' <- forall a. BBlocker a ASTExprNode
genBBlock
  forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
n')
closeBBlock_ :: StateT (BBState a) Identity ()
closeBBlock_ :: forall a. StateT (BBState a) Identity ()
closeBBlock_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

-- Starts up a new bblock.
genBBlock :: BBlocker a Int
genBBlock :: forall a. BBlocker a ASTExprNode
genBBlock = do
  ASTExprNode
n' <- forall a. BBlocker a ASTExprNode
gen
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { curNode :: ASTExprNode
curNode = ASTExprNode
n', curBB :: BB a
curBB = [] }
  forall (m :: * -> *) a. Monad m => a -> m a
return ASTExprNode
n'

-- Adds labeled-edge mappings.
createEdges :: MonadState (BBState a) m => [LEdge ()] -> m ()
createEdges :: forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [LEdge ()]
es = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { newEdges :: [LEdge ()]
newEdges = [LEdge ()]
es forall a. [a] -> [a] -> [a]
++ forall a. BBState a -> [LEdge ()]
newEdges BBState a
st }

-- Generates a new node number.
gen :: BBlocker a Int
gen :: forall a. BBlocker a ASTExprNode
gen = do
  ~(ASTExprNode
n:[ASTExprNode]
ns) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> [ASTExprNode]
nums
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState a
s -> BBState a
s { nums :: [ASTExprNode]
nums = [ASTExprNode]
ns }
  forall (m :: * -> *) a. Monad m => a -> m a
return ASTExprNode
n

genTemp :: String -> BBlocker a String
genTemp :: forall a. String -> BBlocker a String
genTemp String
str = do
  ~(ASTExprNode
n:[ASTExprNode]
ns) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. BBState a -> [ASTExprNode]
tempNums
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ BBState a
s -> BBState a
s { tempNums :: [ASTExprNode]
tempNums = [ASTExprNode]
ns }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"_" forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ String
"_t#" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASTExprNode
n

-- Strip nested code not necessary since it is duplicated in another
-- basic block.
stripNestedBlocks :: Block a -> Block a
stripNestedBlocks :: forall a. Block a -> Block a
stripNestedBlocks (BlDo a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Maybe (Expression a)
tl Maybe (DoSpecification a)
ds [Block a]
_ Maybe (Expression a)
el)     = forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDo a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Maybe (Expression a)
tl Maybe (DoSpecification a)
ds [] Maybe (Expression a)
el
stripNestedBlocks (BlDoWhile a
a SrcSpan
s Maybe (Expression a)
l Maybe String
tl Maybe (Expression a)
n Expression a
e [Block a]
_ Maybe (Expression a)
el)  = forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDoWhile a
a SrcSpan
s Maybe (Expression a)
l Maybe String
tl Maybe (Expression a)
n Expression a
e [] Maybe (Expression a)
el
stripNestedBlocks (BlIf a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn NonEmpty (Expression a, [Block a])
clauses Maybe [Block a]
elseBlock Maybe (Expression a)
el) =
    forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> NonEmpty (Expression a, [Block a])
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlIf a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Expression a
e, [Block a]
_bs) -> (Expression a
e, [])) NonEmpty (Expression a, [Block a])
clauses) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const []) Maybe [Block a]
elseBlock) Maybe (Expression a)
el
stripNestedBlocks (BlCase a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Expression a
sc [(AList Index a, [Block a])]
clauses Maybe [Block a]
caseDef Maybe (Expression a)
el) =
    forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [(AList Index a, [Block a])]
-> Maybe [Block a]
-> Maybe (Expression a)
-> Block a
BlCase a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Expression a
sc (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(AList Index a
r, [Block a]
_bs) -> (AList Index a
r, [])) [(AList Index a, [Block a])]
clauses) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const []) Maybe [Block a]
caseDef) Maybe (Expression a)
el
stripNestedBlocks Block a
b                              = Block a
b

-- Flatten out function calls within the expression, returning an
-- expression that replaces the original expression (probably becoming
-- a temporary variable).
processFunctionCalls :: Data a => Expression (Analysis a) -> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls :: forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls = forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCall -- work bottom-up

-- Flatten out a single function call.
processFunctionCall :: Data a => Expression (Analysis a) -> BBlocker (Analysis a) (Expression (Analysis a))
-- precondition: there are no more nested function calls within the actual arguments
processFunctionCall :: forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCall (ExpFunctionCall Analysis a
a SrcSpan
s fn :: Expression (Analysis a)
fn@(ExpValue Analysis a
a' SrcSpan
s' Value (Analysis a)
_) AList Argument (Analysis a)
aargs) = do
  let a0 :: Analysis a
a0 = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis forall a b. (a -> b) -> a -> b
$ [forall a. Analysis a -> a
prevAnnotation Analysis a
a]
  (ASTExprNode
prevN, ASTExprNode
formalN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  let exps :: [Expression (Analysis a)]
exps = forall a b. (a -> b) -> [a] -> [b]
map forall a. Argument a -> Expression a
argExtractExpr forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument (Analysis a)
aargs

  -- create bblock that assigns formal parameters (fn[1], fn[2], ...)
  let name :: Integer -> String
name Integer
i   = forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
fn forall a. [a] -> [a] -> [a]
++ String
"[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i forall a. [a] -> [a] -> [a]
++ String
"]"
  let formal :: Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal (ExpValue Analysis a
_ SrcSpan
s'' (ValVariable String
_)) Integer
i = forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s'' forall a b. (a -> b) -> a -> b
$ Integer -> String
name Integer
i
      formal Expression (Analysis a)
e Integer
i                                = forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 (forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) forall a b. (a -> b) -> a -> b
$ Integer -> String
name Integer
i

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) ->
    forall a. Block a -> BBlocker a ()
addToBBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$ forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s forall a. Maybe a
Nothing (forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e Integer
i) Expression (Analysis a)
e)
  (ASTExprNode
_, ASTExprNode
dummyCallN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  let retV :: Expression (Analysis a)
retV = forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s forall a b. (a -> b) -> a -> b
$ Integer -> String
name (Integer
0::Integer)
  let dummyArgs :: [Argument (Analysis a)]
dummyArgs = forall a b. (a -> b) -> [a] -> [b]
map (\Expression (Analysis a)
e -> forall a.
a -> SrcSpan -> Maybe String -> ArgumentExpression a -> Argument a
Argument Analysis a
a0 SrcSpan
s' forall a. Maybe a
Nothing (forall a. Expression a -> ArgumentExpression a
ArgExpr Expression (Analysis a)
e))
                      (Expression (Analysis a)
retVforall a. a -> [a] -> [a]
:forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal [Expression (Analysis a)]
exps [(Integer
1::Integer)..])

  -- create "dummy call" bblock with dummy arguments in the StCall AST-node.
  forall a. Block a -> BBlocker a ()
addToBBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$ forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a SrcSpan
s forall a. Maybe a
Nothing (forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Statement a
StCall Analysis a
a' SrcSpan
s' Expression (Analysis a)
fn (forall (t :: * -> *) a. Spanned (t a) => a -> [t a] -> AList t a
fromList Analysis a
a0 [Argument (Analysis a)]
dummyArgs))
  (ASTExprNode
_, ASTExprNode
returnedN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- re-assign the variables using the values of the formal parameters, if possible
  -- (because call-by-reference)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) ->
    -- this is only possible for l-expressions
    (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Expression a -> Bool
isLExpr Expression (Analysis a)
e) forall a b. (a -> b) -> a -> b
$
      forall a. Block a -> BBlocker a ()
addToBBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$ forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s forall a. Maybe a
Nothing (forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' Expression (Analysis a)
e (Expression (Analysis a) -> Integer -> Expression (Analysis a)
formal Expression (Analysis a)
e Integer
i)))
  String
tempName <- forall a. String -> BBlocker a String
genTemp (forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
fn)
  let temp :: Expression (Analysis a)
temp = forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s String
tempName

  forall a. Block a -> BBlocker a ()
addToBBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 forall a b. (a -> b) -> a -> b
$ forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s forall a. Maybe a
Nothing (forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a0 SrcSpan
s' Expression (Analysis a)
temp Expression (Analysis a)
retV)
  (ASTExprNode
_, ASTExprNode
nextN) <- forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- connect the bblocks
  forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [ (ASTExprNode
prevN, ASTExprNode
formalN, ()), (ASTExprNode
formalN, ASTExprNode
dummyCallN, ())
              , (ASTExprNode
dummyCallN, ASTExprNode
returnedN, ()), (ASTExprNode
returnedN, ASTExprNode
nextN, ()) ]
  forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
temp
processFunctionCall Expression (Analysis a)
e = forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
e

--------------------------------------------------
-- Supergraph: all program units in one basic-block graph

data SuperBBGr a = SuperBBGr { forall a. SuperBBGr a -> BBGr a
superBBGrGraph :: BBGr a
                             , forall a. SuperBBGr a -> IntMap ProgramUnitName
superBBGrClusters :: IM.IntMap ProgramUnitName
                             , forall a. SuperBBGr a -> Map ProgramUnitName ASTExprNode
superBBGrEntries :: M.Map PUName SuperNode }

type SuperNode = Node
type SuperEdge = (SuperNode, SuperNode, ELabel)
type PUName = ProgramUnitName
type NLabel a = BB (Analysis a)
type ELabel = ()

genSuperBBGr :: forall a. Data a => BBlockMap (Analysis a) -> SuperBBGr (Analysis a)
genSuperBBGr :: forall a.
Data a =>
BBlockMap (Analysis a) -> SuperBBGr (Analysis a)
genSuperBBGr BBlockMap (Analysis a)
bbm = SuperBBGr { superBBGrGraph :: BBGr (Analysis a)
superBBGrGraph = BBGr (Analysis a)
superGraph''
                             , superBBGrClusters :: IntMap ProgramUnitName
superBBGrClusters = IntMap ProgramUnitName
cmap
                             , superBBGrEntries :: Map ProgramUnitName ASTExprNode
superBBGrEntries = Map ProgramUnitName ASTExprNode
entryMap }
  where
    namedNodes   :: [((PUName, Node), NLabel a)]
    namedNodes :: [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes   = [ ((ProgramUnitName
name, ASTExprNode
n), NLabel a
bs) | (ProgramUnitName
name, BBGr (Analysis a)
gr) <- forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bbm, (ASTExprNode
n, NLabel a
bs) <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) ]
    namedEdges   :: [((PUName, Node), (PUName, Node), ELabel)]
    namedEdges :: [((ProgramUnitName, ASTExprNode), (ProgramUnitName, ASTExprNode),
  ())]
namedEdges   = [ ((ProgramUnitName
name, ASTExprNode
n), (ProgramUnitName
name, ASTExprNode
m), ()
l) | (ProgramUnitName
name, BBGr (Analysis a)
gr) <- forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bbm, (ASTExprNode
n, ASTExprNode
m, ()
l) <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) ]
    superNodeMap :: M.Map (PUName, Node) SuperNode
    superNodeMap :: Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes) [ASTExprNode
1..]
    getSuperNode :: (PUName, Node) -> SuperNode
    getSuperNode :: (ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode = forall a. String -> Maybe a -> a
fromJustMsg String
"UNDEFINED SUPERNODE" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap
    superNodes   :: [(SuperNode, NLabel a)]
    superNodes :: [(ASTExprNode, NLabel a)]
superNodes   = [ ((ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
n, NLabel a
bs) | ((ProgramUnitName, ASTExprNode)
n, NLabel a
bs) <- [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes ]
    superEdges   :: [(SuperNode, SuperNode, ELabel)]
    superEdges :: [LEdge ()]
superEdges   = [ ((ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
n, (ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
m, ()
l) | ((ProgramUnitName, ASTExprNode)
n, (ProgramUnitName, ASTExprNode)
m, ()
l) <- [((ProgramUnitName, ASTExprNode), (ProgramUnitName, ASTExprNode),
  ())]
namedEdges ]
    superGraph   :: Gr (NLabel a) ELabel
    superGraph :: Gr (NLabel a) ()
superGraph   = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(ASTExprNode, NLabel a)]
superNodes [LEdge ()]
superEdges
    entryMap     :: M.Map PUName SuperNode
    entryMap :: Map ProgramUnitName ASTExprNode
entryMap     = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (ProgramUnitName
name, ASTExprNode
n') | ((ProgramUnitName
name, ASTExprNode
n), ASTExprNode
n') <- forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap, ASTExprNode
n forall a. Eq a => a -> a -> Bool
== ASTExprNode
0  ]
    exitMap      :: M.Map PUName SuperNode
    exitMap :: Map ProgramUnitName ASTExprNode
exitMap      = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (ProgramUnitName
name, ASTExprNode
n') | ((ProgramUnitName
name, ASTExprNode
n), ASTExprNode
n') <- forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap, ASTExprNode
n forall a. Eq a => a -> a -> Bool
== -ASTExprNode
1 ]
    -- List of Calls and their corresponding SuperNode where they appear.
    -- Assumption: all StCalls appear by themselves in a bblock.
    stCalls      :: [(SuperNode, String)]
    stCalls :: [(ASTExprNode, String)]
stCalls      = [ ((ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode (ProgramUnitName, ASTExprNode)
n, String
sub) | ((ProgramUnitName, ASTExprNode)
n, [BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
e AList Argument (Analysis a)
_)]) <- [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes
                                           , v :: Expression (Analysis a)
v@ExpValue{}                              <- [Expression (Analysis a)
e]
                                           , let sub :: String
sub = forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v
                                           , String -> ProgramUnitName
Named String
sub forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map ProgramUnitName ASTExprNode
entryMap Bool -> Bool -> Bool
&& String -> ProgramUnitName
Named String
sub forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map ProgramUnitName ASTExprNode
exitMap ]
    stCallCtxts  :: [([SuperEdge], SuperNode, String, [SuperEdge])]
    stCallCtxts :: [([LEdge ()], ASTExprNode, String, [LEdge ()])]
stCallCtxts  = [ (forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
inn Gr (NLabel a) ()
superGraph ASTExprNode
n, ASTExprNode
n, String
sub, forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (NLabel a) ()
superGraph ASTExprNode
n) | (ASTExprNode
n, String
sub) <- [(ASTExprNode, String)]
stCalls ]
    stCallEdges  :: [SuperEdge]
    stCallEdges :: [LEdge ()]
stCallEdges  = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [   [ (ASTExprNode
m, ASTExprNode
nEn, ()
l) | (ASTExprNode
m, ASTExprNode
_, ()
l) <- [LEdge ()]
inEdges  ] forall a. [a] -> [a] -> [a]
++
                              [ (ASTExprNode
nEx, ASTExprNode
m, ()
l) | (ASTExprNode
_, ASTExprNode
m, ()
l) <- [LEdge ()]
outEdges ]
                          | ([LEdge ()]
inEdges, ASTExprNode
_, String
sub, [LEdge ()]
outEdges) <- [([LEdge ()], ASTExprNode, String, [LEdge ()])]
stCallCtxts
                          , let nEn :: ASTExprNode
nEn = forall a. String -> Maybe a -> a
fromJustMsg (String
"UNDEFINED: " forall a. [a] -> [a] -> [a]
++ String
sub) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> ProgramUnitName
Named String
sub) Map ProgramUnitName ASTExprNode
entryMap)
                          , let nEx :: ASTExprNode
nEx = forall a. String -> Maybe a -> a
fromJustMsg (String
"UNDEFINED: " forall a. [a] -> [a] -> [a]
++ String
sub) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> ProgramUnitName
Named String
sub) Map ProgramUnitName ASTExprNode
exitMap) ]
    superGraph'  :: Gr (NLabel a) ELabel
    superGraph' :: Gr (NLabel a) ()
superGraph'  = forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [LEdge ()]
stCallEdges forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b.
Graph gr =>
[ASTExprNode] -> gr a b -> gr a b
delNodes (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ASTExprNode, String)]
stCalls) forall a b. (a -> b) -> a -> b
$ Gr (NLabel a) ()
superGraph
    cmap         :: IM.IntMap PUName -- SuperNode ==> PUName
    cmap :: IntMap ProgramUnitName
cmap         = forall a. [(ASTExprNode, a)] -> IntMap a
IM.fromList [ (ASTExprNode
n, ProgramUnitName
name) | ((ProgramUnitName
name, ASTExprNode
_), ASTExprNode
n) <- forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap ]
    mainEntry    :: SuperNode -- (possibly more than one, arbitrarily take first)
    ASTExprNode
mainEntry:[ASTExprNode]
_  = [ ASTExprNode
n | (ASTExprNode
n, NLabel a
_) <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr (NLabel a) ()
superGraph', forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
pre Gr (NLabel a) ()
superGraph' ASTExprNode
n) ]
    -- Rename the main entry point to 0
    superGraph'' :: BBGr (Analysis a)
    superGraph'' :: BBGr (Analysis a)
superGraph'' = BBGr { bbgrGr :: Gr (NLabel a) ()
bbgrGr = forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> gr a b
delNode ASTExprNode
mainEntry forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [ (ASTExprNode
0, ASTExprNode
m, ()
l) | (ASTExprNode
_, ASTExprNode
m, ()
l) <- forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (NLabel a) ()
superGraph' ASTExprNode
mainEntry ] forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
0, []) forall a b. (a -> b) -> a -> b
$ Gr (NLabel a) ()
superGraph'
                        , bbgrEntries :: [ASTExprNode]
bbgrEntries = (ASTExprNode
0forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=ASTExprNode
mainEntry) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ Map ProgramUnitName ASTExprNode
entryMap
                        , bbgrExits :: [ASTExprNode]
bbgrExits   = (-ASTExprNode
1forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ Map ProgramUnitName ASTExprNode
exitMap }

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

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

findLabeledBBlock :: String -> BBGr a -> Maybe Node
findLabeledBBlock :: forall a. String -> BBGr a -> Maybe ASTExprNode
findLabeledBBlock String
llab BBGr a
gr =
  forall a. [a] -> Maybe a
listToMaybe [ ASTExprNode
n | (ASTExprNode
n, BB a
bs) <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr), Block a
b <- BB a
bs
                  , ExpValue a
_ SrcSpan
_ (ValInteger String
llab' Maybe (KindParam a)
_) <- forall a. Maybe a -> [a]
maybeToList (forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLabel Block a
b)
                  , String
llab forall a. Eq a => a -> a -> Bool
== String
llab' ]

-- | Show a basic block graph in a somewhat decent way.
showBBGr :: (Out a, Show a) => BBGr a -> String
showBBGr :: forall a. (Out a, Show a) => BBGr a -> String
showBBGr (BBGr Gr (BB a) ()
gr [ASTExprNode]
_ [ASTExprNode]
_) = forall w a. Writer w a -> w
execWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr (BB a) ()
gr) forall a b. (a -> b) -> a -> b
$ \ (ASTExprNode
n, BB a
bs) -> do
  let b :: String
b = String
"BBLOCK " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASTExprNode
n forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map (\ (ASTExprNode
_, ASTExprNode
m, ()
_) -> ASTExprNode
m) forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (BB a) ()
gr ASTExprNode
n)
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ String
"\n\n" forall a. [a] -> [a] -> [a]
++ String
b
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. ASTExprNode -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
b) Char
'-' forall a. [a] -> [a] -> [a]
++ String
"\n"
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (((forall a. [a] -> [a] -> [a]
++String
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Out a => a -> String
pretty) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BB a
bs)

-- | Show a basic block graph without the clutter
showAnalysedBBGr :: (Out a, Show a) => BBGr (Analysis a) -> String
showAnalysedBBGr :: forall a. (Out a, Show a) => BBGr (Analysis a) -> String
showAnalysedBBGr = forall a. (Out a, Show a) => BBGr a -> String
showBBGr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap forall {a}. [Block (Analysis a)] -> [Block (Maybe ASTExprNode)]
strip)
  where
    strip :: [Block (Analysis a)] -> [Block (Maybe ASTExprNode)]
strip = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Analysis a -> Maybe ASTExprNode
insLabel)

-- | Show a basic block supergraph
showSuperBBGr :: (Out a, Show a) => SuperBBGr (Analysis a) -> String
showSuperBBGr :: forall a. (Out a, Show a) => SuperBBGr (Analysis a) -> String
showSuperBBGr = forall a. (Out a, Show a) => BBGr (Analysis a) -> String
showAnalysedBBGr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SuperBBGr a -> BBGr a
superBBGrGraph

-- | Pick out and show the basic block graphs in the program file analysis.
showBBlocks :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String
showBBlocks :: forall a.
(Data a, Out a, Show a) =>
ProgramFile (Analysis a) -> String
showBBlocks ProgramFile (Analysis a)
pf = ProgramUnit (Analysis a) -> String
perPU forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs ProgramFile (Analysis a)
pf
  where
    perPU :: ProgramUnit (Analysis a) -> String
perPU PUComment{} = String
""
    perPU ProgramUnit (Analysis a)
pu | Analysis { bBlocks :: forall a. Analysis a -> Maybe (BBGr (Analysis a))
bBlocks = Just BBGr (Analysis a)
gr } <- forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu =
      String
dashes forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
dashes forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. (Out a, Show a) => BBGr a -> String
showBBGr (forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap forall {a}. [Block (Analysis a)] -> [Block (Maybe ASTExprNode)]
strip) BBGr (Analysis a)
gr) forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = forall a. ASTExprNode -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
p) Char
'-'
    perPU ProgramUnit (Analysis a)
pu =
      String
dashes forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
dashes forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Out a => a -> String
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Analysis a -> Maybe ASTExprNode
insLabel) (forall a. ProgramUnit a -> [Block a]
programUnitBody ProgramUnit (Analysis a)
pu)) forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = forall a. ASTExprNode -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
p) Char
'-'
    strip :: [Block (Analysis a)] -> [Block (Maybe ASTExprNode)]
strip = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Analysis a -> Maybe ASTExprNode
insLabel)
    getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    getPUs :: forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs = forall from to. Biplate from to => from -> [to]
universeBi

-- | Output a graph in the GraphViz DOT format
bbgrToDOT :: BBGr a -> String
bbgrToDOT :: forall a. BBGr a -> String
bbgrToDOT = forall a. IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' forall a. IntMap a
IM.empty

-- | Output a supergraph in the GraphViz DOT format
superBBGrToDOT :: SuperBBGr a -> String
superBBGrToDOT :: forall a. SuperBBGr a -> String
superBBGrToDOT SuperBBGr a
sgr = forall a. IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' (forall a. SuperBBGr a -> IntMap ProgramUnitName
superBBGrClusters SuperBBGr a
sgr) (forall a. SuperBBGr a -> BBGr a
superBBGrGraph SuperBBGr a
sgr)

-- shared code for DOT output
bbgrToDOT' :: IM.IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' :: forall a. IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' IntMap ProgramUnitName
clusters' (BBGr{ bbgrGr :: forall a. BBGr a -> Gr (BB a) ()
bbgrGr = Gr (BB a) ()
gr }) = forall w a. Writer w a -> w
execWriter forall a b. (a -> b) -> a -> b
$ do
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"strict digraph {\n"
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"node [shape=box,fontname=\"Courier New\"]\n"
  let entryNodes :: [ASTExprNode]
entryNodes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
pre Gr (BB a) ()
gr) (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes Gr (BB a) ()
gr)
  let nodes' :: [ASTExprNode]
nodes' = forall (gr :: * -> * -> *) a b.
Graph gr =>
[ASTExprNode] -> gr a b -> [ASTExprNode]
bfsn [ASTExprNode]
entryNodes Gr (BB a) ()
gr
  [()]
_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ASTExprNode]
nodes' forall a b. (a -> b) -> a -> b
$ \ ASTExprNode
n -> do
    let Just BB a
bs = forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab Gr (BB a) ()
gr ASTExprNode
n
    let mname :: Maybe ProgramUnitName
mname = forall a. ASTExprNode -> IntMap a -> Maybe a
IM.lookup ASTExprNode
n IntMap ProgramUnitName
clusters'
    case Maybe ProgramUnitName
mname of Just ProgramUnitName
name -> do forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ String
"subgraph \"cluster " forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
showPUName ProgramUnitName
name forall a. [a] -> [a] -> [a]
++ String
"\" {\n"
                                  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ String
"label=\"" forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
showPUName ProgramUnitName
name forall a. [a] -> [a] -> [a]
++ String
"\"\n"
                                  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"fontname=\"Courier New\"\nfontsize=24\n"
                  Maybe ProgramUnitName
_         -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ String
"bb" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASTExprNode
n forall a. [a] -> [a] -> [a]
++ String
"[label=\"" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASTExprNode
n forall a. [a] -> [a] -> [a]
++ String
"\\l" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Block a -> String
showBlock BB a
bs forall a. [a] -> [a] -> [a]
++ String
"\"]\n"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null BB a
bs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ String
"bb" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASTExprNode
n forall a. [a] -> [a] -> [a]
++ String
"[shape=circle]\n"
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ String
"bb" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASTExprNode
n forall a. [a] -> [a] -> [a]
++ String
" -> {"
    [()]
_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
suc Gr (BB a) ()
gr ASTExprNode
n) forall a b. (a -> b) -> a -> b
$ \ ASTExprNode
m -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String
" bb" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ASTExprNode
m)
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe ProgramUnitName
mname) forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"

showPUName :: ProgramUnitName -> String
showPUName :: ProgramUnitName -> String
showPUName (Named String
n) = String
n
showPUName ProgramUnitName
NamelessBlockData = String
".blockdata."
showPUName ProgramUnitName
NamelessMain = String
".main."
showPUName ProgramUnitName
NamelessComment = String
".comment."

-- | Some helper functions to output some pseudo-code for readability.
showBlock :: Block a -> String
showBlock :: forall a. Block a -> String
showBlock (BlStatement a
_ SrcSpan
_ Maybe (Expression a)
mlab Statement a
st)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String
str :: String) = String
""
    | Bool
otherwise = forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ String
"\\l"
  where
    str :: String
str =
      case Statement a
st of
        StExpressionAssign a
_ SrcSpan
_ Expression a
e1 Expression a
e2 -> forall a. Expression a -> String
showExpr Expression a
e1 forall a. [a] -> [a] -> [a]
++ String
" <- " forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e2
        StIfLogical a
_ SrcSpan
_ Expression a
e1 Statement a
_         -> String
"if " forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e1
        StWrite a
_ SrcSpan
_ AList ControlPair a
_ (Just AList Expression a
aexps)   -> String
"write " forall a. [a] -> [a] -> [a]
++ forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. Expression a -> String
showExpr AList Expression a
aexps
        StPrint a
_ SrcSpan
_ Expression a
_ (Just AList Expression a
aexps)   -> String
"print " forall a. [a] -> [a] -> [a]
++ forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. Expression a -> String
showExpr AList Expression a
aexps
        StCall a
_ SrcSpan
_ Expression a
cn AList Argument a
_              -> String
"call " forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
cn
        StDeclaration a
_ SrcSpan
_ TypeSpec a
ty Maybe (AList Attribute a)
Nothing AList Declarator a
adecls ->
          forall a. TypeSpec a -> String
showType TypeSpec a
ty forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StDeclaration a
_ SrcSpan
_ TypeSpec a
ty (Just AList Attribute a
aattrs) AList Declarator a
adecls ->
          forall a. TypeSpec a -> String
showType TypeSpec a
ty forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
            forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. Attribute a -> String
showAttr AList Attribute a
aattrs forall a. [a] -> [a] -> [a]
++
            forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StDimension a
_ SrcSpan
_ AList Declarator a
adecls       -> String
"dimension " forall a. [a] -> [a] -> [a]
++ forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StExit{}                     -> String
"exit"
        Statement a
_                            -> String
"<unhandled statement: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Data a => a -> Constr
toConstr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) Statement a
st)) forall a. [a] -> [a] -> [a]
++ String
">"
showBlock (BlIf a
_ SrcSpan
_ Maybe (Expression a)
mlab Maybe String
_ ((Expression a
e1, [Block a]
_) :| [(Expression a, [Block a])]
_) Maybe [Block a]
_ Maybe (Expression a)
_) =
    forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab forall a. [a] -> [a] -> [a]
++ String
"if " forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e1 forall a. [a] -> [a] -> [a]
++ String
"\\l"
showBlock (BlDo a
_ SrcSpan
_ Maybe (Expression a)
mlab Maybe String
_ Maybe (Expression a)
_ (Just DoSpecification a
spec) [Block a]
_ Maybe (Expression a)
_) =
    forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab forall a. [a] -> [a] -> [a]
++ String
"do " forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e1 forall a. [a] -> [a] -> [a]
++ String
" <- " forall a. [a] -> [a] -> [a]
++
      forall a. Expression a -> String
showExpr Expression a
e2 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++
      forall a. Expression a -> String
showExpr Expression a
e3 forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"1" forall a. Expression a -> String
showExpr Maybe (Expression a)
me4 forall a. [a] -> [a] -> [a]
++ String
"\\l"
  where DoSpecification a
_ SrcSpan
_ (StExpressionAssign a
_ SrcSpan
_ Expression a
e1 Expression a
e2) Expression a
e3 Maybe (Expression a)
me4 = DoSpecification a
spec
showBlock (BlDo a
_ SrcSpan
_ Maybe (Expression a)
_ Maybe String
_ Maybe (Expression a)
_ Maybe (DoSpecification a)
Nothing [Block a]
_ Maybe (Expression a)
_) = String
"do"
showBlock (BlComment{})                = String
""
showBlock Block a
b = String
"<unhandled block: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Data a => a -> Constr
toConstr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) Block a
b)) forall a. [a] -> [a] -> [a]
++ String
">"

showAttr :: Attribute a -> String
showAttr :: forall a. Attribute a -> String
showAttr (AttrParameter a
_ SrcSpan
_) = String
"parameter"
showAttr (AttrPublic a
_ SrcSpan
_) = String
"public"
showAttr (AttrPrivate a
_ SrcSpan
_) = String
"private"
showAttr (AttrProtected a
_ SrcSpan
_) = String
"protected"
showAttr (AttrAllocatable a
_ SrcSpan
_) = String
"allocatable"
showAttr (AttrAsynchronous a
_ SrcSpan
_) = String
"asynchronous"
showAttr (AttrDimension a
_ SrcSpan
_ AList DimensionDeclarator a
aDimDecs) =
  String
"dimension ( " forall a. [a] -> [a] -> [a]
++ forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. DimensionDeclarator a -> String
showDim AList DimensionDeclarator a
aDimDecs forall a. [a] -> [a] -> [a]
++ String
" )"
showAttr (AttrExternal a
_ SrcSpan
_) = String
"external"
showAttr (AttrIntent a
_ SrcSpan
_ Intent
In) = String
"intent (in)"
showAttr (AttrIntent a
_ SrcSpan
_ Intent
Out) = String
"intent (out)"
showAttr (AttrIntent a
_ SrcSpan
_ Intent
InOut) = String
"intent (inout)"
showAttr (AttrIntrinsic a
_ SrcSpan
_) = String
"intrinsic"
showAttr (AttrOptional a
_ SrcSpan
_) = String
"optional"
showAttr (AttrPointer a
_ SrcSpan
_) = String
"pointer"
showAttr (AttrSave a
_ SrcSpan
_) = String
"save"
showAttr (AttrTarget a
_ SrcSpan
_) = String
"target"
showAttr (AttrValue a
_ SrcSpan
_) = String
"value"
showAttr (AttrVolatile a
_ SrcSpan
_) = String
"volatile"
showAttr (AttrSuffix a
_ SrcSpan
_ (SfxBind a
_ SrcSpan
_ Maybe (Expression a)
Nothing)) = String
"bind(c)"
showAttr (AttrSuffix a
_ SrcSpan
_ (SfxBind a
_ SrcSpan
_ (Just Expression a
e))) = String
"bind(c,name=" forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e forall a. [a] -> [a] -> [a]
++ String
")"

showLab :: Maybe (Expression a) -> String
showLab :: forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
a =
  case Maybe (Expression a)
a of
    Maybe (Expression a)
Nothing -> forall a. ASTExprNode -> a -> [a]
replicate ASTExprNode
6 Char
' '
    Just (ExpValue a
_ SrcSpan
_ (ValInteger String
l Maybe (KindParam a)
_)) -> Char
' 'forall a. a -> [a] -> [a]
:String
l forall a. [a] -> [a] -> [a]
++ forall a. ASTExprNode -> a -> [a]
replicate (ASTExprNode
5 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
l) Char
' '
    Maybe (Expression a)
_ -> forall a. HasCallStack => String -> a
error String
"unhandled showLab"

showValue :: Value a -> String
showValue :: forall a. Value a -> String
showValue (ValVariable String
v)       = String
v
showValue (ValIntrinsic String
v)      = String
v
showValue (ValInteger String
v Maybe (KindParam a)
_)      = String
v
showValue (ValReal RealLit
v Maybe (KindParam a)
_)         = RealLit -> String
prettyHsRealLit RealLit
v
showValue v :: Value a
v@ValComplex{}        = Doc -> String
render forall a b. (a -> b) -> a -> b
$ forall t. Pretty t => FortranVersion -> t -> Doc
pprint' forall a. HasCallStack => a
undefined Value a
v
showValue (ValString String
s)         = String
"\\\"" forall a. [a] -> [a] -> [a]
++ String -> String
escapeStr String
s forall a. [a] -> [a] -> [a]
++ String
"\\\""
showValue Value a
v                     = String
"<unhandled value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Data a => a -> Constr
toConstr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) Value a
v)) forall a. [a] -> [a] -> [a]
++ String
">"

escapeStr :: String -> String
escapeStr :: String -> String
escapeStr = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [(Char, Bool)] -> Maybe ((Char, Bool), [(Char, Bool)])
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (,Bool
False)
  where
    f :: [(Char, Bool)] -> Maybe ((Char, Bool), [(Char, Bool)])
f []                = forall a. Maybe a
Nothing
    f ((Char
c,Bool
False):[(Char, Bool)]
cs)
      | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\"\\" = forall a. a -> Maybe a
Just ((Char
'\\', Bool
False), (Char
c, Bool
True)forall a. a -> [a] -> [a]
:[(Char, Bool)]
cs)
    f ((Char
c,Bool
_):[(Char, Bool)]
cs)        = forall a. a -> Maybe a
Just ((Char
c, Bool
False), [(Char, Bool)]
cs)

showExpr :: Expression a -> String
showExpr :: forall a. Expression a -> String
showExpr (ExpValue a
_ SrcSpan
_ Value a
v)         = forall a. Value a -> String
showValue Value a
v
showExpr (ExpBinary a
_ SrcSpan
_ BinaryOp
op Expression a
e1 Expression a
e2) = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e1 forall a. [a] -> [a] -> [a]
++ BinaryOp -> String
showOp BinaryOp
op forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e2 forall a. [a] -> [a] -> [a]
++ String
")"
showExpr (ExpUnary a
_ SrcSpan
_ UnaryOp
op Expression a
e)      = String
"(" forall a. [a] -> [a] -> [a]
++ UnaryOp -> String
showUOp UnaryOp
op forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e forall a. [a] -> [a] -> [a]
++ String
")"
showExpr (ExpSubscript a
_ SrcSpan
_ Expression a
e1 AList Index a
aexps) = forall a. Expression a -> String
showExpr Expression a
e1 forall a. [a] -> [a] -> [a]
++ String
"[" forall a. [a] -> [a] -> [a]
++
                                       forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " forall a. Index a -> String
showIndex AList Index a
aexps forall a. [a] -> [a] -> [a]
++ String
"]"
showExpr Expression a
e                        = String
"<unhandled expr: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Data a => a -> Constr
toConstr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) Expression a
e)) forall a. [a] -> [a] -> [a]
++ String
">"

showIndex :: Index a -> String
showIndex :: forall a. Index a -> String
showIndex (IxSingle a
_ SrcSpan
_ Maybe String
_ Expression a
i) = forall a. Expression a -> String
showExpr Expression a
i
showIndex (IxRange a
_ SrcSpan
_ Maybe (Expression a)
l Maybe (Expression a)
u Maybe (Expression a)
s) =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. Expression a -> String
showExpr Maybe (Expression a)
l forall a. [a] -> [a] -> [a]
++ -- Lower
  Char
':' forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. Expression a -> String
showExpr Maybe (Expression a)
u forall a. [a] -> [a] -> [a]
++ -- Upper
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
u' -> Char
':' forall a. a -> [a] -> [a]
: forall a. Expression a -> String
showExpr Expression a
u') Maybe (Expression a)
s -- Stride

showUOp :: UnaryOp -> String
showUOp :: UnaryOp -> String
showUOp UnaryOp
Plus = String
"+"
showUOp UnaryOp
Minus = String
"-"
showUOp UnaryOp
Not = String
"!"
-- needs a custom instance
showUOp (UnCustom String
x) = forall a. Show a => a -> String
show String
x

showOp :: BinaryOp -> String
showOp :: BinaryOp -> String
showOp BinaryOp
Addition = String
" + "
showOp BinaryOp
Multiplication = String
" * "
showOp BinaryOp
Subtraction = String
" - "
showOp BinaryOp
Division = String
" / "
showOp BinaryOp
Concatenation = String
" // "
showOp BinaryOp
op = String
" ." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BinaryOp
op forall a. [a] -> [a] -> [a]
++ String
". "

showType :: TypeSpec a -> String
showType :: forall a. TypeSpec a -> String
showType (TypeSpec a
_ SrcSpan
_ BaseType
t (Just Selector a
_)) = BaseType -> String
showBaseType BaseType
t forall a. [a] -> [a] -> [a]
++ String
"(selector)" -- ++ show s
showType (TypeSpec a
_ SrcSpan
_ BaseType
t Maybe (Selector a)
Nothing)  = BaseType -> String
showBaseType BaseType
t

showBaseType :: BaseType -> String
showBaseType :: BaseType -> String
showBaseType BaseType
TypeInteger         = String
"integer"
showBaseType BaseType
TypeReal            = String
"real"
showBaseType BaseType
TypeDoublePrecision = String
"double"
showBaseType BaseType
TypeComplex         = String
"complex"
showBaseType BaseType
TypeDoubleComplex   = String
"doublecomplex"
showBaseType BaseType
TypeLogical         = String
"logical"
showBaseType BaseType
TypeCharacter       = String
"character"
showBaseType (TypeCustom String
s)      = String
"type(" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
")"
showBaseType BaseType
TypeByte            = String
"byte"
showBaseType BaseType
ClassStar           = String
"class(*)"
showBaseType (ClassCustom String
s)     = String
"class(" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
")"

showDecl :: Declarator a -> String
showDecl :: forall a. Declarator a -> String
showDecl (Declarator a
_ SrcSpan
_ Expression a
e DeclaratorType a
mAdims Maybe (Expression a)
length' Maybe (Expression a)
initial) =
    let partDims :: String
partDims = case DeclaratorType a
mAdims of
                     DeclaratorType a
ScalarDecl -> forall a. Monoid a => a
mempty
                     ArrayDecl AList DimensionDeclarator a
dims ->
                       String
"(" forall a. [a] -> [a] -> [a]
++ forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
"," forall a. DimensionDeclarator a -> String
showDim AList DimensionDeclarator a
dims forall a. [a] -> [a] -> [a]
++ String
")"
     in  forall a. Expression a -> String
showExpr Expression a
e
           forall a. [a] -> [a] -> [a]
++ String
partDims
           forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
"*" forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
length'
           forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
" = " forall a. [a] -> [a] -> [a]
++ forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
initial

showDim :: DimensionDeclarator a -> String
showDim :: forall a. DimensionDeclarator a -> String
showDim (DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
me1 Maybe (Expression a)
me2) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((forall a. [a] -> [a] -> [a]
++String
":") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Expression a -> String
showExpr) Maybe (Expression a)
me1 forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. Expression a -> String
showExpr Maybe (Expression a)
me2

aIntercalate :: [a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate :: forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate [a1]
sep t a2 -> [a1]
f = forall a. [a] -> [[a]] -> [a]
intercalate [a1]
sep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map t a2 -> [a1]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. AList t a -> [t a]
aStrip

noSrcSpan :: SrcSpan
noSrcSpan :: SrcSpan
noSrcSpan = Position -> Position -> SrcSpan
SrcSpan Position
initPosition Position
initPosition

--------------------------------------------------
-- Some helper functions that really should be in fgl.

-- | Fold a function over the graph. Monadically.
ufoldM' :: (Graph gr, Monad m) => (Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' :: forall (gr :: * -> * -> *) (m :: * -> *) a b c.
(Graph gr, Monad m) =>
(Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' Context a b -> c -> m c
f c
u gr a b
g
  | forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
isEmpty gr a b
g = forall (m :: * -> *) a. Monad m => a -> m a
return c
u
  | Bool
otherwise = Context a b -> c -> m c
f Context a b
c forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (gr :: * -> * -> *) (m :: * -> *) a b c.
(Graph gr, Monad m) =>
(Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' Context a b -> c -> m c
f c
u gr a b
g'
  where
    (Context a b
c,gr a b
g') = forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> GDecomp gr a b
matchAny gr a b
g

-- | Map a function over the graph. Monadically.
gmapM' :: (DynGraph gr, Monad m) => (Context a b -> m (Context c d)) -> gr a b -> m (gr c d)
gmapM' :: forall (gr :: * -> * -> *) (m :: * -> *) a b c d.
(DynGraph gr, Monad m) =>
(Context a b -> m (Context c d)) -> gr a b -> m (gr c d)
gmapM' Context a b -> m (Context c d)
f = forall (gr :: * -> * -> *) (m :: * -> *) a b c.
(Graph gr, Monad m) =>
(Context a b -> c -> m c) -> c -> gr a b -> m c
ufoldM' (\ Context a b
c gr c d
g -> Context a b -> m (Context c d)
f Context a b
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Context c d
c' -> forall (m :: * -> *) a. Monad m => a -> m a
return (Context c d
c' forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr c d
g)) forall (gr :: * -> * -> *) a b. Graph gr => gr a b
empty

-- | Map a function over the 'Node' labels in a graph. Monadically.
nmapM' :: (DynGraph gr, Monad m) => (a -> m c) -> gr a b -> m (gr c b)
nmapM' :: forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' a -> m c
f = forall (gr :: * -> * -> *) (m :: * -> *) a b c d.
(DynGraph gr, Monad m) =>
(Context a b -> m (Context c d)) -> gr a b -> m (gr c d)
gmapM' (\ (Adj b
p,ASTExprNode
v,a
l,Adj b
s) -> a -> m c
f a
l forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ c
l' -> forall (m :: * -> *) a. Monad m => a -> m a
return (Adj b
p,ASTExprNode
v,c
l',Adj b
s))

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