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

module Feldspar.Compiler.Compiler
    ( compile
    , standaloneCompile
    , icompile
    , icompile'
    , defaultOptions
    , tic64xPlatformOptions
    , unrollOptions
    , noSimplification
    , noPrimitiveInstructionHandling
    , fixFunctionName
    , c99Options
    ) where

import Data.Map
import Feldspar.Core.Reify (reify)
import Feldspar.Core.Reify as Reify
import Feldspar.Core.Graph
import qualified Feldspar.Core.Expr as Expr
import Feldspar.Core.Types
import Feldspar.Compiler.Options
import Feldspar.Compiler.Platforms
import Feldspar.Compiler.Transformation.GraphToImperative
import Feldspar.Compiler.Transformation.Lifting

import Feldspar.Compiler.PluginArchitecture
import Feldspar.Compiler.Plugins.BackwardPropagation
import Feldspar.Compiler.Plugins.ForwardPropagation
import Feldspar.Compiler.Plugins.Precompilation
import Feldspar.Compiler.Plugins.HandlePrimitives
import Feldspar.Compiler.Plugins.PrettyPrint
import Feldspar.Compiler.Plugins.Unroll
--import Feldspar.Compiler.Plugins.ConstantFolding


import Feldspar.Compiler.Transformation.GraphUtils
import Feldspar.Compiler.Imperative.Semantics
import Feldspar.Compiler.Imperative.Representation
import Feldspar.Compiler.Imperative.CodeGeneration
import qualified Feldspar.Compiler.Precompiler.Precompiler as Precompiler
import System.IO


type Writer t = (CompilationMode -> t -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO ())

-------------------------
-- Core compiler --
-------------------------

replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace [] _ _ = []
replace s find repl | take (length find) s == find = repl ++ (replace (drop (length find) s) find repl)
                    | otherwise = [head s] ++ (replace (tail s) find repl)

fixFunctionName :: String -> String
fixFunctionName functionName = replace (replace functionName "_" "__") "'" "_prime"

coreCompile :: (Reify.Program t) =>
    Writer t -> CompilationMode -> t -> FilePath -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO ()
coreCompile write compilationMode prg inputFileName outputFileName originalFeldsparFunctionSignature opts =
    write compilationMode prg outputFileName originalFeldsparFunctionSignature {
        Precompiler.originalFeldsparFunctionName = fixFunctionName $ Precompiler.originalFeldsparFunctionName originalFeldsparFunctionSignature
    } opts

-------------------------
-- Standalone compiler --
-------------------------

standaloneWrite :: (Reify.Program t) => Writer t
standaloneWrite compilationMode prg outFileName originalFeldsparFunctionSignature opts
   = appendFile outFileName $ compToC (platform opts) $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts

standaloneCompile :: (Reify.Program t) => t -> FilePath -> FilePath -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> IO ()
standaloneCompile prg inputFileName outputFileName originalFeldsparFunctionSignature opts
   = coreCompile standaloneWrite Standalone prg inputFileName outputFileName originalFeldsparFunctionSignature opts

------------------------------------------------
-- Invoking the compiler from the interpreter --
------------------------------------------------

fileWrite :: (Reify.Program t) => Writer t
fileWrite compilationMode prg fileName originalFeldsparFunctionSignature opts
  = writeFile fileName $ (incList $ includes $ platform $ opts) ++ (compToC (platform opts) $ executePluginChain compilationMode prg originalFeldsparFunctionSignature opts)

compile :: (Reify.Program t) => t -> FilePath -> String -> Options -> IO ()
compile prg fileName functionName opts
   = coreCompile fileWrite Interactive prg "" fileName (Precompiler.OriginalFeldsparFunctionSignature functionName []) opts

writeOut :: (Reify.Program t) => Writer t
writeOut compilationMode prg fileName functionName opts
   = putStrLn $ (incList $ includes $ platform $ opts) ++ (compToC (platform opts) $ executePluginChain compilationMode prg functionName opts)

icompile :: (Reify.Program t) => t -> IO ()
icompile prg
   = coreCompile writeOut Interactive prg "" "" (Precompiler.OriginalFeldsparFunctionSignature "test" []) defaultOptions

icompile' :: (Reify.Program t) => t -> String -> Options -> IO ()
icompile' prg functionName opts
  = coreCompile writeOut Interactive prg "" "" (Precompiler.OriginalFeldsparFunctionSignature functionName []) opts

incList :: [String] -> String
incList []   = "\n"
incList (x:xs) = "#include " ++ x ++ "\n" ++ (incList xs)

------------------------
-- Predefined options --
------------------------

defaultOptions
    = Options
    { platform          = c99
    , unroll            = NoUnroll
    , debug             = NoDebug
    , defaultArraySize  = 16
    }

c99Options = defaultOptions

tic64xPlatformOptions
    = defaultOptions { platform = tic64x }

unrollOptions
    = defaultOptions { unroll = Unroll 8 }

noSimplification
    = defaultOptions { debug = NoSimplification }

noPrimitiveInstructionHandling
    = defaultOptions { debug = NoPrimitiveInstructionHandling }

-- ===========================================================================
--  == Plugin system
-- ===========================================================================

pluginChain :: ExternalInfoCollection -> Procedure InitSemInf -> Procedure PrettyPrintSemanticInfo
pluginChain externalInfo
    = (executePlugin PrettyPrint (prettyPrintExternalInfo externalInfo))
--    . (executePlugin ConstantFolding ())
    . (executePlugin UnrollPlugin (unrollExternalInfo externalInfo))
    . (executePlugin Precompilation (precompilationExternalInfo externalInfo))
    . (executePlugin ForwardPropagation (forwardPropagationExternalInfo externalInfo))
    . (executePlugin HandlePrimitives (handlePrimitivesExternalInfo externalInfo))
    . (executePlugin BackwardPropagation (backwardPropagationExternalInfo externalInfo))


data ExternalInfoCollection = ExternalInfoCollection {
    precompilationExternalInfo      :: ExternalInfo Precompilation,
    prettyPrintExternalInfo         :: ExternalInfo PrettyPrint,
    unrollExternalInfo              :: ExternalInfo UnrollPlugin,
    handlePrimitivesExternalInfo    :: ExternalInfo HandlePrimitives,
    forwardPropagationExternalInfo  :: ExternalInfo ForwardPropagation,
    backwardPropagationExternalInfo :: ExternalInfo BackwardPropagation
}

executePluginChain :: (Reify.Program p) => CompilationMode -> p -> Precompiler.OriginalFeldsparFunctionSignature -> Options -> [Procedure PrettyPrintSemanticInfo]
executePluginChain compilationMode prg originalFeldsparFunctionSignatureParam opt =
    Prelude.map (pluginChain ExternalInfoCollection {
        precompilationExternalInfo = PrecompilationExternalInfo {
            originalFeldsparFunctionSignature = originalFeldsparFunctionSignatureParam,
            graphInputInterfaceType = interfaceInputType $ hierGraphInterface hierarchicalGraph,
            numberOfFunctionArguments = Reify.numArgs (mkT prg),
            compilationMode = compilationMode
        },
        prettyPrintExternalInfo = (platform opt, defaultArraySize opt),
        unrollExternalInfo      = unroll opt,
        handlePrimitivesExternalInfo  = (defaultArraySize opt, debug opt, platform opt),
        forwardPropagationExternalInfo = debug opt,
        backwardPropagationExternalInfo = debug opt
    })
    (graphToImperative hierarchicalGraph)
    where
        hierarchicalGraph = replaceNoInlines $ makeHierarchical $ reify prg