feldspar-compiler-0.2: Feldspar/Compiler/Plugins/BackwardPropagation.hs
{-# LANGUAGE EmptyDataDecls, TypeFamilies, FlexibleInstances #-}
module Feldspar.Compiler.Plugins.BackwardPropagation
where
import Feldspar.Compiler.PluginArchitecture
import Feldspar.Compiler.Plugins.PropagationUtils
import qualified Data.Map as Map
import qualified Data.List as List
import Data.Maybe
import Feldspar.Compiler.Options
-- ===========================================================================
-- == Copy propagation plugin (backward)
-- ===========================================================================
type VarStatBck = VarStatistics ()
data BackwardPropagation = BackwardPropagation
instance TransformationPhase BackwardPropagation where
type From BackwardPropagation = InitSemInf
type To BackwardPropagation = ()
type Downwards BackwardPropagation = ()
type Upwards BackwardPropagation = ()
instance Plugin BackwardPropagation where
type ExternalInfo BackwardPropagation = DebugOption
executePlugin BackwardPropagation externalInfo procedure
| externalInfo == NoSimplification = fst $ executeTransformationPhase BackwardPropagation () procedure
| otherwise = fst $ executeTransformationPhase PropagationTransform [] $ fst $ executeTransformationPhase PropagationCollect (Occurrence_read,False) procedure
-- ====================
-- Collect
-- ====================
instance Default [(VariableData, LeftValue ())] where
defaultValue = []
-- meaning (out,var,out written in a sequence before out=var)
instance Default [(VariableData, LeftValue (),Bool)] where
defaultValue = []
instance Combine (VarStatBck, [(VariableData, LeftValue (),Bool)]) where
combine (m1,x1) (m2,x2) = (combine m1 m2, x1 ++ x2)
instance Default (Maybe (VariableData, LeftValue (),Bool)) where
defaultValue = Nothing
data PropagationSemInf
instance SemanticInfo PropagationSemInf where
type ProcedureInfo PropagationSemInf = ()
type BlockInfo PropagationSemInf = [(VariableData, LeftValue ())] --replacements inside block
type ProgramInfo PropagationSemInf = ()
type EmptyInfo PropagationSemInf = ()
type PrimitiveInfo PropagationSemInf = Maybe (VariableData, LeftValue (), Bool) --if the primitive is a copy assignment the datas of the assigment, just because when we delete primitives at 2nd phase we need this
type SequenceInfo PropagationSemInf = ()
type BranchInfo PropagationSemInf = ()
type SequentialLoopInfo PropagationSemInf = ()
type ParallelLoopInfo PropagationSemInf = ()
type FormalParameterInfo PropagationSemInf = ()
type LocalDeclarationInfo PropagationSemInf = ()
type LeftValueExpressionInfo PropagationSemInf = ()
type VariableInLeftValueInfo PropagationSemInf = ()
type ArrayElemReferenceInfo PropagationSemInf = ()
type InputActualParameterInfo PropagationSemInf = ()
type OutputActualParameterInfo PropagationSemInf = ()
type AssignmentInfo PropagationSemInf = ()
type ProcedureCallInfo PropagationSemInf = ()
type FunctionCallInfo PropagationSemInf = ()
type IntConstantInfo PropagationSemInf = ()
type FloatConstantInfo PropagationSemInf = ()
type BoolConstantInfo PropagationSemInf = ()
type ArrayConstantInfo PropagationSemInf = ()
type VariableInfo PropagationSemInf = ()
data PropagationCollect = PropagationCollect
instance TransformationPhase PropagationCollect where
type From PropagationCollect = InitSemInf
type To PropagationCollect = PropagationSemInf
type Downwards PropagationCollect = (Occurrence_place, Bool)
type Upwards PropagationCollect = (VarStatBck, [(VariableData, LeftValue (),Bool)])
downwardsBranch self d orig = (occurrenceDownwards orig, False)
downwardsSequentialLoop self d orig = (occurrenceDownwards orig, False)
downwardsParallelLoop self d orig = (occurrenceDownwards orig, False)
downwardsFormalParameter self d orig = (occurrenceDownwards orig, False)
downwardsLocalDeclaration self d orig = (occurrenceDownwards orig, isJust $ localInitValue $ localDeclarationData orig)
downwardsAssignment self d orig = (occurrenceDownwards orig, False)
downwardsInputActualParameter self d orig = (occurrenceDownwards orig, False)
downwardsOutputActualParameter self d orig = (occurrenceDownwards orig, False)
downwardsLeftValueExpression self d orig = (occurrenceDownwards orig, False)
downwardsFunctionCall self d orig = (occurrenceDownwards orig, False)
upwardsVariable self (d,me) origVar newVar = case d of
Occurrence_declare
| me -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, [])
| otherwise -> (Map.singleton (variableData origVar) $ Occurrences Zero Zero, [])
Occurrence_read -> (Map.singleton (variableData origVar) $ Occurrences Zero (One ()), [])
Occurrence_write -> (Map.singleton (variableData origVar) $ Occurrences (One Nothing) Zero, [])
Occurrence_notopt -> (Map.singleton (variableData origVar) $ Occurrences Multiple Multiple, [])
upwardsPrimitive self d origPrimitive u newPrimitive = case newPrimitive of
PrimitiveProgram newPr -> case primitiveSemInf newPr of
Just e -> (fst $ upwardsInfoFromPrimitiveInstruction u, [e])
Nothing -> upwardsInfoFromPrimitiveInstruction u
_ -> upwardsInfoFromPrimitiveInstruction u
upwardsBlock self d origBlock u newBlock = (deleteFromVarStatistics (map (fst) $ blockSemInf newBlock) $ fst $ upwardsInfoFromBlockInstructions u,[])
upwardsSequence self d origiSeq u transformedSequence = checkInSequence $ upwardsInfoFromSequenceProgramList u
transformBlock self d origBlock u = Block {
blockData = recursivelyTransformedBlockData u,
blockSemInf = unChain $ checkInDeclatation origBlock $ upwardsInfoFromBlockInstructions u
}
transformPrimitive self d origPrimitive u = PrimitiveProgram $ Primitive {
primitiveInstruction = recursivelyTransformedPrimitiveInstruction u,
primitiveSemInf = getNames origPrimitive
}
getNames :: (SemanticInfo t) => Primitive t -> Maybe (VariableData, LeftValue (),Bool)
getNames pr = getNames' $ primitiveInstruction pr where
getNames' (AssignmentInstruction _) = Nothing
getNames' (ProcedureCallInstruction pc)
| goodName pc = getParamNames $ actualParametersOfProcedureToCall $ procedureCallData pc
| otherwise = Nothing
goodName pc = "copy" == (nameOfProcedureToCall $ procedureCallData pc)
getParamNames [InputActualParameter i, OutputActualParameter o] = pairJust (getIName i) (getOName o)
getParamNames _ = Nothing
pairJust (Just a) (Just b) = Just (a,b,False)
pairJust _ _ = Nothing
getIName i = getExpName $ inputActualParameterExpression i
getOName o = Just $ deleteSemInf $ outputActualParameterLeftValue o
getExpName (LeftValueExpression le) = getLvName_noarr $ leftValueExpressionContents le
getExpName _ = Nothing
getLvName_noarr (VariableLeftValue vlv) = Just $ variableData $ variableLeftValueContents vlv
getLvName_noarr _ = Nothing
getLvName :: (SemanticInfo t) => LeftValue t -> VariableData
getLvName (VariableLeftValue vlv) = variableData $ variableLeftValueContents vlv
getLvName (ArrayElemReferenceLeftValue aer) = getLvName $ arrayName $ arrayElemReferenceData aer
checkInSequence :: [(VarStatBck, [(VariableData, LeftValue (), Bool)])] -> (VarStatBck, [(VariableData, LeftValue (), Bool)])
checkInSequence [] = defaultValue
checkInSequence xs = (varstat $ map fst xs, mapMaybe (checkSeq xs False False False) $ foldl (\ls (vs,s) -> s++ls) [] xs)
where
varstat :: [VarStatBck] -> VarStatBck
varstat = foldl combine defaultValue
checkSeq :: [(VarStatBck, [(VariableData, LeftValue (), Bool)])] -> Bool{-usedVar-} -> Bool{-usedOut-} -> Bool{-after-} -> (VariableData {-var-}, LeftValue () {-out-}, Bool) -> Maybe (VariableData, LeftValue (), Bool)
checkSeq [] _ usedOut _ (var,outD,outUsedLower) = Just (var,outD,usedOut)
checkSeq ((vs,s):ys) usedVar usedOut after sp@(var,outD,outUsedLower)
| after && (vs `notUse` var) = checkSeq ys usedVar usedOut after sp
| after {- && (vs `hasUse` var) -} = Nothing
| {-(not after) && -} (sp `List.elem` s) && ((not outUsedLower) || (not usedVar)) = checkSeq ys usedVar usedOut True sp
| {-(not after) && -} usedVar && (vs `notUse` out) = checkSeq ys usedVar usedOut after sp
| {-(not after) && -} usedVar {- && (vs `hasUse` out)-} = Nothing
| {-(not after) && (not usedVar) && -} (vs `hasRead` var) && (vs `notUse` out) = checkSeq ys True usedOut after sp
| {-(not after) && (not usedVar) && -} (vs `hasRead` var) {- && (vs `hasUse` out) -} = Nothing
| {-(not after) && (not usedVar) && -} (vs `hasWrite` var) && (vs `hasWrite` out) = Nothing
| {-(not after) && (not usedVar) && -} (vs `hasWrite` var) {- && (vs `notWrite` out)-} = checkSeq ys True usedOut after sp
| {-(not after) && (not usedVar) && (vs `notUse` var) && -} (vs `hasUse` out) = checkSeq ys usedVar True after sp
| {-(not after) && (not usedVar) && (vs `notUse` var) && (vs `notUse` out)-} otherwise = checkSeq ys usedVar usedOut after sp
where
--var = variableName varD
out = getLvName outD
{-
check the sequence format:
______________
| use out |
| ___________|
|__|= |
| use var |
|_____________|
out = var
______________
| not use var |
|_____________|
|
-}
checkInDeclatation :: Block InitSemInf -> (VarStatBck, [(VariableData, LeftValue (), Bool)]) -> [(VariableData, LeftValue ())]
checkInDeclatation origBlock u = mapMaybe (checkDecl $ decl) (snd u) where
decl = blockDeclarations $ blockData origBlock
checkDecl :: [LocalDeclaration InitSemInf] -> (VariableData, LeftValue (), Bool) -> Maybe (VariableData, LeftValue ())
checkDecl lds (var,outD,outUsedLower) = case List.find (\ld -> var == declaredVar ld) lds of
Nothing -> Nothing
Just ld -> case localInitValue $ localDeclarationData ld of
Nothing -> Just (var,outD)
Just exp -> case outUsedLower of
True -> Nothing
False -> Just (var,outD)
{-
check var get initValue, because it is a write, and it means we can't use out because "out=var"
-}
-- ====================
-- BackwardPropagation
-- ====================
data PropagationTransform = PropagationTransform
instance TransformationPhase PropagationTransform where
type From PropagationTransform = PropagationSemInf
type To PropagationTransform = ()
type Downwards PropagationTransform = [(VariableData, LeftValue ())]
type Upwards PropagationTransform = ()
downwardsBlock self d origBlock = foldl addChain (blockSemInf origBlock) d
downwardsLocalDeclaration self d origLocDecl = []
transformBlock self d orig fromBelow = delUnusedDecl (map fst $ foldl addChain (blockSemInf orig) d) orig $ recursivelyTransformedBlockData fromBelow
transformPrimitive self d origPrimitive u =
case primitiveSemInf origPrimitive of
Nothing -> makedPrim
Just (var,outD,_)
| List.elem (var,outD) d || ((List.elem (getLvName outD) $ map fst d) && (List.elem var $ map fst d) ) -> EmptyProgram $ Empty ()
| otherwise -> makedPrim
where
makedPrim = PrimitiveProgram $ Primitive {
primitiveInstruction = recursivelyTransformedPrimitiveInstruction u,
primitiveSemInf =()
}
transformVariableInLeftValue self d origVIL u = case List.find (\(a,b) -> a == newVar) d of
Nothing -> VariableLeftValue $ VariableInLeftValue {
variableLeftValueContents = recursivelyTransformedVariableLeftValueContents u,
variableLeftValueSemInf = ()
}
Just (var,out) -> out
where
newVar = variableData $ recursivelyTransformedVariableLeftValueContents u
unChain :: [(VariableData, LeftValue ())] -> [(VariableData, LeftValue ())]
unChain s = foldl addChain [] s
addChain :: [(VariableData, LeftValue ())] -> (VariableData, LeftValue ()) -> [(VariableData, LeftValue ())]
addChain [] pair = [pair]
addChain (x@(mibe1,mit1):xs) r@(mibe2,mit2)
| (getLvName mit1) == mibe2 = (mibe1,changeInnerArrayName mit1 mit2):r:xs
| (getLvName mit2) == mibe1 = (mibe2,changeInnerArrayName mit2 mit1):x:xs
| otherwise = x:(addChain xs r)
where
changeInnerArrayName :: LeftValue () {-toChange-} -> LeftValue () {-newName-} -> LeftValue ()
changeInnerArrayName toChange (ArrayElemReferenceLeftValue aer) = ArrayElemReferenceLeftValue aer {
arrayElemReferenceData = (arrayElemReferenceData aer) {
arrayName = changeInnerArrayName toChange (arrayName $ arrayElemReferenceData aer)
}
}
changeInnerArrayName (ArrayElemReferenceLeftValue aer) newName@(VariableLeftValue _) = ArrayElemReferenceLeftValue aer {
arrayElemReferenceData = (arrayElemReferenceData aer) {
arrayName = changeInnerArrayName (arrayName $ arrayElemReferenceData aer) newName
}
}
changeInnerArrayName (VariableLeftValue _) newName@(VariableLeftValue _) = newName
{-
addChain [ (a, b) ] (b, c) = [ (a, b), (a, c) ]
addChain [ (a, b) ] (b[i],c) = [ (a, b), (a[i], c) ]
addChain [ (a[m],b) ] (b[i],c) = [ (a[m],b), (a[m][i], c) ]
addChain [ (b, c) ] (a, b) = [ (a, b), (a, c) ]
addChain [ (b, c) ] (a[i],b) = [ (a, b), (a[i], c) ]
addChain [ (b[i],c) ] (a[m],b) = [ (a[m],b), (a[m][i], c) ]
but arrayof(arrayof(lv,index1)index2) = lv[index2][index1]
so first go down in newNames indexes and put these outwards
then go down toChanges indexes, and when no indexes change
-}