{-
 - Copyright (c) 2009-2010, ERICSSON AB All rights reserved.
 - 
 - Redistribution and use in source and binary forms, with or without
 - modification, are permitted provided that the following conditions
 - are met:
 - 
 -     * Redistributions of source code must retain the above copyright
 -     notice,
 -       this list of conditions and the following disclaimer.
 -     * Redistributions in binary form must reproduce the above copyright
 -       notice, this list of conditions and the following disclaimer
 -       in the documentation and/or other materials provided with the
 -       distribution.
 -     * Neither the name of the ERICSSON AB nor the names of its
 -     contributors
 -       may be used to endorse or promote products derived from this
 -       software without specific prior written permission.
 - 
 - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 - HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 -}

{-# 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

-}