{-# 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.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))
-> Int
-> Maybe Range
extractSubstringBounds SymbolTable
symTable MemoryTables
memTables Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me Int
l =
  let f :: Int -> Maybe (Expression (Analysis a)) -> Maybe Int
f Int
d Maybe (Expression (Analysis a))
m = case Maybe (Expression (Analysis a))
m Maybe (Expression (Analysis a))
-> (Expression (Analysis a) -> Maybe CPValue) -> Maybe CPValue
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Expression (Analysis a)
v -> CPValue -> Maybe CPValue
forall a. a -> Maybe a
Just (CPValue -> Maybe CPValue) -> CPValue -> Maybe CPValue
forall a b. (a -> b) -> a -> b
$ SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
v of
        Maybe CPValue
Nothing              -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
d
        Just (Const (Int Int
v)) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
v
        Just CPValue
_               -> Maybe Int
forall a. Maybe a
Nothing
  in  case (Int -> Maybe (Expression (Analysis a)) -> Maybe Int
forall {a}. Int -> Maybe (Expression (Analysis a)) -> Maybe Int
f Int
1 Maybe (Expression (Analysis a))
mb, Int -> Maybe (Expression (Analysis a)) -> Maybe Int
forall {a}. Int -> Maybe (Expression (Analysis a)) -> Maybe Int
f Int
l Maybe (Expression (Analysis a))
me) of
        (Just Int
b, Just Int
e) -> Range -> Maybe Range
forall a. a -> Maybe a
Just (Int
b, Int
e)
        (Maybe Int, Maybe Int)
_                -> Maybe Range
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 errStr :: MemoryBlockName
errStr         = MemoryBlockName
"Array sections are not allowed in FORTRAN 77"
      name :: MemoryBlockName
name           = Expression (Analysis a) -> MemoryBlockName
forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e
      isArraySection :: Bool
isArraySection = case Maybe SymbolTableEntry -> SymbolTableEntry
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SymbolTableEntry -> SymbolTableEntry)
-> Maybe SymbolTableEntry -> SymbolTableEntry
forall a b. (a -> b) -> a -> b
$ MemoryBlockName -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable of
        (SVariable (TArray SemType
_ Maybe Dimensions
dims) Location
_) -> [Index (Analysis a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Index (Analysis a)]
is Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe Dimensions -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe Dimensions
dims
        SymbolTableEntry
_                             -> Bool
False
  in  if Bool
isArraySection
        then MemoryBlockName -> CPValue
forall a. HasCallStack => MemoryBlockName -> a
error MemoryBlockName
errStr
        else case SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> CPValue
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 SymbolTable
-> MemoryTables
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Int
-> Maybe Range
forall a.
SymbolTable
-> MemoryTables
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Int
-> Maybe Range
extractSubstringBounds SymbolTable
symTable MemoryTables
memTables Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me (Int -> Maybe Range) -> Int -> Maybe Range
forall a b. (a -> b) -> a -> b
$ MemoryBlockName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length MemoryBlockName
s of
              Just (Int
b', Int
e') ->
                ExpVal -> CPValue
Const (ExpVal -> CPValue)
-> (MemoryBlockName -> ExpVal) -> MemoryBlockName -> CPValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBlockName -> ExpVal
Str (MemoryBlockName -> CPValue) -> MemoryBlockName -> CPValue
forall a b. (a -> b) -> a -> b
$ Int -> MemoryBlockName -> MemoryBlockName
forall a. Int -> [a] -> [a]
take (Int
e' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (MemoryBlockName -> MemoryBlockName)
-> MemoryBlockName -> MemoryBlockName
forall a b. (a -> b) -> a -> b
$ Int -> MemoryBlockName -> MemoryBlockName
forall a. Int -> [a] -> [a]
drop (Int
b' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) MemoryBlockName
s
              Maybe Range
Nothing -> CPValue
Bot
          CPValue
_ -> MemoryBlockName -> CPValue
forall a. HasCallStack => MemoryBlockName -> a
error MemoryBlockName
errStr

-- | 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 (MemoryBlockName -> CPValue) -> MemoryBlockName -> CPValue
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a) -> MemoryBlockName
forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
expr
  ExpValue Analysis a
_ SrcSpan
s Value (Analysis a)
val -> ExpVal -> CPValue
Const (SrcSpan -> Value (Analysis a) -> ExpVal
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 = SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
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 = SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e1
        v2 :: CPValue
v2 = SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
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))
_]) ->
    SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> CPValue
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 ->
    SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> CPValue
forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> CPValue
lookupArray SymbolTable
symTable MemoryTables
memTables (Expression (Analysis a) -> MemoryBlockName
forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e) ([Index (Analysis a)] -> CPValue)
-> [Index (Analysis a)] -> CPValue
forall a b. (a -> b) -> a -> b
$ AList Index (Analysis a) -> [Index (Analysis a)]
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))
_])
    -> SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> CPValue
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 (AList Index (Analysis a) -> [Index (Analysis a)]
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)
_ -> MemoryBlockName -> CPValue
forall a. HasCallStack => MemoryBlockName -> a
error (MemoryBlockName -> CPValue) -> MemoryBlockName -> CPValue
forall a b. (a -> b) -> a -> b
$ MemoryBlockName
"Evaluation of the expression is not implemented - " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ SrcSpan -> MemoryBlockName
forall a. Show a => a -> MemoryBlockName
show
    (Expression (Analysis a) -> SrcSpan
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 MemoryBlockName -> SymbolTable -> Maybe SymbolTableEntry
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 Maybe Dimensions
dims) (MemoryBlockName
memBlockName, Int
offset)) -> do
    Int
kind  <- SemType -> Maybe Int
getTypeKind SemType
ty
    Dimensions
dims' <- Maybe Dimensions
dims
    (MemoryBlockName, Range) -> Maybe (MemoryBlockName, Range)
forall a. a -> Maybe a
Just (MemoryBlockName
memBlockName, (Int
offset, Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Dimensions -> Int
sizeOfArray Int
kind Dimensions
dims' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  Just (SVariable SemType
ty (MemoryBlockName
memBlockName, Int
offset)) -> do
    Int
kind <- SemType -> Maybe Int
getTypeKind SemType
ty
    (MemoryBlockName, Range) -> Maybe (MemoryBlockName, Range)
forall a. a -> Maybe a
Just (MemoryBlockName
memBlockName, (Int
offset, Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kind Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
  Just SParameter{} -> Maybe (MemoryBlockName, Range)
forall a. Maybe a
Nothing
  Just SDummy{}     -> Maybe (MemoryBlockName, Range)
forall a. Maybe a
Nothing
  Maybe SymbolTableEntry
Nothing           -> Maybe (MemoryBlockName, Range)
forall a. Maybe a
Nothing
  Maybe SymbolTableEntry
_                 -> MemoryBlockName -> Maybe (MemoryBlockName, Range)
forall a. HasCallStack => MemoryBlockName -> a
error (MemoryBlockName -> Maybe (MemoryBlockName, Range))
-> MemoryBlockName -> Maybe (MemoryBlockName, Range)
forall a b. (a -> b) -> a -> b
$ MemoryBlockName
"getVariableMemory -  not a variable : " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
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 -> Int
unsafeStripIndexCP (Const (Int Int
i)) = Int
i
unsafeStripIndexCP CPValue
_ = MemoryBlockName -> Int
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 =
  let Just SymbolTableEntry
entry  = MemoryBlockName -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable
      idxCPValues :: [CPValue]
idxCPValues = SymbolTable -> MemoryTables -> [Index (Analysis a)] -> [CPValue]
forall a.
SymbolTable -> MemoryTables -> [Index (Analysis a)] -> [CPValue]
cpValueOfIndices SymbolTable
symTable MemoryTables
memTables [Index (Analysis a)]
indices
  in  case SymbolTableEntry
entry of
        SVariable (TArray SemType
ty Maybe Dimensions
dims) (MemoryBlockName
memBlockName, Int
start)
          | (CPValue -> Bool) -> [CPValue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CPValue -> Bool
isBot [CPValue]
idxCPValues
          -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices ((MemoryBlockName, Range) -> ArrayMemory)
-> (Range -> (MemoryBlockName, Range)) -> Range -> ArrayMemory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) (Range -> ArrayMemory) -> Maybe Range -> Maybe ArrayMemory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
arrayRange
          | (CPValue -> Bool) -> [CPValue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CPValue -> Bool
isTop [CPValue]
idxCPValues
          -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices ((MemoryBlockName, Range) -> ArrayMemory)
-> (Range -> (MemoryBlockName, Range)) -> Range -> ArrayMemory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) (Range -> ArrayMemory) -> Maybe Range -> Maybe ArrayMemory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
arrayRange
          | Bool -> Bool
not ((CPValue -> Bool) -> [CPValue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CPValue -> Bool
isConstInt [CPValue]
idxCPValues)
          -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices ((MemoryBlockName, Range) -> ArrayMemory)
-> (Range -> (MemoryBlockName, Range)) -> Range -> ArrayMemory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) (Range -> ArrayMemory) -> Maybe Range -> Maybe ArrayMemory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
arrayRange
          | Bool
otherwise
          -> do
            let is :: [Int]
is = (CPValue -> Int) -> [CPValue] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CPValue -> Int
unsafeStripIndexCP [CPValue]
idxCPValues
            Range
range <- [Int] -> Int -> Dimensions -> Int -> Range
generateLinearizedIndexRange [Int]
is Int
start (Dimensions -> Int -> Range)
-> Maybe Dimensions -> Maybe (Int -> Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Dimensions
dims Maybe (Int -> Range) -> Maybe Int -> Maybe Range
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
kind
            ArrayMemory -> Maybe ArrayMemory
forall a. a -> Maybe a
Just (ArrayMemory -> Maybe ArrayMemory)
-> ArrayMemory -> Maybe ArrayMemory
forall a b. (a -> b) -> a -> b
$ (MemoryBlockName, Range) -> ArrayMemory
ConstantIndices (MemoryBlockName
memBlockName, Range
range)
         where
          kind :: Maybe Int
kind       = SemType -> Maybe Int
getTypeKind SemType
ty
          size :: Maybe Int
size       = Int -> Dimensions -> Int
sizeOfArray (Int -> Dimensions -> Int)
-> Maybe Int -> Maybe (Dimensions -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
kind Maybe (Dimensions -> Int) -> Maybe Dimensions -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Dimensions
dims
          arrayRange :: Maybe Range
arrayRange = (\Int
x -> (Int
start, Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Int -> Range) -> Maybe Int -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
size
        SVariable SemType
ty (MemoryBlockName
memBlockName, Int
start)
          | [Index (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Index (Analysis a)]
indices -> (MemoryBlockName, Range) -> ArrayMemory
ConstantIndices ((MemoryBlockName, Range) -> ArrayMemory)
-> (Range -> (MemoryBlockName, Range)) -> Range -> ArrayMemory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) (Range -> ArrayMemory) -> Maybe Range -> Maybe ArrayMemory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
range
          | Bool
otherwise    -> (MemoryBlockName, Range) -> ArrayMemory
UnknownIndices ((MemoryBlockName, Range) -> ArrayMemory)
-> (Range -> (MemoryBlockName, Range)) -> Range -> ArrayMemory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemoryBlockName
memBlockName, ) (Range -> ArrayMemory) -> Maybe Range -> Maybe ArrayMemory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Range
range
         where
          kind :: Maybe Int
kind  = SemType -> Maybe Int
getTypeKind SemType
ty
          range :: Maybe Range
range = (\Int
x -> (Int
start, Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Int -> Range) -> Maybe Int -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
kind
        SymbolTableEntry
_ -> Maybe ArrayMemory
forall a. Maybe a
Nothing

-- | 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 MemoryBlockName -> SymbolTable -> Maybe SymbolTableEntry
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, Int
start) = Location
loc
      mkind :: Maybe Int
mkind                 = SemType -> Maybe Int
getTypeKind SemType
ty
      mrange :: Maybe Range
mrange                = (\Int
x -> (Int
start, Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Int -> Range) -> Maybe Int -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
mkind
  in  case Maybe Range
mrange of
        Just Range
range -> case MemoryBlockName -> MemoryTables -> Maybe MemoryTable
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 SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
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 MemoryBlockName -> MemoryTables -> Maybe MemoryTable
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 = (Index (Analysis a) -> CPValue)
-> [Index (Analysis a)] -> [CPValue]
forall a b. (a -> b) -> [a] -> [b]
map Index (Analysis a) -> CPValue
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) = SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
e
  cpValueOfIndex Index (Analysis a)
_ = MemoryBlockName -> CPValue
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 Range -> MemoryTable -> Maybe CPValue
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 -> Dimensions -> Bool
anyOverlap Range
range (MemoryTable -> Dimensions
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 = BBGr (Analysis a)
-> (Int -> InOut MemoryTables)
-> OrderF (Analysis a)
-> (OutF MemoryTables -> OutF MemoryTables)
-> (OutF MemoryTables -> OutF MemoryTables)
-> InOutMap MemoryTables
forall t a.
(NFData t, Ord t) =>
BBGr a
-> (Int -> InOut t)
-> OrderF a
-> (OutF t -> OutF t)
-> (OutF t -> OutF t)
-> InOutMap t
dataFlowSolver
  BBGr (Analysis a)
gr
  (InOut MemoryTables -> Int -> InOut MemoryTables
forall a b. a -> b -> a
const (MemoryTables
forall k a. Map k a
M.empty, MemoryTables
forall k a. Map k a
M.empty))
  OrderF (Analysis a)
forall a. OrderF a
revPostOrder
  OutF MemoryTables -> OutF MemoryTables
forall {k} {k}.
(Ord k, Ord k) =>
(Int -> Map k (Map k CPValue)) -> Int -> Map k (Map k CPValue)
inn
  OutF MemoryTables -> OutF MemoryTables
out
 where
  inn :: (Int -> Map k (Map k CPValue)) -> Int -> Map k (Map k CPValue)
inn Int -> Map k (Map k CPValue)
outF Int
b =
    (Map k CPValue -> Map k CPValue -> Map k CPValue)
-> [Map k (Map k CPValue)] -> Map k (Map k CPValue)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith ((CPValue -> CPValue -> CPValue)
-> Map k CPValue -> Map k CPValue -> Map k CPValue
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith CPValue -> CPValue -> CPValue
meet) [ Int -> Map k (Map k CPValue)
outF Int
s | Int
s <- Gr (BB (Analysis a)) () -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
pre (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b ]
  out :: OutF MemoryTables -> OutF MemoryTables
out OutF MemoryTables
innF Int
b = (MemoryTables -> Block (Analysis a) -> MemoryTables)
-> MemoryTables -> BB (Analysis a) -> MemoryTables
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (ProgramUnitModel
-> MemoryTables -> Block (Analysis a) -> MemoryTables
forall a.
ProgramUnitModel
-> MemoryTables -> Block (Analysis a) -> MemoryTables
varDefine ProgramUnitModel
puModel)
                      (OutF MemoryTables
innF Int
b)
                      (MemoryBlockName -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"constantPropagation" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Int -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
b)

-- | 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  = MemoryTable -> Maybe MemoryTable -> MemoryTable
forall a. a -> Maybe a -> a
fromMaybe MemoryTable
forall k a. Map k a
M.empty (Maybe MemoryTable -> MemoryTable)
-> Maybe MemoryTable -> MemoryTable
forall a b. (a -> b) -> a -> b
$ MemoryBlockName -> MemoryTables -> Maybe MemoryTable
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
memBlockName MemoryTables
memTables'
      rangeMap' :: MemoryTable
rangeMap' = if Bool
filt
        then (Range -> CPValue -> Bool) -> MemoryTable -> MemoryTable
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 = Range -> CPValue -> MemoryTable -> MemoryTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Range
range CPValue
val MemoryTable
rangeMap'
  in  MemoryBlockName -> MemoryTable -> MemoryTables -> MemoryTables
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 SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
getArrayMemory SymbolTable
symTable MemoryTables
memTables (Expression (Analysis a) -> MemoryBlockName
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 = SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
rhs
          str :: CPValue
str = case MemoryBlockName -> MemoryTables -> Maybe MemoryTable
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
                    SymbolTable
-> MemoryTables
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Int
-> Maybe Range
forall a.
SymbolTable
-> MemoryTables
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Int
-> Maybe Range
extractSubstringBounds SymbolTable
symTable MemoryTables
memTables Maybe (Expression (Analysis a))
mb Maybe (Expression (Analysis a))
me (Int -> Maybe Range) -> Int -> Maybe Range
forall a b. (a -> b) -> a -> b
$ MemoryBlockName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length MemoryBlockName
o
                  of
                    Just (Int
b', Int
e') ->
                      let s' :: MemoryBlockName
s' = MemoryBlockName
s MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ Int -> Char -> MemoryBlockName
forall a. Int -> a -> [a]
replicate (Int
e' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- MemoryBlockName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length MemoryBlockName
s) Char
' '
                      in  ExpVal -> CPValue
Const (ExpVal -> CPValue)
-> (MemoryBlockName -> ExpVal) -> MemoryBlockName -> CPValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBlockName -> ExpVal
Str (MemoryBlockName -> CPValue) -> MemoryBlockName -> CPValue
forall a b. (a -> b) -> a -> b
$ Int -> MemoryBlockName -> MemoryBlockName
forall a. Int -> [a] -> [a]
take (Int
b' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) MemoryBlockName
o MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ MemoryBlockName
s' MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ Int -> MemoryBlockName -> MemoryBlockName
forall a. Int -> [a] -> [a]
drop Int
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a) -> Bool
forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
expr
  = let name :: MemoryBlockName
name = Expression (Analysis a) -> MemoryBlockName
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@(Int
b, Int
e)) ->
          let val :: CPValue
val = SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
forall a.
SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
cpValue SymbolTable
symTable MemoryTables
memTables Expression (Analysis a)
rhs
          in
            case Maybe SymbolTableEntry -> SymbolTableEntry
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SymbolTableEntry -> SymbolTableEntry)
-> Maybe SymbolTableEntry -> SymbolTableEntry
forall a b. (a -> b) -> a -> b
$ MemoryBlockName -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
name SymbolTable
symTable of
              SVariable (TArray SemType
ty Maybe Dimensions
_) Location
_ ->
                let
                  kind :: Int
kind =
                    Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (MemoryBlockName -> Int
forall a. HasCallStack => MemoryBlockName -> a
error (MemoryBlockName -> Int) -> MemoryBlockName -> Int
forall a b. (a -> b) -> a -> b
$ MemoryBlockName
"Couldn't get kind of type " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. Semigroup a => a -> a -> a
<> SemType -> MemoryBlockName
forall a. Show a => a -> MemoryBlockName
show SemType
ty)
                      (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe Int
getTypeKind SemType
ty
                  val' :: CPValue
val' = case CPValue
val of
                    Const (Str MemoryBlockName
s) -> ExpVal -> CPValue
Const (ExpVal -> CPValue) -> (Char -> ExpVal) -> Char -> CPValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBlockName -> ExpVal
Str (MemoryBlockName -> ExpVal)
-> (Char -> MemoryBlockName) -> Char -> ExpVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> MemoryBlockName
forall a. Int -> a -> [a]
replicate Int
kind (Char -> CPValue) -> Char -> CPValue
forall a b. (a -> b) -> a -> b
$ if MemoryBlockName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MemoryBlockName
s
                      then Char
' '
                      else MemoryBlockName -> Char
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
                  (MemoryTables -> Range -> MemoryTables)
-> MemoryTables -> Dimensions -> MemoryTables
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' MemoryTables -> Range -> MemoryTables
handler
                         MemoryTables
memTables
                         [ (Int
b', Int
b' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kind Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) | Int
b' <- [Int
b, Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kind .. Int
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a) -> Bool
forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
e
  = SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> MemoryTables
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a) -> Bool
forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
e
  = case SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
forall a.
SymbolTable
-> MemoryTables
-> MemoryBlockName
-> [Index (Analysis a)]
-> Maybe ArrayMemory
getArrayMemory SymbolTable
symTable MemoryTables
memTables (Expression (Analysis a) -> MemoryBlockName
forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e) (AList Index (Analysis a) -> [Index (Analysis a)]
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 = SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a) -> Bool
forall a. Expression (Analysis a) -> Bool
inCommon Expression (Analysis a)
e
  = SymbolTable
-> MemoryTables
-> Expression (Analysis a)
-> [Index (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> MemoryTables
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 (AList Index (Analysis a) -> [Index (Analysis a)]
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 MemoryBlockName -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> MemoryBlockName
forall a. Expression (Analysis a) -> MemoryBlockName
srcName Expression (Analysis a)
e) SymbolTable
symTable of
    Just (SVariable SemType
_ (MemoryBlockName
memBlockName, Int
_)) ->
      case MemoryBlockName -> StorageTable -> Maybe MemoryBlock
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 StorageClass -> StorageClass -> Bool
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   = Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
expr
      err :: MemoryBlockName
err = MemoryBlockName
"Lookup Expression Context at " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ SrcSpan -> MemoryBlockName
forall a. Show a => a -> MemoryBlockName
show SrcSpan
s
  in  MemoryBlockName -> Maybe ExpressionContext -> ExpressionContext
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
err (Maybe ExpressionContext -> ExpressionContext)
-> Maybe ExpressionContext -> ExpressionContext
forall a b. (a -> b) -> a -> b
$ SrcSpan -> ExpressionContextMap -> Maybe ExpressionContext
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 =
  [(SrcSpan, ExpressionContext)] -> ExpressionContextMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    ([(SrcSpan, ExpressionContext)] -> ExpressionContextMap)
-> ([(SrcSpan, ExpressionContext)]
    -> [(SrcSpan, ExpressionContext)])
-> [(SrcSpan, ExpressionContext)]
-> ExpressionContextMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SrcSpan, ExpressionContext)] -> [(SrcSpan, ExpressionContext)]
forall a. [a] -> [a]
reverse
    ([(SrcSpan, ExpressionContext)] -> ExpressionContextMap)
-> [(SrcSpan, ExpressionContext)] -> ExpressionContextMap
forall a b. (a -> b) -> a -> b
$ [ (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
expr, (Int
bl, Int
bbl, ProgramUnitName
pu))
      | (ProgramUnitName
pu , BBGr (Analysis a)
gr        ) <- BBlockMap (Analysis a) -> [(ProgramUnitName, BBGr (Analysis a))]
forall k a. Map k a -> [(k, a)]
M.toList BBlockMap (Analysis a)
bblockMap
      , (Int
bbl, BB (Analysis a)
basicBlock) <- Gr (BB (Analysis a)) () -> [(Int, BB (Analysis a))]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr)
      , Block (Analysis a)
block             <- BB (Analysis a)
basicBlock
      , Int
bl                <- Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList (Maybe Int -> [Int])
-> (Block (Analysis a) -> Maybe Int) -> Block (Analysis a) -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (Analysis a) -> Maybe Int
forall a (b :: * -> *).
(Data a, Data (b (Analysis a)), Annotated b) =>
b (Analysis a) -> Maybe Int
label (Block (Analysis a) -> [Int]) -> Block (Analysis a) -> [Int]
forall a b. (a -> b) -> a -> b
$ Block (Analysis a)
block
      , Expression (Analysis a)
expr              <- Block (Analysis a) -> [Expression (Analysis a)]
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 = Block (Analysis a) -> [Expression (Analysis a)]
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
    (Int
expBlock, Int
expBBlock, ProgramUnitName
_) = ExpressionContext
exprCxt
    bblock :: BB (Analysis a)
bblock = MemoryBlockName -> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Basic Block" (Maybe (BB (Analysis a)) -> BB (Analysis a))
-> Maybe (BB (Analysis a)) -> BB (Analysis a)
forall a b. (a -> b) -> a -> b
$ Gr (BB (Analysis a)) () -> Int -> Maybe (BB (Analysis a))
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (BBGr (Analysis a) -> Gr (BB (Analysis a)) ()
forall a. BBGr a -> Gr (BB a) ()
bbgrGr BBGr (Analysis a)
gr) Int
expBBlock
    precedingBlocks :: BB (Analysis a)
precedingBlocks = (Block (Analysis a) -> Bool) -> BB (Analysis a) -> BB (Analysis a)
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Block (Analysis a)
b -> Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Block (Analysis a) -> Maybe Int
forall a (b :: * -> *).
(Data a, Data (b (Analysis a)), Annotated b) =>
b (Analysis a) -> Maybe Int
label Block (Analysis a)
b) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expBlock) BB (Analysis a)
bblock
    inBBMemoryTables :: MemoryTables
inBBMemoryTables = InOut MemoryTables -> MemoryTables
forall a b. (a, b) -> a
fst (InOut MemoryTables -> MemoryTables)
-> (Maybe (InOut MemoryTables) -> InOut MemoryTables)
-> Maybe (InOut MemoryTables)
-> MemoryTables
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryBlockName -> Maybe (InOut MemoryTables) -> InOut MemoryTables
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Cannot find MemoryTables" (Maybe (InOut MemoryTables) -> MemoryTables)
-> Maybe (InOut MemoryTables) -> MemoryTables
forall a b. (a -> b) -> a -> b
$ Int -> InOutMap MemoryTables -> Maybe (InOut MemoryTables)
forall a. Int -> IntMap a -> Maybe a
IM.lookup
      Int
expBBlock
      InOutMap MemoryTables
memTables
    inBlockMemoryTables :: MemoryTables
inBlockMemoryTables =
      (MemoryTables -> Block (Analysis a) -> MemoryTables)
-> MemoryTables -> BB (Analysis a) -> MemoryTables
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (ProgramUnitModel
-> MemoryTables -> Block (Analysis a) -> MemoryTables
forall a.
ProgramUnitModel
-> MemoryTables -> Block (Analysis a) -> MemoryTables
varDefine ProgramUnitModel
puModel) MemoryTables
inBBMemoryTables BB (Analysis a)
precedingBlocks
  in
    SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue
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@(Int
_, Int
_, ProgramUnitName
unitName) = Expression (Analysis a)
-> ExpressionContextMap -> ExpressionContext
forall a.
Data a =>
Expression a -> ExpressionContextMap -> ExpressionContext
lookupExpressionContext Expression (Analysis a)
expr ExpressionContextMap
exprCtxMap
      puModel :: ProgramUnitModel
puModel = MemoryBlockName -> Maybe ProgramUnitModel -> ProgramUnitModel
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find SymbolTable" (Maybe ProgramUnitModel -> ProgramUnitModel)
-> Maybe ProgramUnitModel -> ProgramUnitModel
forall a b. (a -> b) -> a -> b
$ ProgramUnitName -> ProgramFileModel -> Maybe ProgramUnitModel
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
unitName ProgramFileModel
pfModel
      controlFlowGraph :: BBGr (Analysis a)
controlFlowGraph =
          MemoryBlockName -> Maybe (BBGr (Analysis a)) -> BBGr (Analysis a)
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find basic block graph" (Maybe (BBGr (Analysis a)) -> BBGr (Analysis a))
-> Maybe (BBGr (Analysis a)) -> BBGr (Analysis a)
forall a b. (a -> b) -> a -> b
$ ProgramUnitName
-> BBlockMap (Analysis a) -> Maybe (BBGr (Analysis a))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
unitName BBlockMap (Analysis a)
bbgraphs
      memTables :: InOutMap MemoryTables
memTables = MemoryBlockName
-> Maybe (InOutMap MemoryTables) -> InOutMap MemoryTables
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find MemTables" (Maybe (InOutMap MemoryTables) -> InOutMap MemoryTables)
-> Maybe (InOutMap MemoryTables) -> InOutMap MemoryTables
forall a b. (a -> b) -> a -> b
$ ProgramUnitName -> MemoryTablesMap -> Maybe (InOutMap MemoryTables)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
unitName MemoryTablesMap
memTablesMap
  in  ProgramUnitModel
-> BBGr (Analysis a)
-> InOutMap MemoryTables
-> ExpressionContext
-> Expression (Analysis a)
-> CPValue
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      = ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
analyseBBlocks ProgramFile (Analysis a)
pf
      pfModel :: ProgramFileModel
pfModel  = ProgramFile (Analysis a) -> ProgramFileModel
forall a. Data a => ProgramFile (Analysis a) -> ProgramFileModel
programFileModel ProgramFile (Analysis a)
pfb
      bbgraphs :: BBlockMap (Analysis a)
bbgraphs = ProgramFile (Analysis a) -> BBlockMap (Analysis a)
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 =
                  MemoryBlockName -> Maybe ProgramUnitModel -> ProgramUnitModel
forall a. MemoryBlockName -> Maybe a -> a
fromJustMsg MemoryBlockName
"Find ProgramUnitModel" (Maybe ProgramUnitModel -> ProgramUnitModel)
-> Maybe ProgramUnitModel -> ProgramUnitModel
forall a b. (a -> b) -> a -> b
$ ProgramUnitName -> ProgramFileModel -> Maybe ProgramUnitModel
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ProgramUnitName
puName ProgramFileModel
pfModel
          in  ProgramUnitModel -> BBGr (Analysis a) -> InOutMap MemoryTables
forall a.
ProgramUnitModel -> BBGr (Analysis a) -> InOutMap MemoryTables
constantPropagationAnalysis ProgramUnitModel
puModel BBGr (Analysis a)
controlFlowGraph
      memTablesMap :: MemoryTablesMap
memTablesMap = (ProgramUnitName -> BBGr (Analysis a) -> InOutMap MemoryTables)
-> BBlockMap (Analysis a) -> MemoryTablesMap
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey ProgramUnitName -> BBGr (Analysis a) -> InOutMap MemoryTables
forall {a}.
ProgramUnitName -> BBGr (Analysis a) -> InOutMap MemoryTables
mapFunc BBlockMap (Analysis a)
bbgraphs
      exprCtxMap :: ExpressionContextMap
exprCtxMap   = BBlockMap (Analysis a) -> ExpressionContextMap
forall a. Data a => BBlockMap (Analysis a) -> ExpressionContextMap
genExpressionContextMap BBlockMap (Analysis a)
bbgraphs
  in  ProgramFileModel
-> BBlockMap (Analysis a)
-> MemoryTablesMap
-> ExpressionContextMap
-> Expression (Analysis a)
-> CPValue
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
_        = MemoryBlockName -> 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 Int
label = Analysis a -> Maybe Int
forall a. Analysis a -> Maybe Int
insLabel (Analysis a -> Maybe Int)
-> (b (Analysis a) -> Analysis a) -> b (Analysis a) -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation

-- | Given kind and dimensions, calculate the size of an array
sizeOfArray :: Int -> [(Int, Int)] -> Int
sizeOfArray :: Int -> Dimensions -> Int
sizeOfArray Int
kind Dimensions
dimension =
  let arraySize :: Int
arraySize = (Int -> Range -> Int) -> Int -> Dimensions -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
acc (Int
l, Int
h) -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Int
1 Dimensions
dimension
  in  Int
kind Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
arraySize