module Language.Fortran.Vars.Union
( union
)
where
import qualified Data.Map as M
import Language.Fortran.AST ( Name )
import Language.Fortran.Vars.Types
( SymbolTableEntry(..)
, Location
, MemoryBlock(..)
, MemoryBlockName
, ProgramUnitModel
, StorageClass(..)
, SymbolTable
)
updateVal :: MemoryBlockName -> Int -> Name -> SymbolTable -> SymbolTable
updateVal :: MemoryBlockName
-> Int -> MemoryBlockName -> SymbolTable -> SymbolTable
updateVal MemoryBlockName
blockName Int
diff MemoryBlockName
symbol SymbolTable
symt = case MemoryBlockName -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
symbol SymbolTable
symt of
Just (SVariable Type
ty (MemoryBlockName
_, Int
offset)) ->
let entry :: SymbolTableEntry
entry = Type -> (MemoryBlockName, Int) -> SymbolTableEntry
SVariable Type
ty (MemoryBlockName
blockName, Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
diff)
in MemoryBlockName -> SymbolTableEntry -> SymbolTable -> SymbolTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MemoryBlockName
symbol SymbolTableEntry
entry SymbolTable
symt
Just SymbolTableEntry
_ -> MemoryBlockName -> SymbolTable
forall a. HasCallStack => MemoryBlockName -> a
error (MemoryBlockName
symbol MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ MemoryBlockName
"is not a variable.")
Maybe SymbolTableEntry
Nothing -> SymbolTable
symt
mergeStClass :: StorageClass -> StorageClass -> StorageClass
mergeStClass :: StorageClass -> StorageClass -> StorageClass
mergeStClass StorageClass
Unspecified StorageClass
c2 = StorageClass
c2
mergeStClass StorageClass
c1 StorageClass
Unspecified = StorageClass
c1
mergeStClass StorageClass
c1 StorageClass
c2 | StorageClass
c1 StorageClass -> StorageClass -> Bool
forall a. Eq a => a -> a -> Bool
== StorageClass
c2 = StorageClass
c1
mergeStClass StorageClass
c1 StorageClass
c2 =
MemoryBlockName -> StorageClass
forall a. HasCallStack => MemoryBlockName -> a
error (MemoryBlockName
"Try to merge StorageClass " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ StorageClass -> MemoryBlockName
forall a. Show a => a -> MemoryBlockName
show StorageClass
c1 MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ MemoryBlockName
" with " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ StorageClass -> MemoryBlockName
forall a. Show a => a -> MemoryBlockName
show StorageClass
c2)
union
:: ProgramUnitModel -> Location -> Location -> (ProgramUnitModel, Location)
union :: ProgramUnitModel
-> (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
union ProgramUnitModel
puModel (MemoryBlockName, Int)
loc1 (MemoryBlockName, Int)
loc2 | (MemoryBlockName, Int)
loc1 (MemoryBlockName, Int) -> (MemoryBlockName, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (MemoryBlockName, Int)
loc2 = (ProgramUnitModel
puModel, (MemoryBlockName, Int)
loc1)
union (SymbolTable
symTable, StorageTable
storageTable) (MemoryBlockName, Int)
location1 (MemoryBlockName, Int)
location2 =
let (MemoryBlockName
blockName1, Int
offset1) = (MemoryBlockName, Int)
location1
(MemoryBlockName
blockName2, Int
offset2) = (MemoryBlockName, Int)
location2
Just MemoryBlock
block1 = case MemoryBlockName -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
blockName1 StorageTable
storageTable of
Just MemoryBlock
block -> MemoryBlock -> Maybe MemoryBlock
forall a. a -> Maybe a
Just MemoryBlock
block
Maybe MemoryBlock
Nothing -> MemoryBlockName -> Maybe MemoryBlock
forall a. HasCallStack => MemoryBlockName -> a
error (MemoryBlockName
"Block doesn't exist: " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ MemoryBlockName
blockName1)
Just MemoryBlock
block2 = case MemoryBlockName -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
blockName2 StorageTable
storageTable of
Just MemoryBlock
block -> MemoryBlock -> Maybe MemoryBlock
forall a. a -> Maybe a
Just MemoryBlock
block
Maybe MemoryBlock
Nothing -> MemoryBlockName -> Maybe MemoryBlock
forall a. HasCallStack => MemoryBlockName -> a
error (MemoryBlockName
"Block doesn't exist: " MemoryBlockName -> MemoryBlockName -> MemoryBlockName
forall a. [a] -> [a] -> [a]
++ MemoryBlockName
blockName2)
in case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
offset1 Int
offset2 of
Ordering
Prelude.GT -> (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
mergeTo (MemoryBlockName, Int)
location1 (MemoryBlockName, Int)
location2
Ordering
Prelude.LT -> (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
mergeTo (MemoryBlockName, Int)
location2 (MemoryBlockName, Int)
location1
Ordering
Prelude.EQ -> case (MemoryBlock -> StorageClass
storageClass MemoryBlock
block1, MemoryBlock -> StorageClass
storageClass MemoryBlock
block2) of
(StorageClass
Common, StorageClass
_ ) -> (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
mergeTo (MemoryBlockName, Int)
location1 (MemoryBlockName, Int)
location2
(StorageClass
_ , StorageClass
Common) -> (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
mergeTo (MemoryBlockName, Int)
location2 (MemoryBlockName, Int)
location1
(StorageClass, StorageClass)
_ -> if MemoryBlock -> Maybe Int
blockSize MemoryBlock
block1 Maybe Int -> Maybe Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MemoryBlock -> Maybe Int
blockSize MemoryBlock
block2
then (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
mergeTo (MemoryBlockName, Int)
location1 (MemoryBlockName, Int)
location2
else (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
mergeTo (MemoryBlockName, Int)
location2 (MemoryBlockName, Int)
location1
where
mergeTo :: Location -> Location -> (ProgramUnitModel, Location)
mergeTo :: (MemoryBlockName, Int)
-> (MemoryBlockName, Int)
-> (ProgramUnitModel, (MemoryBlockName, Int))
mergeTo toLocation :: (MemoryBlockName, Int)
toLocation@(MemoryBlockName
toBlockName, Int
toOffset) (MemoryBlockName
fromBlockName, Int
fromOffset) =
let
diff :: Int
diff = Int
toOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fromOffset
Just MemoryBlock
fromBlock = MemoryBlockName -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
fromBlockName StorageTable
storageTable
Just MemoryBlock
toBlock = MemoryBlockName -> StorageTable -> Maybe MemoryBlock
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MemoryBlockName
toBlockName StorageTable
storageTable
newVarList :: [MemoryBlockName]
newVarList = MemoryBlock -> [MemoryBlockName]
variables MemoryBlock
toBlock [MemoryBlockName] -> [MemoryBlockName] -> [MemoryBlockName]
forall a. [a] -> [a] -> [a]
++ MemoryBlock -> [MemoryBlockName]
variables MemoryBlock
fromBlock
newSize :: Maybe Int
newSize = do
Int
to <- MemoryBlock -> Maybe Int
blockSize MemoryBlock
toBlock
Int
from <- MemoryBlock -> Maybe Int
blockSize MemoryBlock
fromBlock
Int -> Maybe Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
to (Int
from Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
diff)
newStClass :: StorageClass
newStClass = StorageClass -> StorageClass -> StorageClass
mergeStClass (MemoryBlock -> StorageClass
storageClass MemoryBlock
fromBlock) (MemoryBlock -> StorageClass
storageClass MemoryBlock
toBlock)
newBlock :: MemoryBlock
newBlock = MemoryBlock :: Maybe Int -> StorageClass -> [MemoryBlockName] -> MemoryBlock
MemoryBlock { blockSize :: Maybe Int
blockSize = Maybe Int
newSize
, storageClass :: StorageClass
storageClass = StorageClass
newStClass
, variables :: [MemoryBlockName]
variables = [MemoryBlockName]
newVarList
}
mbs :: StorageTable
mbs = MemoryBlockName -> MemoryBlock -> StorageTable -> StorageTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MemoryBlockName
toBlockName MemoryBlock
newBlock StorageTable
storageTable
mbs' :: StorageTable
mbs' = MemoryBlockName -> StorageTable -> StorageTable
forall k a. Ord k => k -> Map k a -> Map k a
M.delete MemoryBlockName
fromBlockName StorageTable
mbs
symTable' :: SymbolTable
symTable' =
(MemoryBlockName -> SymbolTable -> SymbolTable)
-> SymbolTable -> [MemoryBlockName] -> SymbolTable
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (MemoryBlockName
-> Int -> MemoryBlockName -> SymbolTable -> SymbolTable
updateVal MemoryBlockName
toBlockName Int
diff) SymbolTable
symTable (MemoryBlock -> [MemoryBlockName]
variables MemoryBlock
fromBlock)
in
((SymbolTable
symTable', StorageTable
mbs'), (MemoryBlockName, Int)
toLocation)