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