{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
module Camfort.Specification.Units.ModFile
(
genUnitsModFile
, initializeModFiles
, runCompileUnits
, dumpModFileCompiledUnits
) where
import Camfort.Analysis (analysisModFiles)
import Camfort.Specification.Units.Annotation (UA)
import Camfort.Specification.Units.Environment (Constraint(..), foldUnits, UnitInfo(..), colSort, Constraints)
import Camfort.Specification.Units.InferenceBackend (flattenConstraints, flattenUnits, genUnitAssignments')
import Camfort.Specification.Units.Monad
import Control.Monad.State (get, gets, lift)
import Data.Binary (Binary, decodeOrFail, encode)
import Data.Data (Data)
import Data.Generics.Uniplate.Operations (universeBi)
import Data.List (partition)
import qualified Data.Map as M
import Data.Maybe (mapMaybe, catMaybes)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import qualified Language.Fortran.AST as F
import qualified Language.Fortran.Analysis as FA
import Language.Fortran.Util.ModFile
import Prelude hiding (mod)
data CompiledUnits = CompiledUnits
{ CompiledUnits -> TemplateMap
cuTemplateMap :: TemplateMap
, CompiledUnits -> NameParamMap
cuNameParamMap :: NameParamMap
} deriving (Eq CompiledUnits
Eq CompiledUnits
-> (CompiledUnits -> CompiledUnits -> Ordering)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> CompiledUnits)
-> (CompiledUnits -> CompiledUnits -> CompiledUnits)
-> Ord CompiledUnits
CompiledUnits -> CompiledUnits -> Bool
CompiledUnits -> CompiledUnits -> Ordering
CompiledUnits -> CompiledUnits -> CompiledUnits
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CompiledUnits -> CompiledUnits -> Ordering
compare :: CompiledUnits -> CompiledUnits -> Ordering
$c< :: CompiledUnits -> CompiledUnits -> Bool
< :: CompiledUnits -> CompiledUnits -> Bool
$c<= :: CompiledUnits -> CompiledUnits -> Bool
<= :: CompiledUnits -> CompiledUnits -> Bool
$c> :: CompiledUnits -> CompiledUnits -> Bool
> :: CompiledUnits -> CompiledUnits -> Bool
$c>= :: CompiledUnits -> CompiledUnits -> Bool
>= :: CompiledUnits -> CompiledUnits -> Bool
$cmax :: CompiledUnits -> CompiledUnits -> CompiledUnits
max :: CompiledUnits -> CompiledUnits -> CompiledUnits
$cmin :: CompiledUnits -> CompiledUnits -> CompiledUnits
min :: CompiledUnits -> CompiledUnits -> CompiledUnits
Ord, CompiledUnits -> CompiledUnits -> Bool
(CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool) -> Eq CompiledUnits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompiledUnits -> CompiledUnits -> Bool
== :: CompiledUnits -> CompiledUnits -> Bool
$c/= :: CompiledUnits -> CompiledUnits -> Bool
/= :: CompiledUnits -> CompiledUnits -> Bool
Eq, Int -> CompiledUnits -> ShowS
[CompiledUnits] -> ShowS
CompiledUnits -> Name
(Int -> CompiledUnits -> ShowS)
-> (CompiledUnits -> Name)
-> ([CompiledUnits] -> ShowS)
-> Show CompiledUnits
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompiledUnits -> ShowS
showsPrec :: Int -> CompiledUnits -> ShowS
$cshow :: CompiledUnits -> Name
show :: CompiledUnits -> Name
$cshowList :: [CompiledUnits] -> ShowS
showList :: [CompiledUnits] -> ShowS
Show, Typeable CompiledUnits
Typeable CompiledUnits
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits)
-> (CompiledUnits -> Constr)
-> (CompiledUnits -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits))
-> ((forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r)
-> (forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits)
-> Data CompiledUnits
CompiledUnits -> Constr
CompiledUnits -> DataType
(forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
$ctoConstr :: CompiledUnits -> Constr
toConstr :: CompiledUnits -> Constr
$cdataTypeOf :: CompiledUnits -> DataType
dataTypeOf :: CompiledUnits -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
$cgmapT :: (forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
gmapT :: (forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
Data, Typeable, (forall x. CompiledUnits -> Rep CompiledUnits x)
-> (forall x. Rep CompiledUnits x -> CompiledUnits)
-> Generic CompiledUnits
forall x. Rep CompiledUnits x -> CompiledUnits
forall x. CompiledUnits -> Rep CompiledUnits x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CompiledUnits -> Rep CompiledUnits x
from :: forall x. CompiledUnits -> Rep CompiledUnits x
$cto :: forall x. Rep CompiledUnits x -> CompiledUnits
to :: forall x. Rep CompiledUnits x -> CompiledUnits
Generic)
instance Binary CompiledUnits
emptyCompiledUnits :: CompiledUnits
emptyCompiledUnits :: CompiledUnits
emptyCompiledUnits = TemplateMap -> NameParamMap -> CompiledUnits
CompiledUnits TemplateMap
forall k a. Map k a
M.empty NameParamMap
forall k a. Map k a
M.empty
combinedCompiledUnits :: ModFiles -> CompiledUnits
combinedCompiledUnits :: ModFiles -> CompiledUnits
combinedCompiledUnits ModFiles
mfs = CompiledUnits { cuTemplateMap :: TemplateMap
cuTemplateMap = [TemplateMap] -> TemplateMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [TemplateMap]
tmaps
, cuNameParamMap :: NameParamMap
cuNameParamMap = [NameParamMap] -> NameParamMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [NameParamMap]
nmaps }
where
cus :: [CompiledUnits]
cus = (ModFile -> CompiledUnits) -> ModFiles -> [CompiledUnits]
forall a b. (a -> b) -> [a] -> [b]
map ModFile -> CompiledUnits
mfCompiledUnits ModFiles
mfs
tmaps :: [TemplateMap]
tmaps = (CompiledUnits -> TemplateMap) -> [CompiledUnits] -> [TemplateMap]
forall a b. (a -> b) -> [a] -> [b]
map CompiledUnits -> TemplateMap
cuTemplateMap [CompiledUnits]
cus
nmaps :: [NameParamMap]
nmaps = (CompiledUnits -> NameParamMap)
-> [CompiledUnits] -> [NameParamMap]
forall a b. (a -> b) -> [a] -> [b]
map CompiledUnits -> NameParamMap
cuNameParamMap [CompiledUnits]
cus
unitsCompiledDataLabel :: String
unitsCompiledDataLabel :: Name
unitsCompiledDataLabel = Name
"units-compiled-data"
mfCompiledUnits :: ModFile -> CompiledUnits
mfCompiledUnits :: ModFile -> CompiledUnits
mfCompiledUnits ModFile
mf = case Name -> ModFile -> Maybe ByteString
lookupModFileData Name
unitsCompiledDataLabel ModFile
mf of
Maybe ByteString
Nothing -> CompiledUnits
emptyCompiledUnits
Just ByteString
bs -> case ByteString
-> Either
(ByteString, ByteOffset, Name)
(ByteString, ByteOffset, CompiledUnits)
forall a.
Binary a =>
ByteString
-> Either
(ByteString, ByteOffset, Name) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs of
Left (ByteString, ByteOffset, Name)
_ -> CompiledUnits
emptyCompiledUnits
Right (ByteString
_, ByteOffset
_, CompiledUnits
cu) -> CompiledUnits
cu
initializeModFiles :: UnitSolver ()
initializeModFiles :: UnitSolver ()
initializeModFiles = do
ModFiles
mfs <- UnitAnalysis ModFiles -> StateT UnitState UnitAnalysis ModFiles
forall (m :: * -> *) a. Monad m => m a -> StateT UnitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UnitAnalysis ModFiles -> StateT UnitState UnitAnalysis ModFiles)
-> (AnalysisT () () IO ModFiles -> UnitAnalysis ModFiles)
-> AnalysisT () () IO ModFiles
-> StateT UnitState UnitAnalysis ModFiles
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO ModFiles -> UnitAnalysis ModFiles
forall (m :: * -> *) a. Monad m => m a -> ReaderT UnitEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnalysisT () () IO ModFiles
-> StateT UnitState UnitAnalysis ModFiles)
-> AnalysisT () () IO ModFiles
-> StateT UnitState UnitAnalysis ModFiles
forall a b. (a -> b) -> a -> b
$ AnalysisT () () IO ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
let compiledUnits :: CompiledUnits
compiledUnits = ModFiles -> CompiledUnits
combinedCompiledUnits ModFiles
mfs
(TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap ((TemplateMap -> TemplateMap) -> UnitSolver ())
-> (CompiledUnits -> TemplateMap -> TemplateMap)
-> CompiledUnits
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplateMap -> TemplateMap -> TemplateMap
forall a b. a -> b -> a
const (TemplateMap -> TemplateMap -> TemplateMap)
-> (CompiledUnits -> TemplateMap)
-> CompiledUnits
-> TemplateMap
-> TemplateMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledUnits -> TemplateMap
cuTemplateMap (CompiledUnits -> UnitSolver ()) -> CompiledUnits -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ CompiledUnits
compiledUnits
(NameParamMap -> NameParamMap) -> UnitSolver ()
modifyNameParamMap ((NameParamMap -> NameParamMap) -> UnitSolver ())
-> (CompiledUnits -> NameParamMap -> NameParamMap)
-> CompiledUnits
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameParamMap -> NameParamMap -> NameParamMap
forall a b. a -> b -> a
const (NameParamMap -> NameParamMap -> NameParamMap)
-> (CompiledUnits -> NameParamMap)
-> CompiledUnits
-> NameParamMap
-> NameParamMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledUnits -> NameParamMap
cuNameParamMap (CompiledUnits -> UnitSolver ()) -> CompiledUnits -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ CompiledUnits
compiledUnits
runCompileUnits :: UnitSolver CompiledUnits
runCompileUnits :: UnitSolver CompiledUnits
runCompileUnits = do
[Constraint]
cons <- UnitState -> [Constraint]
usConstraints (UnitState -> [Constraint])
-> StateT UnitState UnitAnalysis UnitState
-> StateT UnitState UnitAnalysis [Constraint]
forall a b.
(a -> b)
-> StateT UnitState UnitAnalysis a
-> StateT UnitState UnitAnalysis b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UnitState UnitAnalysis UnitState
forall s (m :: * -> *). MonadState s m => m s
get
ProgramFile UA
pf <- UnitState -> ProgramFile UA
usProgramFile (UnitState -> ProgramFile UA)
-> StateT UnitState UnitAnalysis UnitState
-> StateT UnitState UnitAnalysis (ProgramFile UA)
forall a b.
(a -> b)
-> StateT UnitState UnitAnalysis a
-> StateT UnitState UnitAnalysis b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UnitState UnitAnalysis UnitState
forall s (m :: * -> *). MonadState s m => m s
get
let unitAssigns :: [([UnitInfo], [UnitInfo])]
unitAssigns = [Constraint] -> [([UnitInfo], [UnitInfo])]
flattenConstraints [Constraint]
cons
let epsilon :: Double
epsilon = Double
0.001
let approxEq :: Double -> Double -> Bool
approxEq Double
a Double
b = Double -> Double
forall a. Num a => a -> a
abs (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
epsilon
let variables :: Map NameParamKey [UnitInfo]
variables = [(NameParamKey, [UnitInfo])] -> Map NameParamKey [UnitInfo]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (VV -> NameParamKey
NPKVariable VV
var, [UnitInfo]
units) | ([UnitPow (UnitVar VV
var) Double
k], [UnitInfo]
units) <- [([UnitInfo], [UnitInfo])]
unitAssigns
, Double
k Double -> Double -> Bool
`approxEq` Double
1 ]
let getName :: ProgramUnit (Analysis a) -> Maybe Name
getName ProgramUnit (Analysis a)
pu | F.Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puName ProgramUnit (Analysis a)
pu = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n | Bool
otherwise = Maybe Name
forall a. Maybe a
Nothing
let puNameSet :: Set Name
puNameSet = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [ ProgramUnit UA -> Maybe Name
forall {a}. ProgramUnit (Analysis a) -> Maybe Name
getName ProgramUnit UA
pu | ProgramUnit UA
pu <- ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.ProgramUnit UA] ] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
[ Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.varName Expression UA
e | F.BlInterface UA
_ SrcSpan
_ (Just Expression UA
e) Bool
_ [ProgramUnit UA]
_ [Block UA]
_ <- ProgramFile UA -> [Block UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.Block UA] ]
let puVarNameSet :: from -> Set VV
puVarNameSet from
pu = [VV] -> Set VV
forall a. Ord a => [a] -> Set a
S.fromList ([VV] -> Set VV) -> [VV] -> Set VV
forall a b. (a -> b) -> a -> b
$
[ (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.varName Expression UA
v, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.srcName Expression UA
v) | F.Declarator UA
_ SrcSpan
_ Expression UA
v DeclaratorType UA
_ Maybe (Expression UA)
_ Maybe (Expression UA)
_ <- from -> [Declarator UA]
forall from to. Biplate from to => from -> [to]
universeBi from
pu :: [F.Declarator UA] ]
let puVarNameMap :: M.Map F.ProgramUnitName (S.Set VV)
puVarNameMap :: Map ProgramUnitName (Set VV)
puVarNameMap = (Set VV -> Set VV -> Set VV)
-> [(ProgramUnitName, Set VV)] -> Map ProgramUnitName (Set VV)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set VV -> Set VV -> Set VV
forall a. Ord a => Set a -> Set a -> Set a
S.union [ (ProgramUnit UA -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit UA
pu, ProgramUnit UA -> Set VV
forall {from}. Data from => from -> Set VV
puVarNameSet ProgramUnit UA
pu)
| pu :: ProgramUnit UA
pu@F.PUModule {} <- ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.ProgramUnit UA] ]
let filterPUs :: Map Name a -> Map Name a
filterPUs = (Name -> a -> Bool) -> Map Name a -> Map Name a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> a -> Bool
forall a b. a -> b -> a
const (Bool -> a -> Bool) -> (Name -> Bool) -> Name -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
puNameSet))
TemplateMap
tmap <- (TemplateMap -> TemplateMap
forall {a}. Map Name a -> Map Name a
filterPUs (TemplateMap -> TemplateMap)
-> (TemplateMap -> TemplateMap) -> TemplateMap -> TemplateMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Constraint] -> [Constraint]) -> TemplateMap -> TemplateMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [Constraint] -> [Constraint]
optimiseTemplate) (TemplateMap -> TemplateMap)
-> StateT UnitState UnitAnalysis TemplateMap
-> StateT UnitState UnitAnalysis TemplateMap
forall a b.
(a -> b)
-> StateT UnitState UnitAnalysis a
-> StateT UnitState UnitAnalysis b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (UnitState -> TemplateMap)
-> StateT UnitState UnitAnalysis TemplateMap
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets UnitState -> TemplateMap
usTemplateMap
let findNPK :: VV -> Maybe (NameParamKey, [UnitInfo])
findNPK VV
vv = ( (VV -> NameParamKey
NPKVariable VV
vv), ) ([UnitInfo] -> (NameParamKey, [UnitInfo]))
-> Maybe [UnitInfo] -> Maybe (NameParamKey, [UnitInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameParamKey -> Map NameParamKey [UnitInfo] -> Maybe [UnitInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (VV -> NameParamKey
NPKVariable VV
vv) Map NameParamKey [UnitInfo]
variables
let npm :: NameParamMap
npm = (Map NameParamKey [UnitInfo] -> Bool)
-> NameParamMap -> NameParamMap
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (Map NameParamKey [UnitInfo] -> Bool)
-> Map NameParamKey [UnitInfo]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NameParamKey [UnitInfo] -> Bool
forall k a. Map k a -> Bool
M.null) (NameParamMap -> NameParamMap) -> NameParamMap -> NameParamMap
forall a b. (a -> b) -> a -> b
$ ((Set VV -> Map NameParamKey [UnitInfo])
-> Map ProgramUnitName (Set VV) -> NameParamMap)
-> Map ProgramUnitName (Set VV)
-> (Set VV -> Map NameParamKey [UnitInfo])
-> NameParamMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Set VV -> Map NameParamKey [UnitInfo])
-> Map ProgramUnitName (Set VV) -> NameParamMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Map ProgramUnitName (Set VV)
puVarNameMap ([(NameParamKey, [UnitInfo])] -> Map NameParamKey [UnitInfo]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(NameParamKey, [UnitInfo])] -> Map NameParamKey [UnitInfo])
-> (Set VV -> [(NameParamKey, [UnitInfo])])
-> Set VV
-> Map NameParamKey [UnitInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> Maybe (NameParamKey, [UnitInfo]))
-> [VV] -> [(NameParamKey, [UnitInfo])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VV -> Maybe (NameParamKey, [UnitInfo])
findNPK ([VV] -> [(NameParamKey, [UnitInfo])])
-> (Set VV -> [VV]) -> Set VV -> [(NameParamKey, [UnitInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set VV -> [VV]
forall a. Set a -> [a]
S.toList)
CompiledUnits -> UnitSolver CompiledUnits
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompiledUnits { cuTemplateMap :: TemplateMap
cuTemplateMap = TemplateMap
tmap, cuNameParamMap :: NameParamMap
cuNameParamMap = NameParamMap
npm }
optimiseTemplate :: Constraints -> Constraints
optimiseTemplate :: [Constraint] -> [Constraint]
optimiseTemplate [Constraint]
cons = (([UnitInfo], UnitInfo) -> Constraint)
-> [([UnitInfo], UnitInfo)] -> [Constraint]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([UnitInfo]
l, UnitInfo
r) -> UnitInfo -> UnitInfo -> Constraint
ConEq ([UnitInfo] -> UnitInfo
forall (t :: * -> *). Foldable t => t UnitInfo -> UnitInfo
foldUnits [UnitInfo]
l) UnitInfo
r) [([UnitInfo], UnitInfo)]
optimised
where
unitAssigns :: [([UnitInfo], UnitInfo)]
unitAssigns = SortFn -> [Constraint] -> [([UnitInfo], UnitInfo)]
genUnitAssignments' (SortFn
compileColSort) [Constraint]
cons
unitPows :: [([UnitInfo], [UnitInfo])]
unitPows = (([UnitInfo], UnitInfo) -> ([UnitInfo], [UnitInfo]))
-> [([UnitInfo], UnitInfo)] -> [([UnitInfo], [UnitInfo])]
forall a b. (a -> b) -> [a] -> [b]
map ((UnitInfo -> [UnitInfo])
-> ([UnitInfo], UnitInfo) -> ([UnitInfo], [UnitInfo])
forall a b. (a -> b) -> ([UnitInfo], a) -> ([UnitInfo], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitInfo -> [UnitInfo]
flattenUnits) [([UnitInfo], UnitInfo)]
unitAssigns
optimised :: [([UnitInfo], UnitInfo)]
optimised = (([UnitInfo], UnitInfo) -> Bool)
-> [([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter ([UnitInfo], UnitInfo) -> Bool
forall {from} {b}. Data from => (from, b) -> Bool
cull ([([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)])
-> [([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)]
forall a b. (a -> b) -> a -> b
$ (([UnitInfo], [UnitInfo]) -> ([UnitInfo], UnitInfo))
-> [([UnitInfo], [UnitInfo])] -> [([UnitInfo], UnitInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (([UnitInfo] -> UnitInfo)
-> ([UnitInfo], [UnitInfo]) -> ([UnitInfo], UnitInfo)
forall a b. (a -> b) -> ([UnitInfo], a) -> ([UnitInfo], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [UnitInfo] -> UnitInfo
forall (t :: * -> *). Foldable t => t UnitInfo -> UnitInfo
foldUnits (([UnitInfo], [UnitInfo]) -> ([UnitInfo], UnitInfo))
-> (([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo]))
-> ([UnitInfo], [UnitInfo])
-> ([UnitInfo], UnitInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])
shiftTerms) [([UnitInfo], [UnitInfo])]
unitPows
cull :: (from, b) -> Bool
cull (from
lhs, b
_) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | (UnitPow (UnitParamPosAbs (VV, Int)
_) Double
_) <- from -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi from
lhs ]
isUnitRHS :: UnitInfo -> Bool
isUnitRHS (UnitPow (UnitName Name
_) Double
_) = Bool
True
isUnitRHS (UnitPow (UnitParamEAPAbs VV
_) Double
_) = Bool
True
isUnitRHS (UnitPow (UnitParamImpAbs Name
_) Double
_) = Bool
True
isUnitRHS (UnitPow (UnitParamPosAbs (VV, Int)
_) Double
_) = Bool
False
isUnitRHS UnitInfo
_ = Bool
False
negateCons :: [UnitInfo] -> [UnitInfo]
negateCons = (UnitInfo -> UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\ (UnitPow UnitInfo
u Double
k) -> UnitInfo -> Double -> UnitInfo
UnitPow UnitInfo
u (-Double
k))
shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])
shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])
shiftTerms ([UnitInfo]
lhs, [UnitInfo]
rhs) = ([UnitInfo]
lhsOk [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [UnitInfo]
negateCons [UnitInfo]
rhsShift, [UnitInfo]
rhsOk [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [UnitInfo]
negateCons [UnitInfo]
lhsShift)
where
([UnitInfo]
lhsOk, [UnitInfo]
lhsShift) = (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Bool
isUnitRHS) [UnitInfo]
lhs
([UnitInfo]
rhsOk, [UnitInfo]
rhsShift) = (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition UnitInfo -> Bool
isUnitRHS [UnitInfo]
rhs
compileColSort :: SortFn
compileColSort = SortFn -> SortFn
forall a b c. (a -> b -> c) -> b -> a -> c
flip SortFn
colSort
genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile
genUnitsModFile :: ProgramFile UA -> CompiledUnits -> ModFile
genUnitsModFile ProgramFile UA
pf CompiledUnits
cu = (Maybe ByteString -> Maybe ByteString)
-> Name -> ModFile -> ModFile
alterModFileData Maybe ByteString -> Maybe ByteString
forall {p}. p -> Maybe ByteString
f Name
unitsCompiledDataLabel (ModFile -> ModFile) -> ModFile -> ModFile
forall a b. (a -> b) -> a -> b
$ ProgramFile UA -> ModFile
forall a. Data a => ProgramFile (Analysis a) -> ModFile
genModFile ProgramFile UA
pf
where
f :: p -> Maybe ByteString
f p
_ = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ CompiledUnits -> ByteString
forall a. Binary a => a -> ByteString
encode CompiledUnits
cu
dumpModFileCompiledUnits :: ModFile -> Maybe String
dumpModFileCompiledUnits :: ModFile -> Maybe Name
dumpModFileCompiledUnits ModFile
mf = do
ByteString
bs <- Name -> ModFile -> Maybe ByteString
lookupModFileData Name
unitsCompiledDataLabel ModFile
mf
CompiledUnits
cu <- case ByteString
-> Either
(ByteString, ByteOffset, Name)
(ByteString, ByteOffset, CompiledUnits)
forall a.
Binary a =>
ByteString
-> Either
(ByteString, ByteOffset, Name) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs of
Left (ByteString, ByteOffset, Name)
_ -> Maybe CompiledUnits
forall a. Maybe a
Nothing
Right (ByteString
_, ByteOffset
_, CompiledUnits
cu) -> CompiledUnits -> Maybe CompiledUnits
forall a. a -> Maybe a
Just CompiledUnits
cu
Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name) -> ([Name] -> Name) -> [Name] -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Maybe Name) -> [Name] -> Maybe Name
forall a b. (a -> b) -> a -> b
$ [ Name
"Template Map (size=" Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show (TemplateMap -> Int
forall k a. Map k a -> Int
M.size (CompiledUnits -> TemplateMap
cuTemplateMap CompiledUnits
cu)) Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
"):"
, [Name] -> Name
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name] -> Name
unlines (Int -> ShowS
i Int
2 Name
fname'Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:(Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
i Int
4 ShowS -> (Constraint -> Name) -> Constraint -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> Name
forall a. Show a => a -> Name
show) [Constraint]
temp)
| (Name
fname, [Constraint]
temp) <- TemplateMap -> [(Name, [Constraint])]
forall k a. Map k a -> [(k, a)]
M.toList (CompiledUnits -> TemplateMap
cuTemplateMap CompiledUnits
cu)
, let fname' :: Name
fname' = Name
"Template for " Name -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> Name
show Name
fname ]
, Name
"NameParam Map (size=" Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show (NameParamMap -> Int
forall k a. Map k a -> Int
M.size (CompiledUnits -> NameParamMap
cuNameParamMap CompiledUnits
cu)) Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
"):"
, [Name] -> Name
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name] -> Name
unlines (Int -> ShowS
i Int
2 Name
mod'Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[ Int -> ShowS
i Int
4 ([UnitInfo] -> Name
forall a. Show a => a -> Name
show [UnitInfo]
ui Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
" :: " Name -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> Name
show Name
v)
| (NPKVariable (Name
v,Name
_), [UnitInfo]
ui) <- Map NameParamKey [UnitInfo] -> [(NameParamKey, [UnitInfo])]
forall k a. Map k a -> [(k, a)]
M.toList Map NameParamKey [UnitInfo]
npkmap ])
| (ProgramUnitName
mod, Map NameParamKey [UnitInfo]
npkmap) <- NameParamMap -> [(ProgramUnitName, Map NameParamKey [UnitInfo])]
forall k a. Map k a -> [(k, a)]
M.toList (CompiledUnits -> NameParamMap
cuNameParamMap CompiledUnits
cu)
, let mod' :: Name
mod' = Name
"Module " Name -> ShowS
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> Name
forall a. Show a => a -> Name
show ProgramUnitName
mod ]
]
where
i :: Int -> ShowS
i Int
n Name
s = Int -> Char -> Name
forall a. Int -> a -> [a]
replicate Int
n Char
' ' Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
s