{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Language.Fortran.Vars.ConstantPropagation
  ( constantPropagationValue
  , ValueOf
  )
where

import           Language.Fortran.Vars ( programFileModel )
import           Language.Fortran.Vars.Types
import           Language.Fortran.Vars.Kind
                                                ( getTypeKind )
import           Language.Fortran.Vars.Range
                                                ( Range
                                                , overlap
                                                , anyOverlap
                                                )
import           Language.Fortran.Vars.Eval.Deprecated.Operation
                                                ( valueToExpVal )
import           Language.Fortran.Vars.MemoryLocation
                                                ( generateLinearizedIndexRange )
import           Language.Fortran.Vars.CPValue
                                                ( CPValue(..)
                                                , meet
                                                , unaryOper
                                                , binaryOper
                                                , isTop
                                                , isBot
                                                , isConstInt
                                                )

import           Language.Fortran.AST
import           Language.Fortran.Analysis      ( BBGr(..)
                                                , Analysis(..)
                                                , srcName
                                                )
import           Language.Fortran.Util.Position ( SrcSpan
                                                , getSpan
                                                )
import           Language.Fortran.Analysis.BBlocks
                                                ( BBlockMap
                                                , genBBlockMap
                                                , analyseBBlocks
                                                )
import           Language.Fortran.Analysis.DataFlow
                                                ( InOutMap
                                                , dataFlowSolver
                                                , revPostOrder
                                                )
import qualified Data.Map                      as M
import qualified Data.IntMap                   as IM
import           Data.List                      ( foldl' )
import           Data.Graph.Inductive.Graph     ( Node
                                                , lab
                                                , pre
                                                , labNodes
                                                )
import           Data.Data                      ( Data )
import           Data.Generics.Uniplate.Data
import           Data.Maybe                     ( maybeToList
                                                , fromMaybe
                                                , fromJust
                                                )

-- | ValueOf is a closure that takes an 'Expression' and deduces its 'CPValue'
type ValueOf a = Expression (Analysis a) -> CPValue

-- | MemoryTable represents the determined memory state of a particular memory
-- block. It contains the mappings between a piece of memory and its 'CPValue'.
-- The piece of memory is represented by an inclusive range inside a 'MemoryBlock'
type MemoryTable = M.Map Range CPValue

-- | MemoryTables contains 'MemoryTable's for all 'MemoryBlock's
type MemoryTables = M.Map MemoryBlockName MemoryTable

-- | Collection of output of constant propagation analysis ('InOutMap' 'MemoryTables')
-- for each ProgramUnit
type MemoryTablesMap = M.Map ProgramUnitName (InOutMap MemoryTables)

-- | Given a 'SymbolTable', 'MemoryTables', a possible specification of the
-- beginning of the substring as well as one for the end, and the length of
-- the original string, generate the bounds that should be used for the
-- substring. If the bounds cannot be determined the extraction will return
-- 'Nothing'.
extractSubstringBounds
  :: SymbolTable
  -> MemoryTables
  -> Maybe (Expression (Analysis a))
  -> Maybe (Expression (Analysis a))
  -> Int
  -> Maybe (Int, Int)
extractSubstringBounds :: forall a.
SymbolTable
-> MemoryTables
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Offset
-> Maybe Range
extractSubstringBounds SymbolTable
symTable MemoryTables
memTables Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Offset
l =
  let f :: Offset -> Maybe (Expression (Analysis a)) -> Maybe Offset
f Offset
d Maybe (Expression (Analysis a))
m = case Maybe (Expression (Analysis a))
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Expression (Analysis a)
v -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
v of
        Maybe CPValue
Nothing              -> forall a. a -> Maybe a
Just Offset
d
        Just (Const (Int Offset
v)) -> forall a. a -> Maybe a
Just Offset
v
        Just CPValue
_               -> forall a. Maybe a
Nothing
  in  case (Offset -> Maybe (Expression (Analysis a)) -> Maybe Offset
f Offset
1 Maybe (Expression (Analysis a))
mb, Offset -> Maybe (Expression (Analysis a)) -> Maybe Offset
f Offset
l Maybe (Expression (Analysis a))
me) of
        (Just Offset
b, Just Offset
e) -> forall a. a -> Maybe a
Just (Offset
b, Offset
e)
        (Maybe Offset, Maybe Offset)
_                -> forall a. Maybe a
Nothing

-- | Given a 'SymbolTable', 'MemoryTables', the base 'Expression' of the substring,
-- any 'Index's that accompany the base, and possible the specifications for
-- the beginning and end of the substring, return the 'CPValue' of the substring.
substringCPValue
  :: SymbolTable
  -> MemoryTables
  -> Expression (Analysis a)
  -> [Index (Analysis a)]
  -> Maybe (Expression (Analysis a))
  -> Maybe (Expression (Analysis a))
  -> CPValue
substringCPValue :: forall a.
SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> CPValue
substringCPValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e [Index (Analysis a)]
is Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me =
  let name :: MemoryBlockName
name           = forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e
      isArraySection :: Bool
isArraySection = case forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable of
        (SVariable (TArray SemType
_ Dimensions
dims) Location
_) -> forall (t :: * -> *) a. Foldable t => t a -> Offset
length [Index (Analysis a)]
is forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => Dims t a -> Offset
dimsLength Dimensions
dims
        SymbolTableEntry
_                             -> Bool
False
  in  if Bool
isArraySection
        then forall {a}. a
errArraySection
        else case forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> CPValue
lookupArray SymbolTable
symTable MemoryTables
memTables MemoryBlockName
name [Index (Analysis a)]
is of
          CPValue
Top -> CPValue
Top
          CPValue
Bot -> CPValue
Bot
          Const (Str MemoryBlockName
s) ->
            case forall a.
SymbolTable
-> MemoryTables
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Offset
-> Maybe Range
extractSubstringBounds SymbolTable
symTable MemoryTables
memTables Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Offset
length MemoryBlockName
s of
              Just (Offset
b', Offset
e') ->
                ExpVal -> CPValue
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBlockName -> ExpVal
Str forall a b. (a -> b) -> a -> b
$ forall a. Offset -> [a] -> [a]
take (Offset
e' forall a. Num a => a -> a -> a
- Offset
b' forall a. Num a => a -> a -> a
+ Offset
1) forall a b. (a -> b) -> a -> b
$ forall a. Offset -> [a] -> [a]
drop (Offset
b' forall a. Num a => a -> a -> a
- Offset
1) MemoryBlockName
s
              Maybe Range
Nothing -> CPValue
Bot
          CPValue
_ -> forall {a}. a
errArraySection
  where
    errArraySection :: a
errArraySection = forall a. HasCallStack => MemoryBlockName -> a
error MemoryBlockName
"Array sections are not allowed in FORTRAN 77"

-- | Given 'SymbolTable', 'MemoryTables' and an 'Expression', determine the 'CPValue'
-- of the 'Expression'
cpValue :: SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue :: forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
expr = case Expression (Analysis a)
expr of
  ExpValue Analysis a
_ SrcSpan
_ ValVariable{} -> SymbolTable -> MemoryTables -> MemoryBlockName -> CPValue
lookupName SymbolTable
symTable MemoryTables
memTables forall a b. (a -> b) -> a -> b
$ forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
expr
  ExpValue Analysis a
_ SrcSpan
s Value (Analysis a)
val -> ExpVal -> CPValue
Const (forall a. SrcSpan -> Value a -> ExpVal
valueToExpVal SrcSpan
s Value (Analysis a)
val)
  ExpUnary Analysis a
_ SrcSpan
_ UnaryOp
op Expression (Analysis a)
e -> let v :: CPValue
v = forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e in UnaryOp -> CPValue -> CPValue
unaryOper UnaryOp
op CPValue
v
  ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
op Expression (Analysis a)
e1 Expression (Analysis a)
e2 ->
    let v1 :: CPValue
v1 = forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e1
        v2 :: CPValue
v2 = forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e2
    in  BinaryOp -> CPValue -> CPValue -> CPValue
binaryOper BinaryOp
op CPValue
v1 CPValue
v2
  ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} (AList Analysis a
_ SrcSpan
_ [IxRange Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Maybe (Expression (Analysis a))
_]) ->
    forall a.
SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> CPValue
substringCPValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e [] Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me
  ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} AList Index (Analysis a)
is ->
    forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> CPValue
lookupArray SymbolTable
symTable MemoryTables
memTables (forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Index (Analysis a)
is
  ExpSubscript Analysis a
_ SrcSpan
_ (ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} AList Index (Analysis a)
is) (AList Analysis a
_ SrcSpan
_ [IxRange Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Maybe (Expression (Analysis a))
_])
    -> forall a.
SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> CPValue
substringCPValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Index (Analysis a)
is) Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me
  ExpFunctionCall{} -> CPValue
Bot
  Expression (Analysis a)
_ -> forall a. HasCallStack => MemoryBlockName -> a
error forall a b. (a -> b) -> a -> b
$ MemoryBlockName
"Evaluation of the expression is not implemented - " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> MemoryBlockName
show
    (forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
expr)

-- | A piece of memory is represented as inclusive range indicating the start and
-- end offset of the memory within a memory block. This function is used for scalar
-- variable.
getVariableMemory :: SymbolTable -> Name -> Maybe (MemoryBlockName, Range)
getVariableMemory :: SymbolTable -> MemoryBlockName -> Maybe (MemoryBlockName, Range)
getVariableMemory SymbolTable
symTable MemoryBlockName
name = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable of
  -- Array pointer passed to subroutine/function (thus treated as 'ValVariable')
  Just (SVariable (TArray SemType
ty Dimensions
dims) (MemoryBlockName
memBlockName, Offset
offset)) -> do
    Offset
kind  <- SemType -> Maybe Offset
getTypeKind SemType
ty
    case forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
Dims t (f a) -> f (Dims t a)
dimsTraverse Dimensions
dims of
      Just (DimsExplicitShape NonEmpty (Dim Offset)
ds) ->
        forall a. a -> Maybe a
Just (MemoryBlockName
memBlockName, (Offset
offset, Offset
offset forall a. Num a => a -> a -> a
+ forall (t :: * -> *).
Foldable t =>
Offset -> t (Dim Offset) -> Offset
sizeOfArray Offset
kind NonEmpty (Dim Offset)
ds forall a. Num a => a -> a -> a
- Offset
1))
      Maybe (Dims NonEmpty Offset)
_ -> forall a. Maybe a
Nothing
  Just (SVariable SemType
ty (MemoryBlockName
memBlockName, Offset
offset)) -> do
    Offset
kind <- SemType -> Maybe Offset
getTypeKind SemType
ty
    forall a. a -> Maybe a
Just (MemoryBlockName
memBlockName, (Offset
offset, Offset
offset forall a. Num a => a -> a -> a
+ Offset
kind forall a. Num a => a -> a -> a
- Offset
1))
  Just SParameter{} -> forall a. Maybe a
Nothing
  Just SDummy{}     -> forall a. Maybe a
Nothing
  Maybe SymbolTableEntry
Nothing           -> forall a. Maybe a
Nothing
  Maybe SymbolTableEntry
_                 -> forall a. HasCallStack => MemoryBlockName -> a
error forall a b. (a -> b) -> a -> b
$ MemoryBlockName
"getVariableMemory -  not a variable : " forall a. [a] -> [a] -> [a]
++ MemoryBlockName
name

-- | Given a 'CPValue' without any present 'Bot' or 'Top'
-- 'CPValue's, convert to an 'Int'
unsafeStripIndexCP :: CPValue -> Int
unsafeStripIndexCP :: CPValue -> Offset
unsafeStripIndexCP (Const (Int Offset
i)) = Offset
i
unsafeStripIndexCP CPValue
_ = forall a. HasCallStack => MemoryBlockName -> a
error MemoryBlockName
"Expected no Top, Bot, nor non Int values"

-- | This data type describes the memory layout of an array's memory with
-- some additional qualification.
--
-- If any of the indices is unknown then the range of the array expression is
-- unknown. In this case 'UnknownIndices' variant is used with the range set
-- as the whole range of the array.
--
-- On the other hand, if indices are known constant, then the exact
-- range for the indices is used with the 'ConstantIndices' variant.
--
-- If the variable is a string declared as a scalar, the 'UnknownIndices' variant is
-- used with the range set to the size of the variable.
data ArrayMemory
  = UnknownIndices (MemoryBlockName, Range)
  | ConstantIndices (MemoryBlockName, Range)

-- | This function is used for array variable. It returns the range of the
-- specified element.
getArrayMemory
  :: SymbolTable
  -> MemoryTables
  -> Name
  -> [Index (Analysis a)]
  -> Maybe ArrayMemory
getArrayMemory :: forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
getArrayMemory SymbolTable
symTable MemoryTables
memTables MemoryBlockName
name [Index (Analysis a)]
indices =
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable of
      Maybe SymbolTableEntry
Nothing -> forall a. HasCallStack => MemoryBlockName -> a
error forall a b. (a -> b) -> a -> b
$ MemoryBlockName
"variable not in symbol table: "forall a. Semigroup a => a -> a -> a
<>MemoryBlockName
name
      Just SymbolTableEntry
entry ->
        case SymbolTableEntry
entry of
          SVariable SemType
ty (MemoryBlockName
memBlockName, Offset
start) ->
            case SemType
ty of
              TArray SemType
_ Dimensions
dims' ->
                case forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
Dims t (f a) -> f (Dims t a)
dimsTraverse Dimensions
dims' of -- only handle static
                  Just (DimsExplicitShape NonEmpty (Dim Offset)
dims)
                    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CPValue -> Bool
isBot [CPValue]
idxCPValues
                    -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
arrayRange
                    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CPValue -> Bool
isTop [CPValue]
idxCPValues
                    -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
arrayRange
                    | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CPValue -> Bool
isConstInt [CPValue]
idxCPValues)
                    -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
arrayRange
                    | Bool
otherwise
                    -> do
                      let is :: [Offset]
is = forall a b. (a -> b) -> [a] -> [b]
map CPValue -> Offset
unsafeStripIndexCP [CPValue]
idxCPValues
                      Range
range <- forall (t :: * -> *).
(Functor t, Foldable t) =>
[Offset] -> Offset -> t (Dim Offset) -> Offset -> Range
generateLinearizedIndexRange [Offset]
is Offset
start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty (Dim Offset)
dims forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Offset
kind
                      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (MemoryBlockName, Range) -> ArrayMemory
ConstantIndices (MemoryBlockName
memBlockName, Range
range)
                   where
                    kind :: Maybe Offset
kind       = SemType -> Maybe Offset
getTypeKind SemType
ty
                    size :: Maybe Offset
size       = forall (t :: * -> *).
Foldable t =>
Offset -> t (Dim Offset) -> Offset
sizeOfArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Offset
kind forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty (Dim Offset)
dims
                    arrayRange :: Maybe Range
arrayRange = (\Offset
x -> (Offset
start, Offset
start forall a. Num a => a -> a -> a
+ Offset
x forall a. Num a => a -> a -> a
- Offset
1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Offset
size

                  -- only handle explicit-shape arrays
                  Just{} -> forall a. Maybe a
Nothing
                  Maybe (Dims NonEmpty Offset)
Nothing -> forall a. Maybe a
Nothing
              SemType
_
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Index (Analysis a)]
indices -> (MemoryBlockName, Range) -> ArrayMemory
ConstantIndices forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
range
                | Bool
otherwise    -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
range
               where
                kind :: Maybe Offset
kind  = SemType -> Maybe Offset
getTypeKind SemType
ty
                range :: Maybe Range
range = (\Offset
x -> (Offset
start, Offset
start forall a. Num a => a -> a -> a
+ Offset
x forall a. Num a => a -> a -> a
- Offset
1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Offset
kind
          SymbolTableEntry
_ -> forall a. Maybe a
Nothing
  where
    idxCPValues :: [CPValue]
idxCPValues = forall a.
SymbolTable -> MemoryTables -> [Index (Analysis a)] -> [CPValue]
cpValueOfIndices SymbolTable
symTable MemoryTables
memTables [Index (Analysis a)]
indices

-- | Internal function to find 'CPValue' of a symbol
lookupName :: SymbolTable -> MemoryTables -> Name -> CPValue
lookupName :: SymbolTable -> MemoryTables -> MemoryBlockName -> CPValue
lookupName SymbolTable
symTable MemoryTables
memTables MemoryBlockName
name = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable of
  Just (SParameter SemType
_  ExpVal
val) -> ExpVal -> CPValue
Const ExpVal
val
  Just (SVariable  SemType
ty Location
loc) -> MemoryTables -> SemType -> Location -> CPValue
lookupScalarVariable MemoryTables
memTables SemType
ty Location
loc
  Just SDummy{}            -> CPValue
Bot
  Just SExternal{}         -> CPValue
Bot
  Maybe SymbolTableEntry
Nothing                  -> CPValue
Bot

-- | Internal function to find 'CPValue' of a scalar variable
lookupScalarVariable :: MemoryTables -> Type -> Location -> CPValue
lookupScalarVariable :: MemoryTables -> SemType -> Location -> CPValue
lookupScalarVariable MemoryTables
memTables SemType
ty Location
loc =
  let (MemoryBlockName
memBlockName, Offset
start) = Location
loc
      mkind :: Maybe Offset
mkind                 = SemType -> Maybe Offset
getTypeKind SemType
ty
      mrange :: Maybe Range
mrange                = (\Offset
x -> (Offset
start, Offset
start forall a. Num a => a -> a -> a
+ Offset
x forall a. Num a => a -> a -> a
- Offset
1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Offset
mkind
  in  case Maybe Range
mrange of
        Just Range
range -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
memBlockName MemoryTables
memTables of
          Just MemoryTable
memTbl -> Range -> MemoryTable -> CPValue
lookupRange Range
range MemoryTable
memTbl
          Maybe MemoryTable
Nothing     -> CPValue
Top
        Maybe Range
Nothing -> CPValue
Bot

-- | Internal fucntion to find 'CPValue' of an array element
lookupArray
  :: SymbolTable -> MemoryTables -> Name -> [Index (Analysis a)] -> CPValue
lookupArray :: forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> CPValue
lookupArray SymbolTable
symTable MemoryTables
memTables MemoryBlockName
name [Index (Analysis a)]
indices =
  case forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
getArrayMemory SymbolTable
symTable MemoryTables
memTables MemoryBlockName
name [Index (Analysis a)]
indices of
    Maybe ArrayMemory
Nothing                 -> CPValue
Bot
    Just (UnknownIndices (MemoryBlockName, Range)
_) -> CPValue
Bot
    Just (ConstantIndices (MemoryBlockName
memBlockName, Range
range)) ->
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
memBlockName MemoryTables
memTables of
        Just MemoryTable
memTbl -> Range -> MemoryTable -> CPValue
lookupRange Range
range MemoryTable
memTbl
        Maybe MemoryTable
Nothing     -> CPValue
Top

-- | Internal function to resovle the 'CPValue's of array indices
cpValueOfIndices
  :: SymbolTable -> MemoryTables -> [Index (Analysis a)] -> [CPValue]
cpValueOfIndices :: forall a.
SymbolTable -> MemoryTables -> [Index (Analysis a)] -> [CPValue]
cpValueOfIndices SymbolTable
symTable MemoryTables
memTables = forall a b. (a -> b) -> [a] -> [b]
map forall a. Index (Analysis a) -> CPValue
cpValueOfIndex
 where
  cpValueOfIndex :: Index (Analysis a) -> CPValue
  cpValueOfIndex :: forall a. Index (Analysis a) -> CPValue
cpValueOfIndex (IxSingle Analysis a
_ SrcSpan
_ Maybe MemoryBlockName
_ Expression (Analysis a)
e) = forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e
  cpValueOfIndex Index (Analysis a)
_ = forall a. HasCallStack => MemoryBlockName -> a
error MemoryBlockName
"Array sections are not allowed in FORTRAN 77"


-- | Internal function to look up the 'CPValue' of a 'Range'
lookupRange :: Range -> MemoryTable -> CPValue
lookupRange :: Range -> MemoryTable -> CPValue
lookupRange Range
range MemoryTable
memTable = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Range
range MemoryTable
memTable of
  Just CPValue
val -> CPValue
val
  Maybe CPValue
Nothing | Range -> [Range] -> Bool
anyOverlap Range
range (forall k a. Map k a -> [k]
M.keys MemoryTable
memTable) -> CPValue
Bot
  Maybe CPValue
_        -> CPValue
Top


-- | Constant Propagation Analysis
-- Given a 'ProgramUnitModel' and a control flow graph (basic blocks graph) of a
-- 'ProgramUnit', returns the In and Out 'MemoryTables' for each node in the graph
constantPropagationAnalysis
  :: ProgramUnitModel -> BBGr (Analysis a) -> InOutMap MemoryTables
constantPropagationAnalysis :: forall a.
ProgramUnitModel -> BBGr (Analysis a) -> InOutMap MemoryTables
constantPropagationAnalysis ProgramUnitModel
puModel BBGr (Analysis a)
gr = forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Offset -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver
  BBGr (Analysis a)
gr
  (forall a b. a -> b -> a
const (forall k a. Map k a
M.empty, forall k a. Map k a
M.empty))
  forall a. OrderF a
revPostOrder
  (Offset -> MemoryTables) -> Offset -> MemoryTables
inn
  (Offset -> MemoryTables) -> Offset -> MemoryTables
out
 where
  inn :: (Offset -> MemoryTables) -> Offset -> MemoryTables
inn Offset -> MemoryTables
outF Offset
b =
    forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith CPValue -> CPValue -> CPValue
meet) [ Offset -> MemoryTables
outF Offset
s | Offset
s <- forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Offset -> [Offset]
pre (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Offset
b ]
  out :: (Offset -> MemoryTables) -> Offset -> MemoryTables
out Offset -> MemoryTables
innF Offset
b = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a.
ProgramUnitModel
-> MemoryTables -> Block (Analysis a) -> MemoryTables
varDefine ProgramUnitModel
puModel)
                      (Offset -> MemoryTables
innF Offset
b)
                      (forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"constantPropagation" forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Offset -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Offset
b)

-- | Given 'MemoryTables', a 'MemoryBlockName', and a 'Range',
-- update that 'Range' to contain the specified 'CPValue'. If
-- the boolean argument is set to true, delete any values in
-- overlapping ranges
updateRangeValue
  :: MemoryTables -> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue :: MemoryTables
-> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue MemoryTables
memTables' MemoryBlockName
memBlockName Range
range CPValue
val Bool
filt =
  let rangeMap :: MemoryTable
rangeMap  = forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
M.empty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
memBlockName MemoryTables
memTables'
      rangeMap' :: MemoryTable
rangeMap' = if Bool
filt
        then forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Range
k CPValue
_ -> Bool -> Bool
not (Range -> Range -> Bool
overlap Range
k Range
range)) MemoryTable
rangeMap
        else MemoryTable
rangeMap
      newRangeMap :: MemoryTable
newRangeMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Range
range CPValue
val MemoryTable
rangeMap'
  in  forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MemoryBlockName
memBlockName MemoryTable
newRangeMap MemoryTables
memTables'

-- | Process the definition of a substring in a block and update
-- the substring's 'CPValue' in the corresponding 'MemoryTable'.
--
-- Aside from the 'SymbolTable' and 'MemoryTable', this
-- function requires the base 'Expression' of the substring
-- as well as any 'Index's that go along with that base,
-- possibly a specification of the beginning and end of the
-- array, and finally the 'Expression' that is being assigned.
substringDefine
  :: SymbolTable
  -> MemoryTables
  -> Expression (Analysis a)
  -> [Index (Analysis a)]
  -> Maybe (Expression (Analysis a))
  -> Maybe (Expression (Analysis a))
  -> Expression (Analysis a)
  -> MemoryTables
substringDefine :: forall a.
SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> MemoryTables
substringDefine SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e [Index (Analysis a)]
is Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Expression (Analysis a)
rhs =
  case forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
getArrayMemory SymbolTable
symTable MemoryTables
memTables (forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e) [Index (Analysis a)]
is of
    Maybe ArrayMemory
Nothing -> MemoryTables
memTables
    Just (UnknownIndices (MemoryBlockName
memBlockName, Range
wholeArrayRange)) ->
      let val :: CPValue
val = CPValue
Bot
      in  MemoryTables
-> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue MemoryTables
memTables MemoryBlockName
memBlockName Range
wholeArrayRange CPValue
val Bool
True
    Just (ConstantIndices (MemoryBlockName
memBlockName, Range
range)) ->
      let val :: CPValue
val = forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
rhs
          str :: CPValue
str = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
memBlockName MemoryTables
memTables of
            Just MemoryTable
memTbl -> Range -> MemoryTable -> CPValue
lookupRange Range
range MemoryTable
memTbl
            Maybe MemoryTable
Nothing     -> CPValue
Top
          val' :: CPValue
val' = case CPValue
val of
            Const (Str MemoryBlockName
s) -> case CPValue
str of
              Const (Str MemoryBlockName
o) ->
                case
                    forall a.
SymbolTable
-> MemoryTables
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Offset
-> Maybe Range
extractSubstringBounds SymbolTable
symTable MemoryTables
memTables Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Offset
length MemoryBlockName
o
                  of
                    Just (Offset
b', Offset
e') ->
                      let s' :: MemoryBlockName
s' = MemoryBlockName
s forall a. [a] -> [a] -> [a]
++ forall a. Offset -> a -> [a]
replicate (Offset
e' forall a. Num a => a -> a -> a
- Offset
b' forall a. Num a => a -> a -> a
+ Offset
1 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Offset
length MemoryBlockName
s) Char
' '
                      in  ExpVal -> CPValue
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBlockName -> ExpVal
Str forall a b. (a -> b) -> a -> b
$ forall a. Offset -> [a] -> [a]
take (Offset
b' forall a. Num a => a -> a -> a
- Offset
1) MemoryBlockName
o forall a. [a] -> [a] -> [a]
++ MemoryBlockName
s' forall a. [a] -> [a] -> [a]
++ forall a. Offset -> [a] -> [a]
drop Offset
e' MemoryBlockName
o
                    Maybe Range
Nothing -> CPValue
Bot
              CPValue
_ -> CPValue
Bot
            CPValue
_ -> CPValue
Bot
      in  MemoryTables
-> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue MemoryTables
memTables MemoryBlockName
memBlockName Range
range CPValue
val' Bool
True

-- | Process the definition of a variable in a block and update the
-- variable's 'CPValue' in the corresponding 'MemoryTable'.
varDefine
  :: ProgramUnitModel -> MemoryTables -> Block (Analysis a) -> MemoryTables
varDefine :: forall a.
ProgramUnitModel
-> MemoryTables -> Block (Analysis a) -> MemoryTables
varDefine (SymbolTable
symTable, StorageTable
storageTable) MemoryTables
memTables (BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StExpressionAssign Analysis a
_ SrcSpan
_ Expression (Analysis a)
lhs Expression (Analysis a)
rhs))
  | expr :: Expression (Analysis a)
expr@(ExpValue Analysis a
_ SrcSpan
_ ValVariable{}) <- Expression (Analysis a)
lhs
  , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
expr
  = let name :: MemoryBlockName
name = forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
expr
    in
      case SymbolTable -> MemoryBlockName -> Maybe (MemoryBlockName, Range)
getVariableMemory SymbolTable
symTable MemoryBlockName
name of
        Just (MemoryBlockName
memBlockName, range :: Range
range@(Offset
b, Offset
e)) ->
          let val :: CPValue
val = forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
rhs
          in
            case forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable of
              SVariable (TArray SemType
ty Dimensions
_) Location
_ ->
                let
                  kind :: Offset
kind =
                    forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => MemoryBlockName -> a
error forall a b. (a -> b) -> a -> b
$ MemoryBlockName
"Couldn't get kind of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> MemoryBlockName
show SemType
ty)
                      forall a b. (a -> b) -> a -> b
$ SemType -> Maybe Offset
getTypeKind SemType
ty
                  val' :: CPValue
val' = case CPValue
val of
                    Const (Str MemoryBlockName
s) -> ExpVal -> CPValue
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBlockName -> ExpVal
Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Offset -> a -> [a]
replicate Offset
kind forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null MemoryBlockName
s
                      then Char
' '
                      else forall a. [a] -> a
head MemoryBlockName
s
                    CPValue
_ -> CPValue
val
                  handler :: MemoryTables -> Range -> MemoryTables
handler MemoryTables
mt Range
range' =
                    MemoryTables
-> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue MemoryTables
mt MemoryBlockName
memBlockName Range
range' CPValue
val' Bool
True
                in
                  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' MemoryTables -> Range -> MemoryTables
handler
                         MemoryTables
memTables
                         [ (Offset
b', Offset
b' forall a. Num a => a -> a -> a
+ Offset
kind forall a. Num a => a -> a -> a
- Offset
1) | Offset
b' <- [Offset
b, Offset
b forall a. Num a => a -> a -> a
+ Offset
kind .. Offset
e] ]
              SymbolTableEntry
_ -> MemoryTables
-> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue MemoryTables
memTables MemoryBlockName
memBlockName Range
range CPValue
val Bool
True
        Maybe (MemoryBlockName, Range)
Nothing -> MemoryTables
memTables
  | ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} (AList Analysis a
_ SrcSpan
_ [IxRange Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Maybe (Expression (Analysis a))
_]) <- Expression (Analysis a)
lhs
  , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
e
  = forall a.
SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> MemoryTables
substringDefine SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e [] Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Expression (Analysis a)
rhs
  | ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} AList Index (Analysis a)
indices <- Expression (Analysis a)
lhs
  , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
e
  = case forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
getArrayMemory SymbolTable
symTable MemoryTables
memTables (forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e) (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Index (Analysis a)
indices) of
    Maybe ArrayMemory
Nothing -> MemoryTables
memTables
    Just (UnknownIndices (MemoryBlockName
memBlockName, Range
wholeArrayRange)) ->
      let val :: CPValue
val = CPValue
Bot
      in  MemoryTables
-> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue MemoryTables
memTables MemoryBlockName
memBlockName Range
wholeArrayRange CPValue
val Bool
True
    Just (ConstantIndices (MemoryBlockName
memBlockName, Range
range)) ->
      let val :: CPValue
val = forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
rhs
      in  MemoryTables
-> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables
updateRangeValue MemoryTables
memTables MemoryBlockName
memBlockName Range
range CPValue
val Bool
False
  | ExpSubscript Analysis a
_ SrcSpan
_ (ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} AList Index (Analysis a)
is) (AList Analysis a
_ SrcSpan
_ [IxRange Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Maybe (Expression (Analysis a))
_]) <-
    Expression (Analysis a)
lhs
  , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
e
  = forall a.
SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> MemoryTables
substringDefine SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Index (Analysis a)
is) Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Expression (Analysis a)
rhs
  | Bool
otherwise
  = MemoryTables
memTables
 where
  inCommon :: Expression (Analysis a) -> Bool
  inCommon :: forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
e = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e) SymbolTable
symTable of
    Just (SVariable SemType
_ (MemoryBlockName
memBlockName, Offset
_)) ->
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
memBlockName StorageTable
storageTable of
        Just MemoryBlock
memBlock -> MemoryBlock -> StorageClass
storageClass MemoryBlock
memBlock forall a. Eq a => a -> a -> Bool
== StorageClass
Common
        Maybe MemoryBlock
_             -> Bool
False
    Maybe SymbolTableEntry
_ -> Bool
False

varDefine ProgramUnitModel
_ MemoryTables
memTables Block (Analysis a)
_ = MemoryTables
memTables


-- | ExpressionContext represents the block, basic block and 'ProgramUnit'
-- in which an expression is located
type ExpressionContext = (Node, Node, ProgramUnitName)

-- | Mapping from expression source span to 'ExpressionContext'
type ExpressionContextMap = M.Map SrcSpan ExpressionContext


-- | Look up the 'ExpressionContext' of an 'Expression'
lookupExpressionContext
  :: Data a => Expression a -> ExpressionContextMap -> ExpressionContext
lookupExpressionContext :: forall a.
Data a =>
Expression a -> ExpressionContextMap -> ExpressionContext
lookupExpressionContext Expression a
expr ExpressionContextMap
exprCxtMap =
  let s :: SrcSpan
s   = forall a. Spanned a => a -> SrcSpan
getSpan Expression a
expr
      err :: MemoryBlockName
err = MemoryBlockName
"Lookup Expression Context at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> MemoryBlockName
show SrcSpan
s
  in  forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
err forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SrcSpan
s ExpressionContextMap
exprCxtMap

-- | Given 'BBlockMap', generates 'ExpressionContextMap'
genExpressionContextMap
  :: Data a => BBlockMap (Analysis a) -> ExpressionContextMap
genExpressionContextMap :: forall a. Data a => BBlockMap (Analysis a) -> ExpressionContextMap
genExpressionContextMap BBlockMap (Analysis a)
bblockMap =
  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
    forall a b. (a -> b) -> a -> b
$ [ (forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
expr, (Offset
bl, Offset
bbl, ProgramUnitName
pu))
      | (ProgramUnitName
pu , BBGr (Analysis a)
gr        ) <- forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bblockMap
      , (Offset
bbl, BB (Analysis a)
basicBlock) <- forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr)
      , Block (Analysis a)
block             <- BB (Analysis a)
basicBlock
      , Offset
bl                <- forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (b :: * -> *).
(Data a, Data (b (Analysis a)), Annotated b) =>
b (Analysis a) -> Maybe Offset
label forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
block
      , Expression (Analysis a)
expr              <- forall a. Data a => Block (Analysis a) -> [Expression (Analysis a)]
allExp Block (Analysis a)
block
      ]
 where
  allExp :: Data a => Block (Analysis a) -> [Expression (Analysis a)]
  allExp :: forall a. Data a => Block (Analysis a) -> [Expression (Analysis a)]
allExp = forall from to. Biplate from to => from -> [to]
universeBi


-- | Determine the 'CPValue' of an expression in a 'ProgramUnit' using constant
-- propagation analysis
--
-- Input:
--
--   * 'ProgramUnitModel'
--   * 'BBGr' -  Control Flow Graph of Basic Blocks
--   * 'InOutMap' 'MemoryTables' - generated by constantPropagationAnalysis
--   * 'ExpressionContextMap' - to identify the block and basic block of the input expression
--   * 'Expression'
--
-- Output:
--
--   * 'CPValue'
--
-- Description:
--
--   The control flow graph and the associated In and Out 'MemoryTables' are at the
--   level of Basic Block, which is coarse-grained with regard to Expression.
--   The memory state at the beginning of basic block may not represent
--   the memory state at the site of the expression. To get more precise determination
--   of value, the 'MemoryTables' is updated by processing each blocks preceding
--   the enclosing block of input expression.
--
--   The updated 'MemoryTables' is then used to determine the value of the 'Expression'.
constantPropagationValuePU
  :: Data a
  => ProgramUnitModel
  -> BBGr (Analysis a)
  -> InOutMap MemoryTables
  -> ExpressionContext
  -> Expression (Analysis a)
  -> CPValue
constantPropagationValuePU :: forall a.
Data a =>
ProgramUnitModel
-> BBGr (Analysis a)
-> InOutMap MemoryTables
-> ExpressionContext
-> Expression (Analysis a)
-> CPValue
constantPropagationValuePU puModel :: ProgramUnitModel
puModel@(SymbolTable
symTable, StorageTable
_) BBGr (Analysis a)
gr InOutMap MemoryTables
memTables ExpressionContext
exprCxt Expression (Analysis a)
expr =
  let
    (Offset
expBlock, Offset
expBBlock, ProgramUnitName
_) = ExpressionContext
exprCxt
    bblock :: BB (Analysis a)
bblock = forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Basic Block" forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Offset -> Maybe a
lab (forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Offset
expBBlock
    precedingBlocks :: BB (Analysis a)
precedingBlocks = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Block (Analysis a)
b -> forall a. HasCallStack => Maybe a -> a
fromJust (forall a (b :: * -> *).
(Data a, Data (b (Analysis a)), Annotated b) =>
b (Analysis a) -> Maybe Offset
label Block (Analysis a)
b) forall a. Eq a => a -> a -> Bool
/= Offset
expBlock) BB (Analysis a)
bblock
    inBBMemoryTables :: MemoryTables
inBBMemoryTables = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Cannot find MemoryTables" forall a b. (a -> b) -> a -> b
$ forall a. Offset -> IntMap a -> Maybe a
IM.lookup
      Offset
expBBlock
      InOutMap MemoryTables
memTables
    inBlockMemoryTables :: MemoryTables
inBlockMemoryTables =
      forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a.
ProgramUnitModel
-> MemoryTables -> Block (Analysis a) -> MemoryTables
varDefine ProgramUnitModel
puModel) MemoryTables
inBBMemoryTables BB (Analysis a)
precedingBlocks
  in
    forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
inBlockMemoryTables Expression (Analysis a)
expr

-- | Internal function to determine the 'CPValue' of an expression in a 'ProgramFile'
-- using constantpropagation analysis
constantPropagationValuePF
  :: Data a
  => ProgramFileModel
  -> BBlockMap (Analysis a)
  -> MemoryTablesMap
  -> ExpressionContextMap
  -> Expression (Analysis a)
  -> CPValue
constantPropagationValuePF :: forall a.
Data a =>
ProgramFileModel
-> BBlockMap (Analysis a)
-> MemoryTablesMap
-> ExpressionContextMap
-> Expression (Analysis a)
-> CPValue
constantPropagationValuePF ProgramFileModel
pfModel BBlockMap (Analysis a)
bbgraphs MemoryTablesMap
memTablesMap ExpressionContextMap
exprCtxMap Expression (Analysis a)
expr =
  let exprCtx :: ExpressionContext
exprCtx@(Offset
_, Offset
_, ProgramUnitName
unitName) = forall a.
Data a =>
Expression a -> ExpressionContextMap -> ExpressionContext
lookupExpressionContext Expression (Analysis a)
expr ExpressionContextMap
exprCtxMap
      puModel :: ProgramUnitModel
puModel = forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find SymbolTable" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
unitName ProgramFileModel
pfModel
      controlFlowGraph :: BBGr (Analysis a)
controlFlowGraph =
          forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find basic block graph" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
unitName BBlockMap (Analysis a)
bbgraphs
      memTables :: InOutMap MemoryTables
memTables = forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find MemTables" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
unitName MemoryTablesMap
memTablesMap
  in  forall a.
Data a =>
ProgramUnitModel
-> BBGr (Analysis a)
-> InOutMap MemoryTables
-> ExpressionContext
-> Expression (Analysis a)
-> CPValue
constantPropagationValuePU ProgramUnitModel
puModel BBGr (Analysis a)
controlFlowGraph InOutMap MemoryTables
memTables ExpressionContext
exprCtx Expression (Analysis a)
expr


-- | Given a 'ProgramFile', return 'ValueOf' closure, which determines
-- whether given 'Expression' can be evaluated statically to a constant value using
-- constant propagation analysis.
--
-- Usage:
--   The best approach is to create a closure first as illustrated in the following
--   code example, so only one run of constant propragation analysis is performed
--   for a 'ProgramFile'.
--
--   @
--   let cpValueOf = constantPropagationValue pf
--   ...
--   in
--       ...
--       cpVauleOf e1
--       cpValueOf e2
--   @
constantPropagationValue :: Data a => ProgramFile (Analysis a) -> ValueOf a
constantPropagationValue :: forall a. Data a => ProgramFile (Analysis a) -> ValueOf a
constantPropagationValue ProgramFile (Analysis a)
pf =
  let pfb :: ProgramFile (Analysis a)
pfb      = forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks ProgramFile (Analysis a)
pf
      pfModel :: ProgramFileModel
pfModel  = forall a. Data a => ProgramFile (Analysis a) -> ProgramFileModel
programFileModel ProgramFile (Analysis a)
pfb
      bbgraphs :: BBlockMap (Analysis a)
bbgraphs = forall a.
Data a =>
ProgramFile (Analysis a) -> BBlockMap (Analysis a)
genBBlockMap ProgramFile (Analysis a)
pfb
      mapFunc :: ProgramUnitName -> BBGr (Analysis a) -> InOutMap MemoryTables
mapFunc ProgramUnitName
puName BBGr (Analysis a)
controlFlowGraph =
          let puModel :: ProgramUnitModel
puModel =
                  forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find ProgramUnitModel" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
puName ProgramFileModel
pfModel
          in  forall a.
ProgramUnitModel -> BBGr (Analysis a) -> InOutMap MemoryTables
constantPropagationAnalysis ProgramUnitModel
puModel BBGr (Analysis a)
controlFlowGraph
      memTablesMap :: MemoryTablesMap
memTablesMap = forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey ProgramUnitName -> BBGr (Analysis a) -> InOutMap MemoryTables
mapFunc BBlockMap (Analysis a)
bbgraphs
      exprCtxMap :: ExpressionContextMap
exprCtxMap   = forall a. Data a => BBlockMap (Analysis a) -> ExpressionContextMap
genExpressionContextMap BBlockMap (Analysis a)
bbgraphs
  in  forall a.
Data a =>
ProgramFileModel
-> BBlockMap (Analysis a)
-> MemoryTablesMap
-> ExpressionContextMap
-> Expression (Analysis a)
-> CPValue
constantPropagationValuePF ProgramFileModel
pfModel BBlockMap (Analysis a)
bbgraphs MemoryTablesMap
memTablesMap ExpressionContextMap
exprCtxMap

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

-- | 'Language.Fortran.Analysis.BBlocks.analyseBBlocks' annotates the 'Block'
-- and 'Expression' AST node with unique integer label. This function retrieves
-- the label from an AST node if the label exsits.
label
  :: forall a b
   . (Data a, Data (b (Analysis a)), Annotated b)
  => b (Analysis a)
  -> Maybe Int
label :: forall a (b :: * -> *).
(Data a, Data (b (Analysis a)), Annotated b) =>
b (Analysis a) -> Maybe Offset
label = forall a. Analysis a -> Maybe Offset
insLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation

-- | Given kind and dimensions, calculate the size of an array
sizeOfArray :: Foldable t => Int -> t (Dim Int) -> Int
sizeOfArray :: forall (t :: * -> *).
Foldable t =>
Offset -> t (Dim Offset) -> Offset
sizeOfArray Offset
kind t (Dim Offset)
dims = Offset
kind forall a. Num a => a -> a -> a
* Offset
arraySize
  where
    arraySize :: Offset
arraySize = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Offset
acc (Dim Offset
l Offset
h) -> Offset
acc forall a. Num a => a -> a -> a
* (Offset
h forall a. Num a => a -> a -> a
- Offset
l forall a. Num a => a -> a -> a
+ Offset
1)) Offset
1 t (Dim Offset)
dims