Compiler.hs

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