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

{-# LANGUAGE TupleSections, FlexibleContexts, PatternGuards, ScopedTypeVariables #-}
module Language.Fortran.Analysis.BBlocks
  ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap, ASTBlockNode, ASTExprNode
  , genSuperBBGr, SuperBBGr(..), showSuperBBGr, superBBGrToDOT, findLabeledBBlock, showBlock )
where

import Prelude hiding (exp)
import Data.Generics.Uniplate.Data hiding (transform)
import Data.Char (toLower)
import Data.Data
import Data.List (unfoldr, foldl')
import Control.Monad
import Control.Monad.State.Lazy hiding (fix)
import Control.Monad.Writer hiding (fix)
import Text.PrettyPrint.GenericPretty (pretty, Out)
import Language.Fortran.Analysis
import Language.Fortran.AST hiding (setName)
import Language.Fortran.Util.Position
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

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

-- | Insert basic block graphs into each program unit's analysis
analyseBBlocks :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks :: ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks ProgramFile (Analysis a)
pf = State ASTExprNode (ProgramFile (Analysis a))
-> ASTExprNode -> ProgramFile (Analysis a)
forall s a. State s a -> s -> a
evalState (ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
analyse (ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseAllLhsVars ProgramFile (Analysis a)
pf)) ASTExprNode
1
  where
    analyse :: ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
analyse = ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocksInBBGr (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a) -> ProgramFile (Analysis a))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransFunc ProgramUnit ProgramFile a
forall a. Data a => TransFunc ProgramUnit ProgramFile a
trans ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
forall a.
Data a =>
ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprs (ProgramFile (Analysis a)
 -> State ASTExprNode (ProgramFile (Analysis a)))
-> (ProgramFile (Analysis a)
    -> State ASTExprNode (ProgramFile (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocks
    trans :: Data a => TransFunc ProgramUnit ProgramFile a
    trans :: TransFunc ProgramUnit ProgramFile a
trans = TransFunc ProgramUnit ProgramFile a
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 :: ProgramFile (Analysis a) -> BBlockMap (Analysis a)
genBBlockMap ProgramFile (Analysis a)
pf = [(ProgramUnitName, BBGr (Analysis a))] -> BBlockMap (Analysis a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
    (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu, BBGr (Analysis a)
gr) | ProgramUnit (Analysis a)
pu <- ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall a.
Data a =>
ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs ProgramFile (Analysis a)
pf, Just BBGr (Analysis a)
gr <- [Analysis a -> Maybe (BBGr (Analysis a))
forall a. Analysis a -> Maybe (BBGr (Analysis a))
bBlocks (ProgramUnit (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu)]
  ]
  where
    getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    getPUs :: ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs = ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
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 :: ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocks = TransFuncM (State ASTExprNode) Block ProgramFile a
forall a.
Data a =>
TransFuncM (State ASTExprNode) Block ProgramFile a
transform Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
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 :: Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
eachBlock Block (Analysis a)
b = do
      ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
      ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1)
      Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> State ASTExprNode (Block (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b) { insLabel :: Maybe ASTExprNode
insLabel = ASTExprNode -> Maybe ASTExprNode
forall a. a -> Maybe a
Just ASTExprNode
n }) Block (Analysis a)
b
    transform :: Data a => TransFuncM (State ASTBlockNode) Block ProgramFile a
    transform :: TransFuncM (State ASTExprNode) Block ProgramFile a
transform = TransFuncM (State ASTExprNode) Block ProgramFile a
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 :: ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelBlocksInBBGr = (BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transform ((Gr (BB (Analysis a)) ()
 -> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ()))
-> BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a))
forall (m :: * -> *) a1 a2.
Monad m =>
(Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2)
bbgrMapM ((BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a)))
-> Gr (BB (Analysis a)) ()
-> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ())
forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' ((Block (Analysis a)
 -> StateT ASTExprNode Identity (Block (Analysis a)))
-> BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block (Analysis a)
-> StateT ASTExprNode Identity (Block (Analysis a))
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 :: 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 } <- Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b = do
          ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
          ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode -> StateT ASTExprNode Identity ())
-> ASTExprNode -> StateT ASTExprNode Identity ()
forall a b. (a -> b) -> a -> b
$ ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1
          Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> State ASTExprNode (Block (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> Block (Analysis a))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> Block (Analysis a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall a. Data a => Block (Analysis a) -> Block (Analysis a)
labelWithinBlocks (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { insLabel :: Maybe ASTExprNode
insLabel = ASTExprNode -> Maybe ASTExprNode
forall a. a -> Maybe a
Just ASTExprNode
n }) Block (Analysis a)
b
      | Bool
otherwise = Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> State ASTExprNode (Block (Analysis a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> State ASTExprNode (Block (Analysis a)))
-> Block (Analysis a) -> State ASTExprNode (Block (Analysis a))
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 :: (BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transform = (BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
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 :: 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               -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *) (f :: * -> *).
(Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode -> f (f (Analysis a)) -> f (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e) (Maybe ASTExprNode
-> Statement (Analysis a) -> Statement (Analysis a)
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 [Maybe (Expression (Analysis a))]
e2 [[Block (Analysis a)]]
bss Maybe (Expression (Analysis a))
el    -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> [Maybe (Expression (Analysis a))]
-> [[Block (Analysis a)]]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> [Maybe (Expression a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
BlIf        Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *) (f :: * -> *).
(Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode -> f (f (Analysis a)) -> f (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn (Maybe ASTExprNode
-> [Maybe (Expression (Analysis a))]
-> [Maybe (Expression (Analysis a))]
forall (f :: * -> *) (f :: * -> *) (f :: * -> *).
(Functor f, Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode
-> f (f (f (Analysis a))) -> f (f (f (Analysis a)))
mmfill Maybe ASTExprNode
i [Maybe (Expression (Analysis a))]
e2) [[Block (Analysis a)]]
bss Maybe (Expression (Analysis a))
el
        BlCase      Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
e1 Maybe String
mn Expression (Analysis a)
e2 [Maybe (AList Index (Analysis a))]
is [[Block (Analysis a)]]
bss Maybe (Expression (Analysis a))
el -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> Expression (Analysis a)
-> [Maybe (AList Index (Analysis a))]
-> [[Block (Analysis a)]]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [Maybe (AList Index a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
BlCase      Analysis a
a SrcSpan
s (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *) (f :: * -> *).
(Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode -> f (f (Analysis a)) -> f (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn (Maybe ASTExprNode
-> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *).
Data (f (Analysis a)) =>
Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
i Expression (Analysis a)
e2) (Maybe ASTExprNode
-> [Maybe (AList Index (Analysis a))]
-> [Maybe (AList Index (Analysis a))]
forall (f :: * -> *) (f :: * -> *) (f :: * -> *).
(Functor f, Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode
-> f (f (f (Analysis a))) -> f (f (f (Analysis a)))
mmfill Maybe ASTExprNode
i [Maybe (AList Index (Analysis a))]
is) [[Block (Analysis a)]]
bss 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  -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> Maybe (Expression (Analysis a))
-> Maybe (DoSpecification (Analysis a))
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
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 (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *) (f :: * -> *).
(Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode -> f (f (Analysis a)) -> f (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
mn Maybe (Expression (Analysis a))
tl (Maybe ASTExprNode
-> Maybe (DoSpecification (Analysis a))
-> Maybe (DoSpecification (Analysis a))
forall (f :: * -> *) (f :: * -> *).
(Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode -> f (f (Analysis a)) -> f (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   -> Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe String
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
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 (Maybe ASTExprNode
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
forall (f :: * -> *) (f :: * -> *).
(Functor f, Data (f (Analysis a))) =>
Maybe ASTExprNode -> f (f (Analysis a)) -> f (f (Analysis a))
mfill Maybe ASTExprNode
i Maybe (Expression (Analysis a))
e1) Maybe String
n Maybe (Expression (Analysis a))
tl (Maybe ASTExprNode
-> Expression (Analysis a) -> Expression (Analysis a)
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 = Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel (Analysis a -> Maybe ASTExprNode)
-> Analysis a -> Maybe ASTExprNode
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Block (Analysis a)
b

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

    fill :: forall f. (Data (f (Analysis a))) => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a)
    fill :: Maybe ASTExprNode -> f (Analysis a) -> f (Analysis a)
fill Maybe ASTExprNode
Nothing  = f (Analysis a) -> f (Analysis a)
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 = (Index (Analysis a) -> Index (Analysis a))
-> f (Analysis a) -> f (Analysis a)
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 = Analysis a -> Index (Analysis a) -> Index (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((Index (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Index (Analysis a)
x) { insLabel :: Maybe ASTExprNode
insLabel = ASTExprNode -> Maybe ASTExprNode
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 :: ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprs = TransFuncM (State ASTExprNode) Expression ProgramFile a
forall a.
Data a =>
TransFuncM (State ASTExprNode) Expression ProgramFile a
transform Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
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 :: Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
eachExpr Expression (Analysis a)
e = do
      ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
      ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1)
      Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e) { insLabel :: Maybe ASTExprNode
insLabel = ASTExprNode -> Maybe ASTExprNode
forall a. a -> Maybe a
Just ASTExprNode
n }) Expression (Analysis a)
e
    transform :: Data a => TransFuncM (State ASTExprNode) Expression ProgramFile a
    transform :: TransFuncM (State ASTExprNode) Expression ProgramFile a
transform = TransFuncM (State ASTExprNode) Expression ProgramFile a
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 :: ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
labelExprsInBBGr = (BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a)))
-> ProgramFile (Analysis a)
-> State ASTExprNode (ProgramFile (Analysis a))
forall a.
Data a =>
(BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transformBB ((Gr (BB (Analysis a)) ()
 -> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ()))
-> BBGr (Analysis a) -> State ASTExprNode (BBGr (Analysis a))
forall (m :: * -> *) a1 a2.
Monad m =>
(Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2)
bbgrMapM ((BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a)))
-> Gr (BB (Analysis a)) ()
-> StateT ASTExprNode Identity (Gr (BB (Analysis a)) ())
forall (gr :: * -> * -> *) (m :: * -> *) a c b.
(DynGraph gr, Monad m) =>
(a -> m c) -> gr a b -> m (gr c b)
nmapM' ((Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> BB (Analysis a) -> StateT ASTExprNode Identity (BB (Analysis a))
forall a.
Data a =>
(Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
transformExpr Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
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 :: 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 } <- Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e = do
          ASTExprNode
n <- StateT ASTExprNode Identity ASTExprNode
forall s (m :: * -> *). MonadState s m => m s
get
          ASTExprNode -> StateT ASTExprNode Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ASTExprNode -> StateT ASTExprNode Identity ())
-> ASTExprNode -> StateT ASTExprNode Identity ()
forall a b. (a -> b) -> a -> b
$ ASTExprNode
n ASTExprNode -> ASTExprNode -> ASTExprNode
forall a. Num a => a -> a -> a
+ ASTExprNode
1
          Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ Analysis a -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { insLabel :: Maybe ASTExprNode
insLabel = ASTExprNode -> Maybe ASTExprNode
forall a. a -> Maybe a
Just ASTExprNode
n }) Expression (Analysis a)
e
      | Bool
otherwise = Expression (Analysis a)
-> State ASTExprNode (Expression (Analysis a))
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 :: (BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
transformBB = (BBGr a -> State ASTExprNode (BBGr a))
-> ProgramFile a -> State ASTExprNode (ProgramFile a)
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 :: (Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
transformExpr = (Expression (Analysis a)
 -> State ASTExprNode (Expression (Analysis a)))
-> [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]
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 :: ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
toBBlocksPerPU ProgramUnit (Analysis a)
pu
  | [Block (Analysis a)] -> Bool
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 = BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
-> BBState (Analysis a)
forall a b. BBlocker a b -> BBState a
execBBlocker ([Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
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 = Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
delUnreachable (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramUnit (Analysis a)
-> Map String ASTExprNode
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
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 [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
gr [Block a] b -> gr [Block a] b
delInvalidExits (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramUnit (Analysis a)
-> Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
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  = (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> BBGr (Analysis a) -> BBGr (Analysis a)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
fix (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> Gr [Block (Analysis a)] ()
-> Gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEdge ()]
-> Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges (BBState (Analysis a) -> [LEdge ()]
forall a. BBState a -> [LEdge ()]
newEdges BBState (Analysis a)
bbs)) (BBGr (Analysis a) -> BBGr (Analysis a))
-> BBGr (Analysis a) -> BBGr (Analysis a)
forall a b. (a -> b) -> a -> b
$ BBState (Analysis a) -> BBGr (Analysis a)
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' = Analysis a -> ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation ((ProgramUnit (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu) { bBlocks :: Maybe (BBGr (Analysis a))
bBlocks = BBGr (Analysis a) -> Maybe (BBGr (Analysis a))
forall a. a -> Maybe a
Just BBGr (Analysis a)
gr' }) ProgramUnit (Analysis a)
pu
    lm :: Map String ASTExprNode
lm  = BBState (Analysis a) -> Map String ASTExprNode
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 :: ProgramUnit (Analysis a)
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
insEntryEdges ProgramUnit (Analysis a)
pu = LEdge ()
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge (ASTExprNode
0, ASTExprNode
1, ()) (gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ())
-> (gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ())
-> gr [Block (Analysis a)] ()
-> gr [Block (Analysis a)] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LNode [Block (Analysis a)]
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
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 = ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
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 :: ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
genInOutAssignments ProgramUnit (Analysis a)
pu Bool
exit
  | Bool
exit, PUFunction{} <- ProgramUnit (Analysis a)
pu = (Expression (Analysis a) -> Integer -> Block (Analysis a))
-> [Expression (Analysis a)] -> [Integer] -> [Block (Analysis a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Block (Analysis a)
forall a.
Show a =>
Expression (Analysis a) -> a -> Block (Analysis a)
genAssign (Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
noSrcSpan String
fnExpression (Analysis a)
-> [Expression (Analysis a)] -> [Expression (Analysis a)]
forall a. a -> [a] -> [a]
:[Expression (Analysis a)]
vs) [(Integer
0::Integer)..]
  | Bool
otherwise                = (Expression (Analysis a) -> Integer -> Block (Analysis a))
-> [Expression (Analysis a)] -> [Integer] -> [Block (Analysis a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Block (Analysis a)
forall a.
Show a =>
Expression (Analysis a) -> a -> Block (Analysis a)
genAssign [Expression (Analysis a)]
vs [(Integer
1::Integer)..]
  where
    Named String
fn      = ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu
    name :: a -> String
name a
i        = String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    a0 :: Analysis a
a0            = [Analysis a] -> Analysis a
forall a. [a] -> a
head ([Analysis a] -> Analysis a) -> [Analysis a] -> Analysis a
forall a b. (a -> b) -> a -> b
$ [a] -> [Analysis a]
forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis [Analysis a -> a
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)
_                                                -> (String -> Analysis a
forall a. HasCallStack => String -> a
error String
"genInOutAssignments", String -> SrcSpan
forall a. HasCallStack => String -> a
error String
"genInOutAssignments", [])
    genAssign :: Expression (Analysis a) -> a -> Block (Analysis a)
genAssign Expression (Analysis a)
v a
i = Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a) -> Block (Analysis a)
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
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 _ s' (ValVariable _) -> Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a0 SrcSpan
s' (a -> String
forall a. Show a => a -> String
name a
i)
          Expression (Analysis a)
_               -> String -> Expression (Analysis a)
forall a. HasCallStack => String -> a
error (String -> Expression (Analysis a))
-> String -> Expression (Analysis a)
forall a b. (a -> b) -> a -> b
$ String
"unhandled genAssign case: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ () -> String
forall a. Show a => a -> String
show ((Expression (Analysis a) -> ()) -> Expression (Analysis a) -> ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (() -> Expression (Analysis a) -> ()
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 :: gr [Block a] b -> gr [Block a] b
delInvalidExits gr [Block a] b
gr = ([(ASTExprNode, ASTExprNode)] -> gr [Block a] b -> gr [Block a] b)
-> gr [Block a] b -> [(ASTExprNode, ASTExprNode)] -> gr [Block a] b
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(ASTExprNode, ASTExprNode)] -> gr [Block a] b -> gr [Block a] b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[(ASTExprNode, ASTExprNode)] -> gr a b -> gr a b
delEdges gr [Block a] b
gr ([(ASTExprNode, ASTExprNode)] -> gr [Block a] b)
-> [(ASTExprNode, ASTExprNode)] -> gr [Block a] b
forall a b. (a -> b) -> a -> b
$ do
  ASTExprNode
n  <- gr [Block a] b -> [ASTExprNode]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes gr [Block a] b
gr
  [Block a]
bs <- Maybe [Block a] -> [[Block a]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Block a] -> [[Block a]]) -> Maybe [Block a] -> [[Block a]]
forall a b. (a -> b) -> a -> b
$ gr [Block a] b -> ASTExprNode -> Maybe [Block a]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab gr [Block a] b
gr ASTExprNode
n
  Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [Block a] -> Bool
forall a. [Block a] -> Bool
isFinalBlockCtrlXfer [Block a]
bs
  LEdge b
le <- gr [Block a] b -> ASTExprNode -> [LEdge b]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr [Block a] b
gr ASTExprNode
n
  (ASTExprNode, ASTExprNode) -> [(ASTExprNode, ASTExprNode)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((ASTExprNode, ASTExprNode) -> [(ASTExprNode, ASTExprNode)])
-> (ASTExprNode, ASTExprNode) -> [(ASTExprNode, ASTExprNode)]
forall a b. (a -> b) -> a -> b
$ LEdge b -> (ASTExprNode, ASTExprNode)
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 :: 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 = ([LEdge ()]
 -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ())
-> gr [Block (Analysis a)] ()
-> [LEdge ()]
-> gr [Block (Analysis a)] ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip [LEdge ()]
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges (LNode [Block (Analysis a)]
-> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] ()
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) ([LEdge ()] -> gr [Block (Analysis a)] ())
-> [LEdge ()] -> gr [Block (Analysis a)] ()
forall a b. (a -> b) -> a -> b
$ do
  ASTExprNode
n <- gr [Block (Analysis a)] () -> [ASTExprNode]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes gr [Block (Analysis a)] ()
gr
  [Block (Analysis a)]
bs' <- Maybe [Block (Analysis a)] -> [[Block (Analysis a)]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Block (Analysis a)] -> [[Block (Analysis a)]])
-> Maybe [Block (Analysis a)] -> [[Block (Analysis a)]]
forall a b. (a -> b) -> a -> b
$ gr [Block (Analysis a)] ()
-> ASTExprNode -> Maybe [Block (Analysis a)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab gr [Block (Analysis a)] ()
gr ASTExprNode
n
  Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [LEdge ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (gr [Block (Analysis a)] () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out gr [Block (Analysis a)] ()
gr ASTExprNode
n) Bool -> Bool -> Bool
|| [Block (Analysis a)] -> Bool
forall a. [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer [Block (Analysis a)]
bs'
  ASTExprNode
n' <- Map String ASTExprNode -> [Block (Analysis a)] -> [ASTExprNode]
forall a1 a2. Num a1 => Map String a1 -> [Block a2] -> [a1]
examineFinalBlock Map String ASTExprNode
lm [Block (Analysis a)]
bs'
  LEdge () -> [LEdge ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
n', ())
  where
    bs :: [Block (Analysis a)]
bs = ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)]
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 :: [ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers = ((Maybe (Expression a), Maybe (Expression a))
 -> ControlPair a -> (Maybe (Expression a), Maybe (Expression a)))
-> (Maybe (Expression a), Maybe (Expression a))
-> [ControlPair a]
-> (Maybe (Expression a), Maybe (Expression a))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Maybe (Expression a), Maybe (Expression a))
-> ControlPair a -> (Maybe (Expression a), Maybe (Expression a))
forall a.
(Maybe (Expression a), Maybe (Expression a))
-> ControlPair a -> (Maybe (Expression a), Maybe (Expression a))
handler (Maybe (Expression a)
forall a. Maybe a
Nothing, Maybe (Expression a)
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 (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
          String
"end" -> (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
e, Maybe (Expression a)
r2)
          String
"err" -> (Maybe (Expression a)
r1, Expression a -> Maybe (Expression a)
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 :: 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) <- [Block a2] -> Block a2
forall a. [a] -> a
last [Block a2]
bs = [Map String a1 -> Expression a2 -> a1
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)   <- [Block a2] -> Block a2
forall a. [a] -> a
last [Block a2]
bs = (Expression a2 -> a1) -> [Expression a2] -> [a1]
forall a b. (a -> b) -> [a] -> [b]
map (Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm) ([Expression a2]
-> (AList Expression a2 -> [Expression a2])
-> Maybe (AList Expression a2)
-> [Expression a2]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] AList Expression a2 -> [Expression a2]
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
_)   <- [Block a2] -> Block a2
forall a. [a] -> a
last [Block a2]
bs = (Expression a2 -> a1) -> [Expression a2] -> [a1]
forall a b. (a -> b) -> [a] -> [b]
map (Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm) (AList Expression a2 -> [Expression a2]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression a2
ks)
  | BlStatement a2
_ SrcSpan
_ Maybe (Expression a2)
_ StReturn{}            <- [Block a2] -> Block a2
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) <- [Block a2] -> Block a2
forall a. [a] -> a
last [Block a2]
bs =
      [Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k1, Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
k2, Map String a1 -> Expression a2 -> a1
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)
_) <- [Block a2] -> Block a2
forall a. [a] -> a
last [Block a2]
bs =
      let (Maybe (Expression a2)
me, Maybe (Expression a2)
mr) = [ControlPair a2] -> (Maybe (Expression a2), Maybe (Expression a2))
forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers ([ControlPair a2]
 -> (Maybe (Expression a2), Maybe (Expression a2)))
-> [ControlPair a2]
-> (Maybe (Expression a2), Maybe (Expression a2))
forall a b. (a -> b) -> a -> b
$ AList ControlPair a2 -> [ControlPair a2]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList ControlPair a2
cs
          f :: Maybe (Expression a2) -> [a1]
f = [a1] -> (Expression a2 -> [a1]) -> Maybe (Expression a2) -> [a1]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Expression a2 -> [a1]) -> Maybe (Expression a2) -> [a1])
-> (Expression a2 -> [a1]) -> Maybe (Expression a2) -> [a1]
forall a b. (a -> b) -> a -> b
$ \Expression a2
v -> [Map String a1 -> Expression a2 -> a1
forall a1 a2. Num a1 => Map String a1 -> Expression a2 -> a1
lookupBBlock Map String a1
lm Expression a2
v]
      in  Maybe (Expression a2) -> [a1]
forall a2. Maybe (Expression a2) -> [a1]
f Maybe (Expression a2)
me [a1] -> [a1] -> [a1]
forall a. [a] -> [a] -> [a]
++ Maybe (Expression a2) -> [a1]
forall a2. 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 :: [Block a] -> Bool
isFinalBlockCtrlXfer bs :: [Block a]
bs@(Block a
_:[Block a]
_)
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoUnconditional{} <- [Block a] -> Block a
forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoAssigned{}      <- [Block a] -> Block a
forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StReturn{}            <- [Block a] -> Block a
forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StIfArithmetic{}      <- [Block a] -> Block a
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 :: [Block a] -> Bool
isFinalBlockExceptionalCtrlXfer bs :: [Block a]
bs@(Block a
_:[Block a]
_)
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StGotoComputed{} <- [Block a] -> Block a
forall a. [a] -> a
last [Block a]
bs = Bool
True
  | BlStatement a
_ SrcSpan
_ Maybe (Expression a)
_ StRead{}         <- [Block a] -> Block a
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 = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0')

lookupBBlock :: Num a1 => M.Map String a1 -> Expression a2 -> a1
lookupBBlock :: 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) -> (-a1
1) a1 -> Maybe a1 -> a1
forall a. a -> Maybe a -> a
`fromMaybe` String -> Map String a1 -> Maybe a1
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) a1 -> Maybe a1 -> a1
forall a. a -> Maybe a -> a
`fromMaybe` String -> Map String a1 -> Maybe a1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
l Map String a1
lm
    Expression a2
_ -> String -> a1
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 :: 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 = gr (t a) b -> gr (t a) b
forall (t :: * -> *) (gr :: * -> * -> *) a b.
(Foldable t, DynGraph gr) =>
gr (t a) b -> gr (t a) b
delEmptyBBlocks (gr (t a) b -> gr (t a) b)
-> (gr (t a) b -> gr (t a) b) -> gr (t a) b -> gr (t a) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEdge b -> gr (t a) b -> gr (t a) b
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
LEdge b -> gr a b -> gr a b
insEdge (ASTExprNode
s, ASTExprNode
t, b
l) (gr (t a) b -> gr (t a) b)
-> (gr (t a) b -> gr (t a) b) -> gr (t a) b -> gr (t a) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTExprNode -> gr (t a) b -> gr (t a) b
forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> gr a b
delNode ASTExprNode
n (gr (t a) b -> gr (t a) b) -> gr (t a) b -> gr (t a) b
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 = ((ASTExprNode, t a) -> Bool)
-> [(ASTExprNode, t a)] -> [(ASTExprNode, t a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (t a -> Bool)
-> ((ASTExprNode, t a) -> t a) -> (ASTExprNode, t a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASTExprNode, t a) -> t a
forall a b. (a, b) -> b
snd) (gr (t a) b -> [(ASTExprNode, t a)]
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     = ((ASTExprNode, t a) -> (ASTExprNode, [LEdge b], [LEdge b]))
-> [(ASTExprNode, t a)] -> [(ASTExprNode, [LEdge b], [LEdge b])]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ASTExprNode
n, t a
_) -> (ASTExprNode
n, gr (t a) b -> ASTExprNode -> [LEdge b]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
inn gr (t a) b
gr ASTExprNode
n, gr (t a) b -> ASTExprNode -> [LEdge b]
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
      (ASTExprNode, ASTExprNode, ASTExprNode, b)
-> [(ASTExprNode, ASTExprNode, ASTExprNode, b)]
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 :: gr a b -> gr a b
delUnreachable gr a b
gr = [ASTExprNode] -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[ASTExprNode] -> gr a b -> gr a b
subgraph (ASTExprNode -> gr a b -> [ASTExprNode]
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 { BBState a -> BBGr a
bbGraph  :: BBGr a
                     , BBState a -> BB a
curBB    :: BB a
                     , BBState a -> ASTExprNode
curNode  :: Node
                     , BBState a -> Map String ASTExprNode
labelMap :: M.Map String Node
                     , BBState a -> [ASTExprNode]
nums     :: [Int]
                     , BBState a -> [ASTExprNode]
tempNums :: [Int]
                     , BBState a -> [LEdge ()]
newEdges :: [LEdge ()] }

-- Initial state
bbs0 :: BBState a
bbs0 :: BBState a
bbs0 = BBS :: forall a.
BBGr a
-> BB a
-> ASTExprNode
-> Map String ASTExprNode
-> [ASTExprNode]
-> [ASTExprNode]
-> [LEdge ()]
-> BBState a
BBS { bbGraph :: BBGr a
bbGraph = BBGr a
forall a. BBGr a
bbgrEmpty, curBB :: BB a
curBB = [], curNode :: ASTExprNode
curNode = ASTExprNode
1
           , labelMap :: Map String ASTExprNode
labelMap = Map String ASTExprNode
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 :: BBlocker a b -> BBState a
execBBlocker = (BBlocker a b -> BBState a -> BBState a)
-> BBState a -> BBlocker a b -> BBState a
forall a b c. (a -> b -> c) -> b -> a -> c
flip BBlocker a b -> BBState a -> BBState a
forall s a. State s a -> s -> s
execState BBState a
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 :: [Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs = do
  ASTExprNode
startN <- (BBState (Analysis a) -> ASTExprNode)
-> StateT (BBState (Analysis a)) Identity ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> [Block (Analysis a)]
-> StateT (BBState (Analysis a)) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a. Data a => Block (Analysis a) -> BBlocker (Analysis a) ()
perBlock [Block (Analysis a)]
bs
  ASTExprNode
endN   <- (BBState (Analysis a) -> ASTExprNode)
-> StateT (BBState (Analysis a)) Identity ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  (BBState (Analysis a) -> BBState (Analysis a))
-> StateT (BBState (Analysis a)) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState (Analysis a) -> BBState (Analysis a))
 -> StateT (BBState (Analysis a)) Identity ())
-> (BBState (Analysis a) -> BBState (Analysis a))
-> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState (Analysis a)
st -> BBState (Analysis a)
st { bbGraph :: BBGr (Analysis a)
bbGraph = (Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ())
-> BBGr (Analysis a) -> BBGr (Analysis a)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (LNode [Block (Analysis a)]
-> Gr [Block (Analysis a)] () -> Gr [Block (Analysis a)] ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
endN, [Block (Analysis a)] -> [Block (Analysis a)]
forall a. [a] -> [a]
reverse (BBState (Analysis a) -> [Block (Analysis a)]
forall a. BBState a -> BB a
curBB BBState (Analysis a)
st))) (BBState (Analysis a) -> BBGr (Analysis a)
forall a. BBState a -> BBGr a
bbGraph BBState (Analysis a)
st)
                      , curBB :: [Block (Analysis a)]
curBB   = [] }
  (ASTExprNode, ASTExprNode)
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
startN, ASTExprNode
endN)

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

-- 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 :: Block (Analysis a) -> BBlocker (Analysis a) ()
perBlock b :: Block (Analysis a)
b@(BlIf Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Maybe String
_ [Maybe (Expression (Analysis a))]
exps [[Block (Analysis a)]]
bss Maybe (Expression (Analysis a))
_) = do
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  [Expression (Analysis a)]
_ <- [Expression (Analysis a)]
-> (Expression (Analysis a)
    -> StateT
         (BBState (Analysis a)) Identity (Expression (Analysis a)))
-> StateT (BBState (Analysis a)) Identity [Expression (Analysis a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Maybe (Expression (Analysis a))] -> [Expression (Analysis a)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Expression (Analysis a))] -> [Expression (Analysis a)])
-> ([Maybe (Expression (Analysis a))]
    -> [Maybe (Expression (Analysis a))])
-> [Maybe (Expression (Analysis a))]
-> [Expression (Analysis a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Expression (Analysis a)) -> Bool)
-> [Maybe (Expression (Analysis a))]
-> [Maybe (Expression (Analysis a))]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe (Expression (Analysis a)) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (Expression (Analysis a))] -> [Expression (Analysis a)])
-> [Maybe (Expression (Analysis a))] -> [Expression (Analysis a)]
forall a b. (a -> b) -> a -> b
$ [Maybe (Expression (Analysis a))]
exps) Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
forall a. Block a -> Block a
stripNestedBlocks Block (Analysis a)
b
  (ASTExprNode
ifN, ASTExprNode
_) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- go through nested AST-blocks
  [(ASTExprNode, ASTExprNode)]
startEnds <- [[Block (Analysis a)]]
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Block (Analysis a)]]
bss (([Block (Analysis a)]
  -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
 -> StateT
      (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)])
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall a b. (a -> b) -> a -> b
$ \ [Block (Analysis a)]
bs -> do
    (ASTExprNode
thenN, ASTExprNode
endN) <- [Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
    ASTExprNode
_ <- BBlocker (Analysis a) ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
    (ASTExprNode, ASTExprNode)
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
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   <- (BBState (Analysis a) -> ASTExprNode)
-> BBlocker (Analysis a) ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  let es :: [LEdge ()]
es  = [(ASTExprNode, ASTExprNode)]
startEnds [(ASTExprNode, ASTExprNode)]
-> ((ASTExprNode, ASTExprNode) -> [LEdge ()]) -> [LEdge ()]
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
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges ([LEdge ()] -> BBlocker (Analysis a) ())
-> [LEdge ()] -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ if (Maybe (Expression (Analysis a)) -> Bool)
-> [Maybe (Expression (Analysis a))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe (Expression (Analysis a)) -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe (Expression (Analysis a))]
exps then [LEdge ()]
es else (ASTExprNode
ifN, ASTExprNode
nxtN, ())LEdge () -> [LEdge ()] -> [LEdge ()]
forall a. a -> [a] -> [a]
:[LEdge ()]
es

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

  -- go through nested AST-blocks
  [(ASTExprNode, ASTExprNode)]
startEnds <- [[Block (Analysis a)]]
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Block (Analysis a)]]
bss (([Block (Analysis a)]
  -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
 -> StateT
      (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)])
-> ([Block (Analysis a)]
    -> BBlocker (Analysis a) (ASTExprNode, ASTExprNode))
-> StateT
     (BBState (Analysis a)) Identity [(ASTExprNode, ASTExprNode)]
forall a b. (a -> b) -> a -> b
$ \ [Block (Analysis a)]
bs -> do
    (ASTExprNode
caseN, ASTExprNode
endN) <- [Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a.
Data a =>
[Block (Analysis a)]
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
processBlocks [Block (Analysis a)]
bs
    ASTExprNode
_ <- BBlocker (Analysis a) ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
    (ASTExprNode, ASTExprNode)
-> BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
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   <- (BBState (Analysis a) -> ASTExprNode)
-> BBlocker (Analysis a) ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState (Analysis a) -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  let es :: [LEdge ()]
es  = [(ASTExprNode, ASTExprNode)]
startEnds [(ASTExprNode, ASTExprNode)]
-> ((ASTExprNode, ASTExprNode) -> [LEdge ()]) -> [LEdge ()]
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
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges ([LEdge ()] -> BBlocker (Analysis a) ())
-> [LEdge ()] -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ if (Maybe (AList Index (Analysis a)) -> Bool)
-> [Maybe (AList Index (Analysis a))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe (AList Index (Analysis a)) -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe (AList Index (Analysis a))]
inds then [LEdge ()]
es else (ASTExprNode
selectN, ASTExprNode
nxtN, ())LEdge () -> [LEdge ()] -> [LEdge ()]
forall a. a -> [a] -> [a]
:[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
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Expression (Analysis a)
_ <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
exp
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b
  (ASTExprNode
gotoN, ASTExprNode
nxtN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  [LEdge ()] -> BBlocker (Analysis a) ()
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
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b
  Expression (Analysis a)
_ <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
exp
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
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) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

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

  -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN
  ASTExprNode
nxtN <- BBlocker (Analysis a) ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
  [LEdge ()] -> BBlocker (Analysis a) ()
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
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BBlocker (Analysis a) ()
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)
_  <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e1
  Expression (Analysis a)
_  <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (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 -> Expression (Analysis a) -> Maybe (Expression (Analysis a))
forall a. a -> Maybe a
Just (Expression (Analysis a) -> Maybe (Expression (Analysis a)))
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
-> StateT
     (BBState (Analysis a)) Identity (Maybe (Expression (Analysis a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls Expression (Analysis a)
e3; Maybe (Expression (Analysis a))
Nothing -> Maybe (Expression (Analysis a))
-> StateT
     (BBState (Analysis a)) Identity (Maybe (Expression (Analysis a)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing
  Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock Maybe (Expression (Analysis a))
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))
_) = Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock Maybe (Expression (Analysis a))
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))
_) = Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
forall a.
Data a =>
Maybe (Expression (Analysis a))
-> Block (Analysis a)
-> [Block (Analysis a)]
-> BBlocker (Analysis a) ()
perDoBlock (Expression (Analysis a) -> Maybe (Expression (Analysis a))
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{}) =
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BBlocker (Analysis a) ()
forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StGotoUnconditional{}) =
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
processLabel Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b BBlocker (Analysis a) ()
-> BBlocker (Analysis a) () -> BBlocker (Analysis a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BBlocker (Analysis a) ()
forall a. StateT (BBState a) Identity ()
closeBBlock_
perBlock b :: Block (Analysis a)
b@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StCall Analysis a
_ SrcSpan
_ ExpValue{} Maybe (AList Argument (Analysis a))
Nothing)) = do
  (ASTExprNode
prevN, ASTExprNode
callN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  -- put StCall in a bblock by itself
  Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock Block (Analysis a)
b
  (ASTExprNode
_, ASTExprNode
nextN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock
  [LEdge ()] -> BBlocker (Analysis a) ()
forall a (m :: * -> *).
MonadState (BBState a) m =>
[LEdge ()] -> m ()
createEdges [ (ASTExprNode
prevN, ASTExprNode
callN, ()), (ASTExprNode
callN, ASTExprNode
nextN, ()) ]
perBlock (BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l (StCall Analysis a
a' SrcSpan
s' cn :: Expression (Analysis a)
cn@ExpValue{} (Just AList Argument (Analysis a)
aargs))) = do
  let a0 :: Analysis a
a0 = [Analysis a] -> Analysis a
forall a. [a] -> a
head ([Analysis a] -> Analysis a)
-> ([a] -> [Analysis a]) -> [a] -> Analysis a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [Analysis a]
forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis ([a] -> Analysis a) -> [a] -> Analysis a
forall a b. (a -> b) -> a -> b
$ [Analysis a -> a
forall a. Analysis a -> a
prevAnnotation Analysis a
a]
  let exps :: [Expression (Analysis a)]
exps = (Argument (Analysis a) -> Expression (Analysis a))
-> [Argument (Analysis a)] -> [Expression (Analysis a)]
forall a b. (a -> b) -> [a] -> [b]
map Argument (Analysis a) -> Expression (Analysis a)
forall a. Argument a -> Expression a
extractExp ([Argument (Analysis a)] -> [Expression (Analysis a)])
-> (AList Argument (Analysis a) -> [Argument (Analysis a)])
-> AList Argument (Analysis a)
-> [Expression (Analysis a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AList Argument (Analysis a) -> [Argument (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip (AList Argument (Analysis a) -> [Expression (Analysis a)])
-> AList Argument (Analysis a) -> [Expression (Analysis a)]
forall a b. (a -> b) -> a -> b
$ AList Argument (Analysis a)
aargs
  (ASTExprNode
prevN, ASTExprNode
formalN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
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')) -> String -> ASTExprNode -> BBlocker (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))
_                                   -> () -> BBlocker (Analysis a) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  let name :: a -> String
name a
i   = Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
cn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  let formal :: Expression (Analysis a) -> a -> Expression (Analysis a)
formal (ExpValue Analysis a
a'' SrcSpan
s'' (ValVariable String
_)) a
i = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a''{ insLabel :: Maybe ASTExprNode
insLabel = Maybe ASTExprNode
forall a. Maybe a
Nothing } SrcSpan
s'' (a -> String
forall a. Show a => a -> String
name a
i)
      formal Expression (Analysis a)
e a
i                                  = Analysis a -> SrcSpan -> String -> Expression (Analysis a)
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
genVar Analysis a
a''{ insLabel :: Maybe ASTExprNode
insLabel = Maybe ASTExprNode
forall a. Maybe a
Nothing } SrcSpan
s'' (a -> String
forall a. Show a => a -> String
name a
i)
        where a'' :: Analysis a
a'' = Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e; s'' :: SrcSpan
s'' = Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e
  [(Expression (Analysis a), Integer)]
-> ((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Expression (Analysis a)]
-> [Integer] -> [(Expression (Analysis a), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expression (Analysis a)]
exps [(Integer
1::Integer)..]) (((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
 -> BBlocker (Analysis a) ())
-> ((Expression (Analysis a), Integer) -> BBlocker (Analysis a) ())
-> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ \ (Expression (Analysis a)
e, Integer
i) -> do
    Expression (Analysis a)
e' <- Expression (Analysis a)
-> StateT (BBState (Analysis a)) Identity (Expression (Analysis a))
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 = Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a{ insLabel :: Maybe ASTExprNode
insLabel = Maybe ASTExprNode
forall a. Maybe a
Nothing } SrcSpan
s Maybe (Expression (Analysis a))
l (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Statement a
StExpressionAssign Analysis a
a' SrcSpan
s' (Expression (Analysis a) -> Integer -> Expression (Analysis a)
forall a a.
Show a =>
Expression (Analysis a) -> a -> Expression (Analysis a)
formal Expression (Analysis a)
e' Integer
i) Expression (Analysis a)
e')
    Block (Analysis a) -> BBlocker (Analysis a) ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> BBlocker (Analysis a) ())
-> Block (Analysis a) -> BBlocker (Analysis a) ()
forall a b. (a -> b) -> a -> b
$ Block (Analysis a) -> Block (Analysis a)
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) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
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 = (Expression (Analysis a) -> Argument (Analysis a))
-> [Expression (Analysis a)] -> [Argument (Analysis a)]
forall a b. (a -> b) -> [a] -> [b]
map (Analysis a
-> SrcSpan
-> Maybe String
-> Expression (Analysis a)
-> Argument (Analysis a)
forall a.
a -> SrcSpan -> Maybe String -> Expression a -> Argument a
Argument Analysis a
a0 SrcSpan
s' Maybe String
forall a. Maybe a
Nothing) ((Expression (Analysis a) -> Integer -> Expression (Analysis a))
-> [Expression (Analysis a)]
-> [Integer]
-> [Expression (Analysis a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression (Analysis a) -> Integer -> Expression (Analysis a)
forall a a.
Show a =>
Expression (Analysis a) -> a -> Expression (Analysis a)
formal [Expression (Analysis a)]
exps [(Integer
1::Integer)..])

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

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

  -- connect the bblocks
  [LEdge ()] -> BBlocker (Analysis a) ()
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) = [ControlPair (Analysis a)]
-> (Maybe (Expression (Analysis a)),
    Maybe (Expression (Analysis a)))
forall a.
[ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))
getReadCtrlXfers ([ControlPair (Analysis a)]
 -> (Maybe (Expression (Analysis a)),
     Maybe (Expression (Analysis a))))
-> [ControlPair (Analysis a)]
-> (Maybe (Expression (Analysis a)),
    Maybe (Expression (Analysis a)))
forall a b. (a -> b) -> a -> b
$ AList ControlPair (Analysis a) -> [ControlPair (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList ControlPair (Analysis a)
cs

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

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

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

-- Inserts into labelMap
insertLabel :: MonadState (BBState a) m => String -> Node -> m ()
insertLabel :: String -> ASTExprNode -> m ()
insertLabel String
l ASTExprNode
n = (BBState a -> BBState a) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> m ())
-> (BBState a -> BBState a) -> m ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { labelMap :: Map String ASTExprNode
labelMap = String
-> ASTExprNode -> Map String ASTExprNode -> Map String ASTExprNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (String -> String
dropLeadingZeroes String
l) ASTExprNode
n (BBState a -> Map String ASTExprNode
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 :: Block a -> BBlocker a ()
addToBBlock Block a
b = (BBState a -> BBState a) -> BBlocker a ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> BBlocker a ())
-> (BBState a -> BBState a) -> BBlocker a ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { curBB :: BB a
curBB = Block a
bBlock a -> BB a -> BB a
forall a. a -> [a] -> [a]
:BBState a -> BB 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 :: BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock = do
  ASTExprNode
n  <- (BBState a -> ASTExprNode)
-> StateT (BBState a) Identity ASTExprNode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState a -> ASTExprNode
forall a. BBState a -> ASTExprNode
curNode
  (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> StateT (BBState a) Identity ())
-> (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
st -> BBState a
st { bbGraph :: BBGr a
bbGraph = (Gr (BB a) () -> Gr (BB a) ()) -> BBGr a -> BBGr a
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap (LNode (BB a) -> Gr (BB a) () -> Gr (BB a) ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
n, BB a -> BB a
forall a. [a] -> [a]
reverse (BBState a -> BB a
forall a. BBState a -> BB a
curBB BBState a
st))) (BBState a -> BBGr a
forall a. BBState a -> BBGr a
bbGraph BBState a
st), curBB :: BB a
curBB = [] }
  ASTExprNode
n' <- StateT (BBState a) Identity ASTExprNode
forall a. BBlocker a ASTExprNode
genBBlock
  (ASTExprNode, ASTExprNode) -> BBlocker a (ASTExprNode, ASTExprNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ASTExprNode
n, ASTExprNode
n')
closeBBlock_ :: StateT (BBState a) Identity ()
closeBBlock_ :: StateT (BBState a) Identity ()
closeBBlock_ = StateT (BBState a) Identity (ASTExprNode, ASTExprNode)
-> StateT (BBState a) Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void StateT (BBState a) Identity (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

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

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

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

genTemp :: String -> BBlocker a String
genTemp :: String -> BBlocker a String
genTemp String
str = do
  ~(ASTExprNode
n:[ASTExprNode]
ns) <- (BBState a -> [ASTExprNode])
-> StateT (BBState a) Identity [ASTExprNode]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BBState a -> [ASTExprNode]
forall a. BBState a -> [ASTExprNode]
tempNums
  (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BBState a -> BBState a) -> StateT (BBState a) Identity ())
-> (BBState a -> BBState a) -> StateT (BBState a) Identity ()
forall a b. (a -> b) -> a -> b
$ \ BBState a
s -> BBState a
s { tempNums :: [ASTExprNode]
tempNums = [ASTExprNode]
ns }
  String -> BBlocker a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> BBlocker a String) -> String -> BBlocker a String
forall a b. (a -> b) -> a -> b
$ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_t#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
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 :: 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)     = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
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)  = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
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 [Maybe (Expression a)]
exps [[Block a]]
_ Maybe (Expression a)
el)      = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> [Maybe (Expression a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> [Maybe (Expression a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
BlIf a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn [Maybe (Expression a)]
exps [] Maybe (Expression a)
el
stripNestedBlocks (BlCase a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Expression a
sc [Maybe (AList Index a)]
inds [[Block a]]
_ Maybe (Expression a)
el) = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [Maybe (AList Index a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe String
-> Expression a
-> [Maybe (AList Index a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
BlCase a
a SrcSpan
s Maybe (Expression a)
l Maybe String
mn Expression a
sc [Maybe (AList Index a)]
inds [] Maybe (Expression a)
el
stripNestedBlocks (BlStatement a
a SrcSpan
s Maybe (Expression a)
l
                   (StIfLogical a
a' SrcSpan
s' Expression a
e Statement a
_))      = a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement a
a SrcSpan
s Maybe (Expression a)
l (a -> SrcSpan -> Expression a -> Statement a -> Statement a
forall a.
a -> SrcSpan -> Expression a -> Statement a -> Statement a
StIfLogical a
a' SrcSpan
s' Expression a
e (a -> SrcSpan -> Maybe String -> Statement a
forall a. a -> SrcSpan -> Maybe String -> Statement a
StEndif a
a' SrcSpan
s' Maybe String
forall a. Maybe a
Nothing))
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 :: Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
processFunctionCalls = (Expression (Analysis a)
 -> BBlocker (Analysis a) (Expression (Analysis a)))
-> Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
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 :: 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)
_) Maybe (AList Argument (Analysis a))
aargs) = do
  let a0 :: Analysis a
a0 = [Analysis a] -> Analysis a
forall a. [a] -> a
head ([Analysis a] -> Analysis a)
-> ([a] -> [Analysis a]) -> [a] -> Analysis a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [Analysis a]
forall (b :: * -> *) a. Functor b => b a -> b (Analysis a)
initAnalysis ([a] -> Analysis a) -> [a] -> Analysis a
forall a b. (a -> b) -> a -> b
$ [Analysis a -> a
forall a. Analysis a -> a
prevAnnotation Analysis a
a]
  (ASTExprNode
prevN, ASTExprNode
formalN) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  let exps :: [Expression (Analysis a)]
exps = (Argument (Analysis a) -> Expression (Analysis a))
-> [Argument (Analysis a)] -> [Expression (Analysis a)]
forall a b. (a -> b) -> [a] -> [b]
map Argument (Analysis a) -> Expression (Analysis a)
forall a. Argument a -> Expression a
extractExp ([Argument (Analysis a)]
-> Maybe [Argument (Analysis a)] -> [Argument (Analysis a)]
forall a. a -> Maybe a -> a
fromMaybe [] (AList Argument (Analysis a) -> [Argument (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip (AList Argument (Analysis a) -> [Argument (Analysis a)])
-> Maybe (AList Argument (Analysis a))
-> Maybe [Argument (Analysis a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (AList Argument (Analysis a))
aargs))

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

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

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

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

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

  Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a. Block a -> BBlocker a ()
addToBBlock (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> (Block (Analysis a) -> Block (Analysis a))
-> Block (Analysis a)
-> StateT (BBState (Analysis a)) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Block (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data (f (Analysis a)), Data a) =>
f (Analysis a) -> f (Analysis a)
analyseAllLhsVars1 (Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ())
-> Block (Analysis a) -> StateT (BBState (Analysis a)) Identity ()
forall a b. (a -> b) -> a -> b
$ Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a0 SrcSpan
s Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing (Analysis a
-> SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Statement (Analysis a)
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) <- BBlocker (Analysis a) (ASTExprNode, ASTExprNode)
forall a. BBlocker a (ASTExprNode, ASTExprNode)
closeBBlock

  -- connect the bblocks
  [LEdge ()] -> StateT (BBState (Analysis a)) Identity ()
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, ()) ]
  Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
temp
processFunctionCall Expression (Analysis a)
e = Expression (Analysis a)
-> BBlocker (Analysis a) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
e

extractExp :: Argument a -> Expression a
extractExp :: Argument a -> Expression a
extractExp (Argument a
_ SrcSpan
_ Maybe String
_ Expression a
exp) = Expression a
exp

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

data SuperBBGr a = SuperBBGr { SuperBBGr a -> BBGr a
superBBGrGraph :: BBGr a
                             , SuperBBGr a -> IntMap ProgramUnitName
superBBGrClusters :: IM.IntMap ProgramUnitName
                             , 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 :: BBlockMap (Analysis a) -> SuperBBGr (Analysis a)
genSuperBBGr BBlockMap (Analysis a)
bbm = SuperBBGr :: forall a.
BBGr a
-> IntMap ProgramUnitName
-> Map ProgramUnitName ASTExprNode
-> SuperBBGr a
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) <- BBlockMap (Analysis a) -> [(ProgramUnitName, BBGr (Analysis a))]
forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bbm, (ASTExprNode
n, NLabel a
bs) <- Gr (NLabel a) () -> [(ASTExprNode, NLabel a)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (BBGr (Analysis a) -> Gr (NLabel a) ()
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) <- BBlockMap (Analysis a) -> [(ProgramUnitName, BBGr (Analysis a))]
forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bbm, (ASTExprNode
n, ASTExprNode
m, ()
l) <- Gr (NLabel a) () -> [LEdge ()]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges (BBGr (Analysis a) -> Gr (NLabel a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) ]
    superNodeMap :: M.Map (PUName, Node) SuperNode
    superNodeMap :: Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap = [((ProgramUnitName, ASTExprNode), ASTExprNode)]
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((ProgramUnitName, ASTExprNode), ASTExprNode)]
 -> Map (ProgramUnitName, ASTExprNode) ASTExprNode)
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
forall a b. (a -> b) -> a -> b
$ [(ProgramUnitName, ASTExprNode)]
-> [ASTExprNode] -> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((((ProgramUnitName, ASTExprNode), NLabel a)
 -> (ProgramUnitName, ASTExprNode))
-> [((ProgramUnitName, ASTExprNode), NLabel a)]
-> [(ProgramUnitName, ASTExprNode)]
forall a b. (a -> b) -> [a] -> [b]
map ((ProgramUnitName, ASTExprNode), NLabel a)
-> (ProgramUnitName, ASTExprNode)
forall a b. (a, b) -> a
fst [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes) [ASTExprNode
1..]
    getSuperNode :: (PUName, Node) -> SuperNode
    getSuperNode :: (ProgramUnitName, ASTExprNode) -> ASTExprNode
getSuperNode = String -> Maybe ASTExprNode -> ASTExprNode
forall a. String -> Maybe a -> a
fromJustMsg String
"UNDEFINED SUPERNODE" (Maybe ASTExprNode -> ASTExprNode)
-> ((ProgramUnitName, ASTExprNode) -> Maybe ASTExprNode)
-> (ProgramUnitName, ASTExprNode)
-> ASTExprNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ProgramUnitName, ASTExprNode)
 -> Map (ProgramUnitName, ASTExprNode) ASTExprNode
 -> Maybe ASTExprNode)
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> (ProgramUnitName, ASTExprNode)
-> Maybe ASTExprNode
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ProgramUnitName, ASTExprNode)
-> Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> Maybe ASTExprNode
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   = [(ASTExprNode, NLabel a)] -> [LEdge ()] -> Gr (NLabel a) ()
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     = [(ProgramUnitName, ASTExprNode)] -> Map ProgramUnitName ASTExprNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (ProgramUnitName
name, ASTExprNode
n') | ((ProgramUnitName
name, ASTExprNode
n), ASTExprNode
n') <- Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap, ASTExprNode
n ASTExprNode -> ASTExprNode -> Bool
forall a. Eq a => a -> a -> Bool
== ASTExprNode
0  ]
    exitMap      :: M.Map PUName SuperNode
    exitMap :: Map ProgramUnitName ASTExprNode
exitMap      = [(ProgramUnitName, ASTExprNode)] -> Map ProgramUnitName ASTExprNode
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (ProgramUnitName
name, ASTExprNode
n') | ((ProgramUnitName
name, ASTExprNode
n), ASTExprNode
n') <- Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList Map (ProgramUnitName, ASTExprNode) ASTExprNode
superNodeMap, ASTExprNode
n ASTExprNode -> ASTExprNode -> Bool
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 Maybe (AList Argument (Analysis a))
_)]) <- [((ProgramUnitName, ASTExprNode), NLabel a)]
namedNodes
                                           , v :: Expression (Analysis a)
v@ExpValue{}                              <- [Expression (Analysis a)
e]
                                           , let sub :: String
sub = Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
varName Expression (Analysis a)
v
                                           , String -> ProgramUnitName
Named String
sub ProgramUnitName -> Map ProgramUnitName ASTExprNode -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map ProgramUnitName ASTExprNode
entryMap Bool -> Bool -> Bool
&& String -> ProgramUnitName
Named String
sub ProgramUnitName -> Map ProgramUnitName ASTExprNode -> Bool
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  = [ (Gr (NLabel a) () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
inn Gr (NLabel a) ()
superGraph ASTExprNode
n, ASTExprNode
n, String
sub, Gr (NLabel a) () -> ASTExprNode -> [LEdge ()]
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  = [[LEdge ()]] -> [LEdge ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [   [ (ASTExprNode
m, ASTExprNode
nEn, ()
l) | (ASTExprNode
m, ASTExprNode
_, ()
l) <- [LEdge ()]
inEdges  ] [LEdge ()] -> [LEdge ()] -> [LEdge ()]
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 = String -> Maybe ASTExprNode -> ASTExprNode
forall a. String -> Maybe a -> a
fromJustMsg (String
"UNDEFINED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sub) (ProgramUnitName
-> Map ProgramUnitName ASTExprNode -> Maybe ASTExprNode
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 = String -> Maybe ASTExprNode -> ASTExprNode
forall a. String -> Maybe a -> a
fromJustMsg (String
"UNDEFINED: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sub) (ProgramUnitName
-> Map ProgramUnitName ASTExprNode -> Maybe ASTExprNode
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'  = [LEdge ()] -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [LEdge ()]
stCallEdges (Gr (NLabel a) () -> Gr (NLabel a) ())
-> (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) ()
-> Gr (NLabel a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ASTExprNode] -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
[ASTExprNode] -> gr a b -> gr a b
delNodes (((ASTExprNode, String) -> ASTExprNode)
-> [(ASTExprNode, String)] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (ASTExprNode, String) -> ASTExprNode
forall a b. (a, b) -> a
fst [(ASTExprNode, String)]
stCalls) (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) () -> Gr (NLabel a) ()
forall a b. (a -> b) -> a -> b
$ Gr (NLabel a) ()
superGraph
    cmap         :: IM.IntMap PUName -- SuperNode ==> PUName
    cmap :: IntMap ProgramUnitName
cmap         = [(ASTExprNode, ProgramUnitName)] -> IntMap ProgramUnitName
forall a. [(ASTExprNode, a)] -> IntMap a
IM.fromList [ (ASTExprNode
n, ProgramUnitName
name) | ((ProgramUnitName
name, ASTExprNode
_), ASTExprNode
n) <- Map (ProgramUnitName, ASTExprNode) ASTExprNode
-> [((ProgramUnitName, ASTExprNode), ASTExprNode)]
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
_) <- Gr (NLabel a) () -> [(ASTExprNode, NLabel a)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr (NLabel a) ()
superGraph', [ASTExprNode] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Gr (NLabel a) () -> ASTExprNode -> [ASTExprNode]
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 :: forall a. Gr (BB a) () -> [ASTExprNode] -> [ASTExprNode] -> BBGr a
BBGr { bbgrGr :: Gr (NLabel a) ()
bbgrGr = ASTExprNode -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
ASTExprNode -> gr a b -> gr a b
delNode ASTExprNode
mainEntry (Gr (NLabel a) () -> Gr (NLabel a) ())
-> (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) ()
-> Gr (NLabel a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   [LEdge ()] -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [ (ASTExprNode
0, ASTExprNode
m, ()
l) | (ASTExprNode
_, ASTExprNode
m, ()
l) <- Gr (NLabel a) () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (NLabel a) ()
superGraph' ASTExprNode
mainEntry ] (Gr (NLabel a) () -> Gr (NLabel a) ())
-> (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) ()
-> Gr (NLabel a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   (ASTExprNode, NLabel a) -> Gr (NLabel a) () -> Gr (NLabel a) ()
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
LNode a -> gr a b -> gr a b
insNode (ASTExprNode
0, []) (Gr (NLabel a) () -> Gr (NLabel a) ())
-> Gr (NLabel a) () -> Gr (NLabel a) ()
forall a b. (a -> b) -> a -> b
$ Gr (NLabel a) ()
superGraph'
                        , bbgrEntries :: [ASTExprNode]
bbgrEntries = (ASTExprNode
0ASTExprNode -> [ASTExprNode] -> [ASTExprNode]
forall a. a -> [a] -> [a]
:) ([ASTExprNode] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ASTExprNode -> Bool) -> [ASTExprNode] -> [ASTExprNode]
forall a. (a -> Bool) -> [a] -> [a]
filter (ASTExprNode -> ASTExprNode -> Bool
forall a. Eq a => a -> a -> Bool
/=ASTExprNode
mainEntry) ([ASTExprNode] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ProgramUnitName, ASTExprNode) -> ASTExprNode)
-> [(ProgramUnitName, ASTExprNode)] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (ProgramUnitName, ASTExprNode) -> ASTExprNode
forall a b. (a, b) -> b
snd ([(ProgramUnitName, ASTExprNode)] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode
    -> [(ProgramUnitName, ASTExprNode)])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ProgramUnitName ASTExprNode -> [(ProgramUnitName, ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode -> [ASTExprNode]
forall a b. (a -> b) -> a -> b
$ Map ProgramUnitName ASTExprNode
entryMap
                        , bbgrExits :: [ASTExprNode]
bbgrExits   = (-ASTExprNode
1ASTExprNode -> [ASTExprNode] -> [ASTExprNode]
forall a. a -> [a] -> [a]
:) ([ASTExprNode] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ProgramUnitName, ASTExprNode) -> ASTExprNode)
-> [(ProgramUnitName, ASTExprNode)] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (ProgramUnitName, ASTExprNode) -> ASTExprNode
forall a b. (a, b) -> b
snd ([(ProgramUnitName, ASTExprNode)] -> [ASTExprNode])
-> (Map ProgramUnitName ASTExprNode
    -> [(ProgramUnitName, ASTExprNode)])
-> Map ProgramUnitName ASTExprNode
-> [ASTExprNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ProgramUnitName ASTExprNode -> [(ProgramUnitName, ASTExprNode)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ProgramUnitName ASTExprNode -> [ASTExprNode])
-> Map ProgramUnitName ASTExprNode -> [ASTExprNode]
forall a b. (a -> b) -> a -> b
$ Map ProgramUnitName ASTExprNode
exitMap }

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

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

findLabeledBBlock :: String -> BBGr a -> Maybe Node
findLabeledBBlock :: String -> BBGr a -> Maybe ASTExprNode
findLabeledBBlock String
llab BBGr a
gr =
  [ASTExprNode] -> Maybe ASTExprNode
forall a. [a] -> Maybe a
listToMaybe [ ASTExprNode
n | (ASTExprNode
n, BB a
bs) <- Gr (BB a) () -> [(ASTExprNode, BB a)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (BBGr a -> Gr (BB a) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr a
gr), Block a
b <- BB a
bs
                  , ExpValue a
_ SrcSpan
_ (ValInteger String
llab') <- Maybe (Expression a) -> [Expression a]
forall a. Maybe a -> [a]
maybeToList (Block a -> Maybe (Expression a)
forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLabel Block a
b)
                  , String
llab String -> String -> Bool
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 :: BBGr a -> String
showBBGr (BBGr Gr (BB a) ()
gr [ASTExprNode]
_ [ASTExprNode]
_) = Writer String [()] -> String
forall w a. Writer w a -> w
execWriter (Writer String [()] -> String)
-> ((LNode (BB a) -> WriterT String Identity ())
    -> Writer String [()])
-> (LNode (BB a) -> WriterT String Identity ())
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LNode (BB a)]
-> (LNode (BB a) -> WriterT String Identity ())
-> Writer String [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Gr (BB a) () -> [LNode (BB a)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr (BB a) ()
gr) ((LNode (BB a) -> WriterT String Identity ()) -> String)
-> (LNode (BB a) -> WriterT String Identity ()) -> String
forall a b. (a -> b) -> a -> b
$ \ (ASTExprNode
n, BB a
bs) -> do
  let b :: String
b = String
"BBLOCK " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ASTExprNode] -> String
forall a. Show a => a -> String
show ((LEdge () -> ASTExprNode) -> [LEdge ()] -> [ASTExprNode]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ASTExprNode
_, ASTExprNode
m, ()
_) -> ASTExprNode
m) ([LEdge ()] -> [ASTExprNode]) -> [LEdge ()] -> [ASTExprNode]
forall a b. (a -> b) -> a -> b
$ Gr (BB a) () -> ASTExprNode -> [LEdge ()]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [LEdge b]
out Gr (BB a) ()
gr ASTExprNode
n)
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate (String -> ASTExprNode
forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
b) Char
'-' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (((String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") (String -> String) -> (Block a -> String) -> Block a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block a -> String
forall a. Out a => a -> String
pretty) (Block a -> String) -> BB a -> String
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 :: BBGr (Analysis a) -> String
showAnalysedBBGr = BBGr (Maybe ASTExprNode) -> String
forall a. (Out a, Show a) => BBGr a -> String
showBBGr (BBGr (Maybe ASTExprNode) -> String)
-> (BBGr (Analysis a) -> BBGr (Maybe ASTExprNode))
-> BBGr (Analysis a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ())
-> BBGr (Analysis a) -> BBGr (Maybe ASTExprNode)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap ((BB (Analysis a) -> BB (Maybe ASTExprNode))
-> Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ()
forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap BB (Analysis a) -> BB (Maybe ASTExprNode)
forall a. [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip)
  where
    strip :: [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip = (Block (Analysis a) -> Block (Maybe ASTExprNode))
-> [Block (Analysis a)] -> BB (Maybe ASTExprNode)
forall a b. (a -> b) -> [a] -> [b]
map ((Analysis a -> Maybe ASTExprNode)
-> Block (Analysis a) -> Block (Maybe ASTExprNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel)

-- | Show a basic block supergraph
showSuperBBGr :: (Out a, Show a) => SuperBBGr (Analysis a) -> String
showSuperBBGr :: SuperBBGr (Analysis a) -> String
showSuperBBGr = BBGr (Analysis a) -> String
forall a. (Out a, Show a) => BBGr (Analysis a) -> String
showAnalysedBBGr (BBGr (Analysis a) -> String)
-> (SuperBBGr (Analysis a) -> BBGr (Analysis a))
-> SuperBBGr (Analysis a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuperBBGr (Analysis a) -> BBGr (Analysis a)
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 :: ProgramFile (Analysis a) -> String
showBBlocks ProgramFile (Analysis a)
pf = ProgramUnit (Analysis a) -> String
forall a. ProgramUnit (Analysis a) -> String
perPU (ProgramUnit (Analysis a) -> String)
-> [ProgramUnit (Analysis a)] -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
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 } <- ProgramUnit (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu =
      String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BBGr (Maybe ASTExprNode) -> String
forall a. (Out a, Show a) => BBGr a -> String
showBBGr ((Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ())
-> BBGr (Analysis a) -> BBGr (Maybe ASTExprNode)
forall a b. (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b
bbgrMap ((BB (Analysis a) -> BB (Maybe ASTExprNode))
-> Gr (BB (Analysis a)) () -> Gr (BB (Maybe ASTExprNode)) ()
forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap BB (Analysis a) -> BB (Maybe ASTExprNode)
forall a. [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip) BBGr (Analysis a)
gr) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
forall a. Show a => a -> String
show (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate (String -> ASTExprNode
forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
p) Char
'-'
    perPU ProgramUnit (Analysis a)
pu =
      String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dashes String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((Block (Analysis a) -> String) -> BB (Analysis a) -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Block (Maybe ASTExprNode) -> String
forall a. Out a => a -> String
pretty (Block (Maybe ASTExprNode) -> String)
-> (Block (Analysis a) -> Block (Maybe ASTExprNode))
-> Block (Analysis a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Analysis a -> Maybe ASTExprNode)
-> Block (Analysis a) -> Block (Maybe ASTExprNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel) (ProgramUnit (Analysis a) -> BB (Analysis a)
forall a. ProgramUnit a -> [Block a]
programUnitBody ProgramUnit (Analysis a)
pu)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
      where p :: String
p = String
"| Program Unit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
forall a. Show a => a -> String
show (ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |"
            dashes :: String
dashes = ASTExprNode -> Char -> String
forall a. ASTExprNode -> a -> [a]
replicate (String -> ASTExprNode
forall (t :: * -> *) a. Foldable t => t a -> ASTExprNode
length String
p) Char
'-'
    strip :: [Block (Analysis a)] -> BB (Maybe ASTExprNode)
strip = (Block (Analysis a) -> Block (Maybe ASTExprNode))
-> [Block (Analysis a)] -> BB (Maybe ASTExprNode)
forall a b. (a -> b) -> [a] -> [b]
map ((Analysis a -> Maybe ASTExprNode)
-> Block (Analysis a) -> Block (Maybe ASTExprNode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Analysis a -> Maybe ASTExprNode
forall a. Analysis a -> Maybe ASTExprNode
insLabel)
    getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
    getPUs :: ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
getPUs = ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

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

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

-- shared code for DOT output
bbgrToDOT' :: IM.IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' :: IntMap ProgramUnitName -> BBGr a -> String
bbgrToDOT' IntMap ProgramUnitName
clusters' (BBGr{ bbgrGr :: forall a. BBGr a -> Gr (BB a) ()
bbgrGr = Gr (BB a) ()
gr }) = WriterT String Identity () -> String
forall w a. Writer w a -> w
execWriter (WriterT String Identity () -> String)
-> WriterT String Identity () -> String
forall a b. (a -> b) -> a -> b
$ do
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"strict digraph {\n"
  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"node [shape=box,fontname=\"Courier New\"]\n"
  let entryNodes :: [ASTExprNode]
entryNodes = (ASTExprNode -> Bool) -> [ASTExprNode] -> [ASTExprNode]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ASTExprNode] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ASTExprNode] -> Bool)
-> (ASTExprNode -> [ASTExprNode]) -> ASTExprNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr (BB a) () -> ASTExprNode -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
pre Gr (BB a) ()
gr) (Gr (BB a) () -> [ASTExprNode]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [ASTExprNode]
nodes Gr (BB a) ()
gr)
  let nodes' :: [ASTExprNode]
nodes' = [ASTExprNode] -> Gr (BB a) () -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
[ASTExprNode] -> gr a b -> [ASTExprNode]
bfsn [ASTExprNode]
entryNodes Gr (BB a) ()
gr
  [()]
_ <- [ASTExprNode]
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ASTExprNode]
nodes' ((ASTExprNode -> WriterT String Identity ()) -> Writer String [()])
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall a b. (a -> b) -> a -> b
$ \ ASTExprNode
n -> do
    let Just BB a
bs = Gr (BB a) () -> ASTExprNode -> Maybe (BB a)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> Maybe a
lab Gr (BB a) ()
gr ASTExprNode
n
    let mname :: Maybe ProgramUnitName
mname = ASTExprNode -> IntMap ProgramUnitName -> Maybe ProgramUnitName
forall a. ASTExprNode -> IntMap a -> Maybe a
IM.lookup ASTExprNode
n IntMap ProgramUnitName
clusters'
    case Maybe ProgramUnitName
mname of Just ProgramUnitName
name -> do String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"subgraph \"cluster " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
showPUName ProgramUnitName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" {\n"
                                  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
showPUName ProgramUnitName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"\n"
                                  String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"fontname=\"Courier New\"\nfontsize=24\n"
                  Maybe ProgramUnitName
_         -> () -> WriterT String Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[label=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\l" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Block a -> String) -> BB a -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block a -> String
forall a. Block a -> String
showBlock BB a
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]\n"
    Bool -> WriterT String Identity () -> WriterT String Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BB a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null BB a
bs) (WriterT String Identity () -> WriterT String Identity ())
-> (String -> WriterT String Identity ())
-> String
-> WriterT String Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[shape=circle]\n"
    String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> {"
    [()]
_ <- [ASTExprNode]
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Gr (BB a) () -> ASTExprNode -> [ASTExprNode]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> ASTExprNode -> [ASTExprNode]
suc Gr (BB a) ()
gr ASTExprNode
n) ((ASTExprNode -> WriterT String Identity ()) -> Writer String [()])
-> (ASTExprNode -> WriterT String Identity ())
-> Writer String [()]
forall a b. (a -> b) -> a -> b
$ \ ASTExprNode
m -> String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String
" bb" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
m)
    String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"
    Bool -> WriterT String Identity () -> WriterT String Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ProgramUnitName -> Bool
forall a. Maybe a -> Bool
isJust Maybe ProgramUnitName
mname) (WriterT String Identity () -> WriterT String Identity ())
-> WriterT String Identity () -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell String
"}\n"
  String -> WriterT String Identity ()
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 :: Block a -> String
showBlock (BlStatement a
_ SrcSpan
_ Maybe (Expression a)
mlab Statement a
st)
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String
str :: String) = String
""
    | Bool
otherwise = Maybe (Expression a) -> String
forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
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 -> Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e2
        StIfLogical a
_ SrcSpan
_ Expression a
e1 Statement a
_         -> String
"if " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1
        StWrite a
_ SrcSpan
_ AList ControlPair a
_ (Just AList Expression a
aexps)   -> String
"write " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Expression a -> String) -> AList Expression a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Expression a -> String
forall a. Expression a -> String
showExpr AList Expression a
aexps
        StPrint a
_ SrcSpan
_ Expression a
_ (Just AList Expression a
aexps)   -> String
"print " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Expression a -> String) -> AList Expression a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Expression a -> String
forall a. Expression a -> String
showExpr AList Expression a
aexps
        StCall a
_ SrcSpan
_ Expression a
cn Maybe (AList Argument a)
_              -> String
"call " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
cn
        StDeclaration a
_ SrcSpan
_ TypeSpec a
ty Maybe (AList Attribute a)
Nothing AList Declarator a
adecls ->
          TypeSpec a -> String
forall a. TypeSpec a -> String
showType TypeSpec a
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Declarator a -> String) -> AList Declarator a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Declarator a -> 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 ->
          TypeSpec a -> String
forall a. TypeSpec a -> String
showType TypeSpec a
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String -> (Attribute a -> String) -> AList Attribute a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Attribute a -> String
forall a. Attribute a -> String
showAttr AList Attribute a
aattrs String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String -> (Declarator a -> String) -> AList Declarator a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Declarator a -> String
forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StDimension a
_ SrcSpan
_ AList Declarator a
adecls       -> String
"dimension " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (Declarator a -> String) -> AList Declarator a -> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " Declarator a -> String
forall a. Declarator a -> String
showDecl AList Declarator a
adecls
        StExit{}                     -> String
"exit"
        Statement a
_                            -> String
"<unhandled statement: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show (Statement () -> Constr
forall a. Data a => a -> Constr
toConstr ((a -> ()) -> Statement a -> Statement ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) Statement a
st)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
showBlock (BlIf a
_ SrcSpan
_ Maybe (Expression a)
mlab Maybe String
_ (Just Expression a
e1:[Maybe (Expression a)]
_) [[Block a]]
_ Maybe (Expression a)
_) = Maybe (Expression a) -> String
forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"if " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
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)
_) =
    Maybe (Expression a) -> String
forall a. Maybe (Expression a) -> String
showLab Maybe (Expression a)
mlab String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"do " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e3 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"1" Expression a -> String
forall a. Expression a -> String
showExpr Maybe (Expression a)
me4 String -> String -> String
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show (Block () -> Constr
forall a. Data a => a -> Constr
toConstr ((a -> ()) -> Block a -> Block ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) Block a
b)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

showAttr :: Attribute a -> String
showAttr :: 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 ( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (DimensionDeclarator a -> String)
-> AList DimensionDeclarator a
-> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
", " DimensionDeclarator a -> String
forall a. DimensionDeclarator a -> String
showDim AList DimensionDeclarator a
aDimDecs String -> String -> String
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=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

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

showValue :: Value a -> Name
showValue :: Value a -> String
showValue (ValVariable String
v)       = String
v
showValue (ValIntrinsic String
v)      = String
v
showValue (ValInteger String
v)        = String
v
showValue (ValReal String
v)           = String
v
showValue (ValComplex Expression a
e1 Expression a
e2)    = String
"( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" , " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"
showValue (ValString String
s)         = String
"\\\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escapeStr String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\\""
showValue Value a
v                     = String
"<unhandled value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Constr -> String
forall a. Show a => a -> String
show (Value () -> Constr
forall a. Data a => a -> Constr
toConstr ((a -> ()) -> Value a -> Value ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) Value a
v)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

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

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

showIndex :: Index a -> String
showIndex :: Index a -> String
showIndex (IxSingle a
_ SrcSpan
_ Maybe String
_ Expression a
i) = Expression a -> String
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) =
  String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Expression a -> String
forall a. Expression a -> String
showExpr Maybe (Expression a)
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ -- Lower
  Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Expression a -> String
forall a. Expression a -> String
showExpr Maybe (Expression a)
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ -- Upper
  String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
u' -> Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Expression a -> String
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) = String -> String
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
" ." String -> String -> String
forall a. [a] -> [a] -> [a]
++ BinaryOp -> String
forall a. Show a => a -> String
show BinaryOp
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". "

showType :: TypeSpec a -> String
showType :: TypeSpec a -> String
showType (TypeSpec a
_ SrcSpan
_ BaseType
t (Just Selector a
_)) = BaseType -> String
showBaseType BaseType
t String -> String -> String
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 (TypeCharacter Maybe CharacterLen
l Maybe String
k) = case (Maybe CharacterLen
l, Maybe String
k) of
  (Just CharacterLen
cl, Just String
ki) -> String
"character(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CharacterLen -> String
showCharLen CharacterLen
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ki String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  (Just CharacterLen
cl, Maybe String
Nothing) -> String
"character(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CharacterLen -> String
showCharLen CharacterLen
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  (Maybe CharacterLen
Nothing, Just String
ki) -> String
"character(kind=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ki String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  (Maybe CharacterLen
Nothing, Maybe String
Nothing) -> String
"character"
showBaseType (TypeCustom String
s)      = String
"type(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showBaseType BaseType
TypeByte            = String
"byte"
showBaseType BaseType
ClassStar           = String
"class(*)"
showBaseType (ClassCustom String
s)     = String
"class(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

showCharLen :: CharacterLen -> String
showCharLen :: CharacterLen -> String
showCharLen CharacterLen
CharLenStar = String
"*"
showCharLen CharacterLen
CharLenColon = String
":"
showCharLen CharacterLen
CharLenExp  = String
"*" -- FIXME, possibly, with a more robust const-exp
showCharLen (CharLenInt ASTExprNode
i) = ASTExprNode -> String
forall a. Show a => a -> String
show ASTExprNode
i

showDecl :: Declarator a -> String
showDecl :: Declarator a -> String
showDecl (DeclArray a
_ SrcSpan
_ Expression a
e AList DimensionDeclarator a
adims Maybe (Expression a)
length' Maybe (Expression a)
initial) =
  Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (DimensionDeclarator a -> String)
-> AList DimensionDeclarator a
-> String
forall a1 (t :: * -> *) a2.
[a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate String
"," DimensionDeclarator a -> String
forall a. DimensionDeclarator a -> String
showDim AList DimensionDeclarator a
adims String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
"*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
length' String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
initial
showDecl (DeclVariable a
_ SrcSpan
_ Expression a
e Maybe (Expression a)
length' Maybe (Expression a)
initial) =
  Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
"*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
length' String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
-> (Expression a -> String) -> Maybe (Expression a) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Expression a
e' -> String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Expression a -> String
showExpr Expression a
e') Maybe (Expression a)
initial

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

aIntercalate :: [a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate :: [a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1]
aIntercalate [a1]
sep t a2 -> [a1]
f = [a1] -> [[a1]] -> [a1]
forall a. [a] -> [[a]] -> [a]
intercalate [a1]
sep ([[a1]] -> [a1]) -> (AList t a2 -> [[a1]]) -> AList t a2 -> [a1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t a2 -> [a1]) -> [t a2] -> [[a1]]
forall a b. (a -> b) -> [a] -> [b]
map t a2 -> [a1]
f ([t a2] -> [[a1]])
-> (AList t a2 -> [t a2]) -> AList t a2 -> [[a1]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AList t a2 -> [t a2]
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' :: (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
  | gr a b -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
isEmpty gr a b
g = c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return c
u
  | Bool
otherwise = Context a b -> c -> m c
f Context a b
c (c -> m c) -> m c -> m c
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Context a b -> c -> m c) -> c -> gr a b -> m c
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') = gr a b -> (Context a b, gr a b)
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' :: (Context a b -> m (Context c d)) -> gr a b -> m (gr c d)
gmapM' Context a b -> m (Context c d)
f = (Context a b -> gr c d -> m (gr c d))
-> gr c d -> gr a b -> m (gr c d)
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 m (Context c d) -> (Context c d -> m (gr c d)) -> m (gr c d)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Context c d
c' -> gr c d -> m (gr c d)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context c d
c' Context c d -> gr c d -> gr c d
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr c d
g)) gr c d
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' :: (a -> m c) -> gr a b -> m (gr c b)
nmapM' a -> m c
f = (Context a b -> m (Context c b)) -> gr a b -> m (gr c b)
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 m c -> (c -> m (Context c b)) -> m (Context c b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ c
l' -> Context c b -> m (Context c b)
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: