feldspar-compiler-0.2: Feldspar/Compiler/Plugins/PropagationUtils.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

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

-- ========================
--       VarStatistics
-- ========================

instance Ord VariableData where
	compare v1 v2 = compare (variableName v1) $ variableName v2

type VarStatistics t = Map.Map VariableData (Occurrences t)

data Occurrences t
    = Occurrences
    { writeVar  :: Occurrence (Maybe t) --(Maybe (Expression t,[String],Bool))
    , 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


-- ========================
--       Downwards
-- ========================

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 --condition variable OK
instance OccurrenceDownwards (SequentialLoop t) where
	occurrenceDownwards _ = Occurrence_read --condition variable OK
instance OccurrenceDownwards (ParallelLoop t) where
	occurrenceDownwards _ = Occurrence_notopt --condition variable OK
instance OccurrenceDownwards (FormalParameter t) where
	occurrenceDownwards _ = Occurrence_notopt
instance OccurrenceDownwards (LocalDeclaration t) where
	occurrenceDownwards _ = Occurrence_declare
instance OccurrenceDownwards (Assignment t) where
	occurrenceDownwards _ = Occurrence_write --left OK, right is expression
instance OccurrenceDownwards (InputActualParameterType t) where
	occurrenceDownwards _ = Occurrence_read
instance OccurrenceDownwards (OutputActualParameterType t) where
	occurrenceDownwards _ = Occurrence_write
instance OccurrenceDownwards (LeftValueInExpression t) where
	occurrenceDownwards _ = Occurrence_read -- OK
instance OccurrenceDownwards (FunctionCall t) where
	occurrenceDownwards _ = Occurrence_read -- OK



-- ========================
--       Other utils
-- ========================

instance Default [VariableData] where
	defaultValue = []


declaredVar :: (SemanticInfo t) => LocalDeclaration t -> VariableData
declaredVar = variableData.localVariable.localDeclarationData

declaredVars :: (SemanticInfo t) => Block t -> [VariableData]
declaredVars block = map declaredVar $ blockDeclarations $ blockData block

delUnusedDecl :: (ConvertAllInfos via to) =>  [VariableData] -> Block via -> BlockData to -> Block to
delUnusedDecl unusedList origblock partiallyTransformedBlock =
				Block {
					blockData = BlockData {
						blockDeclarations = filter (\d -> not $ List.elem (declaredVar d) unusedList) $ blockDeclarations partiallyTransformedBlock,
						blockInstructions = blockInstructions partiallyTransformedBlock
					},
					blockSemInf = convert $ blockSemInf origblock
				}

-- ========================
--       SemInfUtils
-- ========================

class SemInfUtils node where
	deleteSemInf :: (SemanticInfo t) => node t -> node ()

instance SemInfUtils Expression where
	deleteSemInf (LeftValueExpression lve) = LeftValueExpression $ lve {
		leftValueExpressionContents = deleteSemInf $ leftValueExpressionContents lve,
		leftValueExpressionSemInf = ()
	}
	deleteSemInf (ConstantExpression ce) = (ConstantExpression $ deleteSemInf ce)
	deleteSemInf (FunctionCallExpression fce) = FunctionCallExpression $ fce {
		functionCallData = (functionCallData fce) {
			actualParametersOfFunctionToCall = map deleteSemInf $ actualParametersOfFunctionToCall $ functionCallData fce
		},
		functionCallSemInf = ()
	}

instance SemInfUtils LeftValue where
	deleteSemInf (VariableLeftValue vlv) = VariableLeftValue vlv {
		variableLeftValueContents = deleteSemInf $ variableLeftValueContents vlv,
		variableLeftValueSemInf = ()
	}
	deleteSemInf (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue aer {
		arrayElemReferenceData = (arrayElemReferenceData aer){
			arrayName = deleteSemInf $ arrayName $ arrayElemReferenceData aer,
			arrayIndex = deleteSemInf $ arrayIndex $ arrayElemReferenceData aer
		},
		arrayElemReferenceSemInf = ()
	}

instance SemInfUtils Variable where
	deleteSemInf var = var {
		variableSemInf = ()
	}

instance SemInfUtils ActualParameter where
	deleteSemInf (InputActualParameter iap) = InputActualParameter iap {
		inputActualParameterExpression = deleteSemInf $ inputActualParameterExpression iap,
		inputActualParameterSemInf = ()
	}
	deleteSemInf (OutputActualParameter oap) = OutputActualParameter oap {
		outputActualParameterLeftValue = deleteSemInf $ outputActualParameterLeftValue oap,
		outputActualParameterSemInf = ()
	}

instance SemInfUtils Constant where
	deleteSemInf (IntConstant ic) = IntConstant ic {
		intConstantSemInf = ()
	}
	deleteSemInf (FloatConstant fc) = FloatConstant fc {
		floatConstantSemInf = ()
	}
	deleteSemInf (BoolConstant bc) = BoolConstant bc {
		boolConstantSemInf = ()
	}
	deleteSemInf (ArrayConstant ac) = ArrayConstant ac {
		arrayConstantValue = map deleteSemInf $ arrayConstantValue ac,
		arrayConstantSemInf = ()
	}