module Language.Fortran.Vars.MemoryLocation
( getLocation
, generateLinearizedIndexRange
, getStartLocation
)
where
import Data.Data ( Data )
import Data.List ( foldl' )
import qualified Data.Map as M
import Language.Fortran.Analysis ( Analysis
, srcName
)
import Language.Fortran.AST ( AList(..)
, Expression(..)
, Index(..)
, Name
, Value(..)
)
import Language.Fortran.Vars.Eval
( eval )
import Language.Fortran.Vars.Kind
( toInt
, getTypeKind
)
import Language.Fortran.Vars.Range
( Range )
import Language.Fortran.Vars.Types
( SymbolTableEntry(..)
, Type(..)
, SemType(..)
, Location
, Offset
, SymbolTable
)
isIxSingle :: Index a -> Bool
isIxSingle :: Index a -> Bool
isIxSingle IxSingle{} = Bool
True
isIxSingle IxRange{} = Bool
False
linearizedIndex :: [Int] -> [(Int, Int)] -> Int
linearizedIndex :: [Int] -> [(Int, Int)] -> Int
linearizedIndex [Int]
indices [(Int, Int)]
dimensions =
let normalizedIndices :: [Int]
normalizedIndices =
(Int -> (Int, Int) -> Int) -> [Int] -> [(Int, Int)] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Int, (Int, Int)) -> Int) -> Int -> (Int, Int) -> Int
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (\(Int
i, (Int
lower, Int
_)) -> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lower)) [Int]
indices [(Int, Int)]
dimensions
dimSizes :: [Int]
dimSizes = ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
lower, Int
upper) -> Int
upper Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lower Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Int, Int)]
dimensions
leadingDims :: [Int]
leadingDims = [Int] -> [Int]
calcLeadingDimensions [Int]
dimSizes
in (Int -> (Int, Int) -> Int) -> Int -> [(Int, Int)] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
acc (Int
i, Int
ld) -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ld)
Int
0
([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
normalizedIndices [Int]
leadingDims)
where
calcLeadingDimensions :: [Int] -> [Int]
calcLeadingDimensions :: [Int] -> [Int]
calcLeadingDimensions [] = []
calcLeadingDimensions [Int]
dimSizes = [Int] -> [Int] -> [Int]
forall a. Num a => [a] -> [a] -> [a]
calc [Int
1] [Int]
dimSizes
where
calc :: [a] -> [a] -> [a]
calc [a]
_ [] = []
calc [a]
acc [a
_ ] = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc
calc [a]
acc (a
h : [a]
t) = [a] -> [a] -> [a]
calc (([a] -> a
forall a. [a] -> a
head [a]
acc a -> a -> a
forall a. Num a => a -> a -> a
* a
h) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc) [a]
t
generateLinearizedIndexRange :: [Int] -> Int -> [(Int, Int)] -> Int -> Range
generateLinearizedIndexRange :: [Int] -> Int -> [(Int, Int)] -> Int -> (Int, Int)
generateLinearizedIndexRange [Int]
intIndices Int
start [(Int, Int)]
dims Int
kind =
let offset :: Int
offset = [Int] -> [(Int, Int)] -> Int
linearizedIndex [Int]
intIndices [(Int, Int)]
dims Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
kind
in (Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset, Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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)
findBlockOffset :: SymbolTable -> Name -> Offset -> Location
findBlockOffset :: SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable Name
symbol Int
offset = case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symTable of
Just (SVariable Type
_ (Name
blockName, Int
start)) -> (Name
blockName, Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
Just SymbolTableEntry
entry -> Name -> Location
forall a. HasCallStack => Name -> a
error (Name -> Location) -> Name -> Location
forall a b. (a -> b) -> a -> b
$ Name
symbol Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" is not a variable - " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SymbolTableEntry -> Name
forall a. Show a => a -> Name
show SymbolTableEntry
entry
Maybe SymbolTableEntry
Nothing ->
Name -> Location
forall a. HasCallStack => Name -> a
error
(Name -> Location) -> Name -> Location
forall a b. (a -> b) -> a -> b
$ Name
"Unable to find location for symbol "
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
symbol
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" at offset "
Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show Int
offset
calculateOffset :: Data a => SymbolTable -> Name -> [Index (Analysis a)] -> Int
calculateOffset :: SymbolTable -> Name -> [Index (Analysis a)] -> Int
calculateOffset SymbolTable
symTable Name
symbol indices :: [Index (Analysis a)]
indices@(IxSingle{} : [Index (Analysis a)]
_) =
let Just SymbolTableEntry
entry = Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
symbol SymbolTable
symTable
in case SymbolTableEntry
entry of
SVariable (TArray Type
ty (Just [(Int, Int)]
dims)) Location
_ ->
let ixSingles :: [Index (Analysis a)]
ixSingles = (Index (Analysis a) -> Bool)
-> [Index (Analysis a)] -> [Index (Analysis a)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Index (Analysis a) -> Bool
forall a. Index a -> Bool
isIxSingle [Index (Analysis a)]
indices
Just Int
kind = Type -> Maybe Int
getTypeKind Type
ty
arrayIndices :: [Int]
arrayIndices = (Index (Analysis a) -> Int) -> [Index (Analysis a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Index (Analysis a) -> Int
forall a. Index a -> Int
toIndices [Index (Analysis a)]
ixSingles
where
toIndices :: Index a -> Int
toIndices (IxSingle a
_ SrcSpan
_ Maybe Name
_ Expression a
expr) = ExpVal -> Int
toInt (ExpVal -> Int) -> ExpVal -> Int
forall a b. (a -> b) -> a -> b
$ SymbolTable -> Expression a -> ExpVal
forall a. SymbolTable -> Expression a -> ExpVal
eval SymbolTable
symTable Expression a
expr
toIndices Index a
_ = Name -> Int
forall a. HasCallStack => Name -> a
error Name
"toIndices: unexpected input"
in [Int] -> [(Int, Int)] -> Int
linearizedIndex [Int]
arrayIndices [(Int, Int)]
dims Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
kind
SymbolTableEntry
_ ->
Name -> Int
forall a. HasCallStack => Name -> a
error Name
"Only array-typed VariableEntries are expected at this point"
calculateOffset SymbolTable
_ Name
_ (IxRange Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
Nothing Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ : [Index (Analysis a)]
_) = Int
0
calculateOffset SymbolTable
symTable Name
_ (IxRange Analysis a
_ SrcSpan
_ (Just Expression (Analysis a)
lowerIndex) Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ : [Index (Analysis a)]
_) =
ExpVal -> Int
toInt (SymbolTable -> Expression (Analysis a) -> ExpVal
forall a. SymbolTable -> Expression a -> ExpVal
eval SymbolTable
symTable Expression (Analysis a)
lowerIndex) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
calculateOffset SymbolTable
_ Name
_ [Index (Analysis a)]
_ = Name -> Int
forall a. HasCallStack => Name -> a
error Name
"calculateOffset: invalid index"
getLocation :: Data a => SymbolTable -> Expression (Analysis a) -> Location
getLocation :: SymbolTable -> Expression (Analysis a) -> Location
getLocation SymbolTable
symTable e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_)) =
SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e) Int
0
getLocation SymbolTable
symTable (ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} (AList Analysis a
_ SrcSpan
_ [Index (Analysis a)]
indices)) =
let symbol :: Name
symbol = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e
offset :: Int
offset = SymbolTable -> Name -> [Index (Analysis a)] -> Int
forall a.
Data a =>
SymbolTable -> Name -> [Index (Analysis a)] -> Int
calculateOffset SymbolTable
symTable Name
symbol [Index (Analysis a)]
indices
in SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable Name
symbol Int
offset
getLocation SymbolTable
symTable (ExpSubscript Analysis a
_ SrcSpan
_ (ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} (AList Analysis a
_ SrcSpan
_ [Index (Analysis a)]
indices)) (AList Analysis a
_ SrcSpan
_ [Index (Analysis a)]
subs))
= let symbol :: Name
symbol = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e
offset :: Int
offset =
SymbolTable -> Name -> [Index (Analysis a)] -> Int
forall a.
Data a =>
SymbolTable -> Name -> [Index (Analysis a)] -> Int
calculateOffset SymbolTable
symTable Name
symbol [Index (Analysis a)]
indices
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SymbolTable -> Name -> [Index (Analysis a)] -> Int
forall a.
Data a =>
SymbolTable -> Name -> [Index (Analysis a)] -> Int
calculateOffset SymbolTable
symTable Name
symbol [Index (Analysis a)]
subs
in SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable Name
symbol Int
offset
getLocation SymbolTable
symTable (ExpFunctionCall Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} Maybe (AList Argument (Analysis a))
_) =
SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e) Int
0
getLocation SymbolTable
_ Expression (Analysis a)
_ = Name -> Location
forall a. HasCallStack => Name -> a
error Name
"getLocation : Not a variable expression"
getStartLocation :: Data a => SymbolTable -> Expression (Analysis a) -> Location
getStartLocation :: SymbolTable -> Expression (Analysis a) -> Location
getStartLocation SymbolTable
symTable e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_)) =
SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e) Int
0
getStartLocation SymbolTable
symTable (ExpSubscript Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} AList Index (Analysis a)
_) =
SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e) Int
0
getStartLocation SymbolTable
symTable (ExpFunctionCall Analysis a
_ SrcSpan
_ e :: Expression (Analysis a)
e@ExpValue{} Maybe (AList Argument (Analysis a))
_) =
SymbolTable -> Name -> Int -> Location
findBlockOffset SymbolTable
symTable (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e) Int
0
getStartLocation SymbolTable
_ Expression (Analysis a)
_ = Name -> Location
forall a. HasCallStack => Name -> a
error Name
"getStartLocation : Not a variable expression"