module Feldspar.Compiler.Plugins.PropagationUtils where
import Feldspar.Compiler.PluginArchitecture
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
data VariableData = VariableData {
variableDataType :: Type
, variableDataName :: String
} deriving (Eq,Show)
variableData :: (SemanticInfo t) => Variable t -> VariableData
variableData var = VariableData {
variableDataName = variableName var
, variableDataType = variableType var
}
instance Ord VariableData where
compare v1 v2 = compare (variableDataName v1) $ variableDataName v2
instance Default (Maybe VariableData) where
defaultValue = Nothing
instance Default [VariableData] where
defaultValue = []
instance Default (Set.Set VariableData) where
defaultValue = Set.empty
instance Combine (Set.Set VariableData) where
combine = Set.union
type VarStatistics t = Map.Map VariableData (Occurrences t)
data Occurrences t
= Occurrences
{ writeVar :: Occurrence (Maybe t)
, readVar :: Occurrence ()
}
deriving (Eq,Show)
data Occurrence t = Zero | One t | Multiple
deriving (Eq,Show)
hasUse :: VarStatistics t -> VariableData -> Bool
hasUse vs var = hasRead vs var || hasWrite vs var
notUse :: VarStatistics t -> VariableData -> Bool
notUse vs var = not $ hasUse vs var
hasRead :: VarStatistics t -> VariableData -> Bool
hasRead vs var = case Map.lookup var vs of
Nothing -> False
Just occ -> case readVar occ of
Zero -> False
_ -> True
notRead :: VarStatistics t -> VariableData -> Bool
notRead vs var = not $ hasRead vs var
hasWrite :: VarStatistics t -> VariableData -> Bool
hasWrite vs var = case Map.lookup var vs of
Nothing -> False
Just occ -> case writeVar occ of
Zero -> False
_ -> True
notWrite :: VarStatistics t -> VariableData -> Bool
notWrite vs var = not $ hasWrite vs var
getWrite :: VarStatistics t -> VariableData -> Maybe t
getWrite vs var = case Map.lookup var vs of
Nothing -> Nothing
Just occ -> case writeVar occ of
One val -> val
_ -> Nothing
instance Default (VarStatistics t) where
defaultValue = Map.empty
instance Combine (VarStatistics t) where
combine fst snd = Map.unionWith combine fst snd
instance Combine (Occurrences t) where
combine o1 o2 = Occurrences
(combine (writeVar o1) (writeVar o2) )
(combine (readVar o1) (readVar o2) )
instance Combine (Occurrence t) where
combine Zero x = x
combine Multiple x = Multiple
combine e@(One _) Zero = e
combine (One _) _ = Multiple
multipleVarStatistics :: VarStatistics t -> VarStatistics t
multipleVarStatistics vs = Map.map multipleOccurrences vs where
multipleOccurrences (Occurrences write read) = Occurrences (multipleOccurrence write) (multipleOccurrence read)
multipleOccurrence Zero = Zero
multipleOccurrence (One _) = Multiple
multipleOccurrence Multiple = Multiple
variablesInVarStatistics :: VarStatistics t -> [VariableData]
variablesInVarStatistics vs = Map.keys vs
selectFromVarStatistics :: [VariableData] -> VarStatistics t -> VarStatistics t
selectFromVarStatistics s vs = Map.filterWithKey (\v o -> v `elem` s) vs
deleteFromVarStatistics :: [VariableData] -> VarStatistics t -> VarStatistics t
deleteFromVarStatistics s vs = Map.filterWithKey (\v o -> not $ v `elem` s) vs
data Occurrence_place = Occurrence_read | Occurrence_write | Occurrence_declare | Occurrence_notopt
deriving (Eq,Show)
instance Default Occurrence_place where
defaultValue = Occurrence_read
class OccurrenceDownwards node where
occurrenceDownwards :: node -> Occurrence_place
instance OccurrenceDownwards (Branch t) where
occurrenceDownwards _ = Occurrence_notopt
instance OccurrenceDownwards (SequentialLoop t) where
occurrenceDownwards _ = Occurrence_read
instance OccurrenceDownwards (ParallelLoop t) where
occurrenceDownwards _ = Occurrence_notopt
instance OccurrenceDownwards (FormalParameter t) where
occurrenceDownwards _ = Occurrence_notopt
instance OccurrenceDownwards (LocalDeclaration t) where
occurrenceDownwards _ = Occurrence_declare
instance OccurrenceDownwards (Assignment t) where
occurrenceDownwards _ = Occurrence_write
instance OccurrenceDownwards (ActualParameter t) where
occurrenceDownwards _ = Occurrence_write
instance OccurrenceDownwards (Expression t) where
occurrenceDownwards _ = Occurrence_read
declaredVar :: (SemanticInfo t) => LocalDeclaration t -> VariableData
declaredVar = variableData.localVariable
declaredVars :: (SemanticInfo t) => Block t -> [VariableData]
declaredVars block = map declaredVar $ blockDeclarations block
delUnusedDecl :: (ConvertAllInfos via to) => [VariableData] -> Block via -> [LocalDeclaration to] -> Program to -> Block to
delUnusedDecl unusedList origblock partiallyTransformedDecl partiallyTransformedInstr =
Block {
blockDeclarations = filter (\d -> not $ List.elem (declaredVar d) unusedList) $ partiallyTransformedDecl,
blockInstructions = partiallyTransformedInstr,
blockSemInf = convert $ blockSemInf origblock
}
class SemInfUtils node where
deleteSemInf :: (SemanticInfo t) => node t -> node ()
instance SemInfUtils Expression where
deleteSemInf exp = exp {
expressionData = deleteSemInf $ expressionData exp,
expressionSemInf = ()
}
instance SemInfUtils ExpressionData where
deleteSemInf (LeftValueExpression lve) = LeftValueExpression $ deleteSemInf lve
deleteSemInf (ConstantExpression ce) = ConstantExpression $ deleteSemInf ce
deleteSemInf (FunctionCallExpression fce) = FunctionCallExpression $ deleteSemInf fce
instance SemInfUtils LeftValue where
deleteSemInf lv = lv {
leftValueData = deleteSemInf $ leftValueData lv,
leftValueSemInf = ()
}
instance SemInfUtils LeftValueData where
deleteSemInf (VariableLeftValue vlv) = VariableLeftValue $ deleteSemInf vlv
deleteSemInf (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue $ deleteSemInf aer
instance SemInfUtils ArrayElemReference where
deleteSemInf aer = aer {
arrayName = deleteSemInf $ arrayName aer,
arrayIndex = deleteSemInf $ arrayIndex aer,
arrayElemReferenceSemInf = ()
}
instance SemInfUtils Variable where
deleteSemInf var = var {
variableSemInf = ()
}
instance SemInfUtils ActualParameter where
deleteSemInf ap = ap {
actualParameterData = deleteSemInf $ actualParameterData ap,
actualParameterSemInf = ()
}
instance SemInfUtils ActualParameterData where
deleteSemInf (InputActualParameter iap) = InputActualParameter $ deleteSemInf iap
deleteSemInf (OutputActualParameter oap) = OutputActualParameter $ deleteSemInf oap
instance SemInfUtils Constant where
deleteSemInf c = c {
constantData = deleteSemInf $ constantData c,
constantSemInf = ()
}
instance SemInfUtils ConstantData where
deleteSemInf (IntConstant ic) = IntConstant $ deleteSemInf ic
deleteSemInf (FloatConstant fc) = FloatConstant $ deleteSemInf fc
deleteSemInf (BoolConstant bc) = BoolConstant $ deleteSemInf bc
deleteSemInf (ArrayConstant ac) = ArrayConstant $ deleteSemInf ac
instance SemInfUtils IntConstantType where
deleteSemInf c = c {
intConstantSemInf = ()
}
instance SemInfUtils FloatConstantType where
deleteSemInf c = c {
floatConstantSemInf = ()
}
instance SemInfUtils BoolConstantType where
deleteSemInf c = c {
boolConstantSemInf = ()
}
instance SemInfUtils ArrayConstantType where
deleteSemInf c = c {
arrayConstantValue = map deleteSemInf $ arrayConstantValue c,
arrayConstantSemInf = ()
}
instance SemInfUtils FunctionCall where
deleteSemInf fc = fc {
actualParametersOfFunctionToCall = map deleteSemInf $ actualParametersOfFunctionToCall fc,
functionCallSemInf = ()
}