Compiler.hs

{-
 - 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
    , unrollOptions
    , c99Options
    , noSimplification
    , noPrimitiveInstructionHandling
    , includeGeneration
    ) 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.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

------------------------------------------
-- Header file for generated C programs --
------------------------------------------

intro = "#include \"feldspar.h\"\n\n"

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

includeGeneration :: FilePath -> IO ()
includeGeneration fileName
   = appendFile fileName intro

standaloneWrite :: (Reify.Program t) => Writer t
standaloneWrite compilationMode prg outFileName originalFeldsparFunctionSignature opts
   = appendFile outFileName $ compToC $ 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 $ intro ++ (compToC $ 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 $ intro ++ (compToC $ 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

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

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

c99Options 
    = defaultOptions { platform = C99 } 

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),
        forwardPropagationExternalInfo = debug opt,
        backwardPropagationExternalInfo = debug opt
    })
    (graphToImperative hierarchicalGraph)
    where
        hierarchicalGraph = replaceNoInlines $ makeHierarchical $ reify prg