--
-- Copyright (c) 2009-2011, 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.
--

module Feldspar.Compiler.Backend.C.Plugin.AllocationEliminator where

import Data.Map (Map)
import qualified Data.Map as Map
import Feldspar.Transformation
import Feldspar.Compiler.Backend.C.Library

data AllocationEliminator = AllocationEliminator

data AllocationEliminatorSemanticInfo

instance Annotation AllocationEliminatorSemanticInfo Module where
    type Label AllocationEliminatorSemanticInfo Module = ()

instance Annotation AllocationEliminatorSemanticInfo Entity where
    type Label AllocationEliminatorSemanticInfo Entity = ()

instance Annotation AllocationEliminatorSemanticInfo Struct where
    type Label AllocationEliminatorSemanticInfo Struct = ()

instance Annotation AllocationEliminatorSemanticInfo ProcDef where
    type Label AllocationEliminatorSemanticInfo ProcDef = AllocationInfo

instance Annotation AllocationEliminatorSemanticInfo ProcDecl where
    type Label AllocationEliminatorSemanticInfo ProcDecl = AllocationInfo

instance Annotation AllocationEliminatorSemanticInfo StructMember where
    type Label AllocationEliminatorSemanticInfo StructMember = ()

instance Annotation AllocationEliminatorSemanticInfo Block where
    type Label AllocationEliminatorSemanticInfo Block = ()

instance Annotation AllocationEliminatorSemanticInfo Program where
    type Label AllocationEliminatorSemanticInfo Program = ()

instance Annotation AllocationEliminatorSemanticInfo Empty where
    type Label AllocationEliminatorSemanticInfo Empty = ()

instance Annotation AllocationEliminatorSemanticInfo Assign where
    type Label AllocationEliminatorSemanticInfo Assign = ()

instance Annotation AllocationEliminatorSemanticInfo ProcedureCall where
    type Label AllocationEliminatorSemanticInfo ProcedureCall = ()

instance Annotation AllocationEliminatorSemanticInfo Sequence where
    type Label AllocationEliminatorSemanticInfo Sequence = ()

instance Annotation AllocationEliminatorSemanticInfo Branch where
    type Label AllocationEliminatorSemanticInfo Branch = ()

instance Annotation AllocationEliminatorSemanticInfo SeqLoop where
    type Label AllocationEliminatorSemanticInfo SeqLoop = ()

instance Annotation AllocationEliminatorSemanticInfo ParLoop where
    type Label AllocationEliminatorSemanticInfo ParLoop = ()

instance Annotation AllocationEliminatorSemanticInfo ActualParameter where
    type Label AllocationEliminatorSemanticInfo ActualParameter = ()

instance Annotation AllocationEliminatorSemanticInfo Declaration where
    type Label AllocationEliminatorSemanticInfo Declaration = ()

instance Annotation AllocationEliminatorSemanticInfo Expression where
    type Label AllocationEliminatorSemanticInfo Expression = ()

instance Annotation AllocationEliminatorSemanticInfo FunctionCall where
    type Label AllocationEliminatorSemanticInfo FunctionCall = ()

instance Annotation AllocationEliminatorSemanticInfo SizeOf where
    type Label AllocationEliminatorSemanticInfo SizeOf = ()

instance Annotation AllocationEliminatorSemanticInfo ArrayElem where
    type Label AllocationEliminatorSemanticInfo ArrayElem = ()

instance Annotation AllocationEliminatorSemanticInfo StructField where
    type Label AllocationEliminatorSemanticInfo StructField = ()

instance Annotation AllocationEliminatorSemanticInfo Constant where
    type Label AllocationEliminatorSemanticInfo Constant = ()

instance Annotation AllocationEliminatorSemanticInfo IntConst where
    type Label AllocationEliminatorSemanticInfo IntConst = ()

instance Annotation AllocationEliminatorSemanticInfo FloatConst where
    type Label AllocationEliminatorSemanticInfo FloatConst = ()

instance Annotation AllocationEliminatorSemanticInfo BoolConst where
    type Label AllocationEliminatorSemanticInfo BoolConst = ()

instance Annotation AllocationEliminatorSemanticInfo ArrayConst where
    type Label AllocationEliminatorSemanticInfo ArrayConst = ()

instance Annotation AllocationEliminatorSemanticInfo ComplexConst where
    type Label AllocationEliminatorSemanticInfo ComplexConst = ()

instance Annotation AllocationEliminatorSemanticInfo Variable where
    type Label AllocationEliminatorSemanticInfo Variable = ()

instance Annotation AllocationEliminatorSemanticInfo Cast where
    type Label AllocationEliminatorSemanticInfo Cast = ()

instance Annotation AllocationEliminatorSemanticInfo Comment where
    type Label AllocationEliminatorSemanticInfo Comment = ()


instance Transformation AllocationEliminator
  where
    type From AllocationEliminator = ()
    type To AllocationEliminator = AllocationEliminatorSemanticInfo
    type Down AllocationEliminator = ()
    type Up AllocationEliminator = ()
    type State AllocationEliminator = (Integer, Map String (Integer, Type))

instance Transformable AllocationEliminator Entity
  where
    transform t s d proc@(ProcDef _ _ _ _ _ _) = Result proc'
        { inParams = mem : ins'
        , procDefLabel = (localsOf s', typesOf ins', typesOf outs')
        }
        (0,Map.empty) u'
      where
        Result proc' s' u' = defaultTransform t s d proc
        mem = Variable
            { varName = "mem"
            , varType = ArrayType UndefinedLen $ ArrayType UndefinedLen VoidType
            , varRole = Pointer
            , varLabel = ()
            }
        ins'  = inParams proc'
        outs' = outParams proc'
        localsOf = map (\(_,(_,t)) -> t) . Map.toList . snd
        typesOf  = map varType

    transform t s d x = defaultTransform t s d x

instance Transformable AllocationEliminator Expression
  where
    transform t s@(idx,m) d e@(VarExpr v lab) = case Map.lookup (varName v) m of
        Nothing -> defaultTransform t s d e
        Just (i,_) -> Result ArrayElem
            { array         = VarExpr
                { var   = Variable
                    { varName = "mem"
                    , varType = ArrayType UndefinedLen $ varType v
                    , varRole = Pointer
                    , varLabel = ()
                    }
                , exprLabel = ()
                }
            , arrayIndex    = ConstExpr
                { constExpr = IntConst
                    { intValue = i
                    , intType = NumType Signed S32
                    , intConstLabel = ()
                    , constLabel = ()
                    }
                , exprLabel = ()
                }
            , arrayLabel = ()
            , exprLabel = ()
            } s ()
    transform t s d e = defaultTransform t s d e

instance Transformable1 AllocationEliminator [] Declaration
  where
    transform1 t s d [] = Result1 [] s ()
    transform1 t s@(idx,m) d (x:xs) = case varType $ declVar x of
        ArrayType _ _   -> transform1 t (idx + 1, Map.insert (varName $ declVar x) (idx, varType $ declVar x) m) d xs
        _               -> Result1 (x':xs') s'' ()
      where
        Result1 xs' s'' () = transform1 t s' d xs
        Result x' s' ()    = transform t s d x

instance Plugin AllocationEliminator
  where
    type ExternalInfo AllocationEliminator = ()
    executePlugin self@AllocationEliminator externalInfo procedure = 
        result $ transform self (0,Map.empty) () procedure