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

-- ========================
--       VariableData
-- ========================
 
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

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

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


-- ========================
--       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 (ActualParameter t) where
    occurrenceDownwards _ = Occurrence_write
instance OccurrenceDownwards (Expression t) where
    occurrenceDownwards _ = Occurrence_read -- OK

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

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
                }

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

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 = ()
    }