CompilerMain.hs

{-
 - Copyright (c) 2009, 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 CPP #-}
module Main where

import Feldspar.Compiler.Precompiler.Precompiler

import System.Exit
import System.Environment
import System.IO
import System.Process
import System.Info
import System.Directory

import Control.Monad
import Control.Monad.Error

import Data.List
import System.Console.GetOpt
import System.FilePath

import Language.Haskell.Interpreter

generateCompileCode outputFileName options functionName =
    "standaloneCompile " ++ functionName ++ " \""++ outputFileName ++"\" " ++ "\""++ functionName ++"\" " ++
    options

generateUltimateCode outputFileName declarationList options = -- final code for the interpreter
    "do " ++ (concat $ map (generateCompileCode outputFileName options) declarationList)

compileFunction :: String -> String -> String -> Interpreter ()
compileFunction outputFileName options functionName = do
    lift $ putStr $ "Compiling function " ++ functionName ++ "...\t"
    --result <- catchError ( interpret (generateCompileCode outputFileName options functionName) (as::IO()) ) (\_->error "error")
    result <- interpret (generateCompileCode outputFileName options functionName) (as::IO())
    lift result
    say "[OK]"

compileAllFunctions :: String -> String -> [String] -> Interpreter ()
compileAllFunctions outputFileName options [] = return()
compileAllFunctions outputFileName options (x:xs) = do
    catchError (compileFunction outputFileName options x) ( const $ say "[FAILED]")
    compileAllFunctions outputFileName options xs

globalImportList = ["Feldspar.Fs2dot", "Feldspar.Compiler.Compiler"]

generateIncludeLine :: String -> Interpreter ()
generateIncludeLine outputFileName = do
    result <- interpret ("includeGeneration \"" ++ outputFileName ++ "\"") (as::IO())
    lift result

-- | Interpreter body for single-function compilation
singleFunctionCompilationBody :: String -> String -> String -> Interpreter (IO ())
singleFunctionCompilationBody outputFileName options functionName = do
    say $ "Output file: " ++ outputFileName
    say $ "Compiling function " ++ functionName ++ "..."
    generateIncludeLine outputFileName
    result <- interpret (generateCompileCode outputFileName options functionName) (as::IO())
    return result

-- | Interpreter body for multi-function compilation
multiFunctionCompilationBody :: String -> String -> [String] -> Interpreter (IO ())
multiFunctionCompilationBody outputFileName compilerOptions declarationList = do
    say $ "Output file: " ++ outputFileName
    generateIncludeLine outputFileName
    compileAllFunctions outputFileName compilerOptions declarationList
    return(return())

-- | A general interpreter body for interpreting an expression
generalInterpreterBody :: String -- ^ the expression to interpret
                       -> Interpreter (IO ())
generalInterpreterBody expression = do
    result <- interpret expression (as::IO())
    return result

-- | A high-level interface for calling the interpreter
highLevelInterpreter :: String -- ^ the module name (for example My.Module)
                     -> String -- ^ the input file name (for example "My/Module.hs")
                     -> Interpreter (IO ()) -- ^ an interpreter body
                     -> IO ()
highLevelInterpreter moduleName inputFileName interpreterBody = do
    actionToExecute <- runInterpreter $ do
        set [ languageExtensions := (glasgowExtensions ++
                [NoMonomorphismRestriction, OverlappingInstances, Rank2Types, UndecidableInstances]) ]
        say $ "Loading module " ++ moduleName ++ "..."
#ifdef RELEASE
        loadModules [inputFileName] -- the globalImportList modules are package modules and should not be loaded, only imported
#else
        loadModules $ [inputFileName] ++ globalImportList -- in normal mode, we need to load them before importing them
#endif
        setTopLevelModules [moduleName]
        setImports globalImportList
        interpreterBody
    either printInterpreterError id actionToExecute

printGhcError (GhcError {errMsg=s}) = putStrLn s

printInterpreterError :: InterpreterError -> IO ()
printInterpreterError (WontCompile []) = return()
printInterpreterError (WontCompile (x:xs)) = do
    printGhcError x
    printInterpreterError (WontCompile xs)
printInterpreterError e = putStrLn $ "Code generation failed: " ++ (show e)

data FunctionMode = SingleFunction String | MultiFunction

data Options = Options  { optSingleFunction     :: FunctionMode
                        , optOutputFileName     :: Maybe String
                        , optDotGeneration      :: Bool
                        , optDotFileName        :: Maybe String
                        , optCompilerMode       :: String
                        }

-- | Default options
startOptions :: Options
startOptions = Options  { optSingleFunction = MultiFunction
                        , optOutputFileName = Nothing
                        , optDotGeneration  = False
                        , optDotFileName    = Nothing
                        , optCompilerMode   = "defaultOptions"
                        }

-- | Option descriptions for getOpt
options :: [ OptDescr (Options -> IO Options) ]
options =
    [ Option "f" ["singlefunction"]
        (ReqArg
            (\arg opt -> return opt { optSingleFunction = SingleFunction arg })
            "FUNCTION")
        "Enables single-function compilation"

    , Option "o" ["output"]
        (ReqArg
            (\arg opt -> return opt { optOutputFileName = Just arg })
            "outputfile.c")
        "Overrides the file name for the generated output code"

    , Option "d" ["todot"]
        (OptArg
            (\arg opt -> return opt { optDotFileName = arg, optDotGeneration = True })
            "dotfile.dot")
        "Enables dot generation (outputs to stdout if no filename is specified)"

    , Option "c" ["compilermode"]
        (ReqArg
            (\arg opt -> return opt { optCompilerMode = arg })
            "compilerMode")
        "Changes compiler mode. Valid options are: unrollOptions, noSimplification, noPrimitiveInstructionHandling"

    , Option "h" ["help"]
        (NoArg
            (\_ -> do
                --prg <- getProgName
                hPutStrLn stderr (usageInfo header options)
                exitWith ExitSuccess))
        "Show this help message"
    ]

header = "Standalone Feldspar Compiler\nUsage: feldspar [options] inputfile\n" ++
         "Notes: \n" ++
         " * When no output file name is specified, the input file's name with .c extension is used\n" ++
         " * The inputfile parameter is always needed, even in single-function mode\n" ++
         "\nAvailable options: \n"

-- | Calculates the output file name.
convertOutputFileName :: String -> Maybe String -> String
convertOutputFileName inputFileName maybeOutputFileName = case maybeOutputFileName of
    Nothing -> takeFileName $ replaceExtension inputFileName ".c" -- remove takeFileName to return the full path
    Just overriddenFileName -> overriddenFileName

main = do
    args <- getArgs

    when (length args == 0) (do
        putStrLn $ usageInfo header options
        exitWith ExitSuccess)

    -- Parse options, getting a list of option actions
    let (actions, nonOptions, errors) = getOpt Permute options args

    when (length errors > 0) (do
        putStrLn $ concat errors
        putStrLn $ usageInfo header options
        exitWith (ExitFailure 1))

    -- Here we thread startOptions through all supplied option actions
    opts <- foldl (>>=) (return startOptions) actions

    when (length nonOptions /= 1) (do
        putStrLn "ERROR: Exactly one input file expected."
        exitWith (ExitFailure 1))

    let Options { optSingleFunction = functionMode
                , optOutputFileName = maybeOutputFileName
                , optDotGeneration  = dotGeneration
                , optDotFileName    = dotFileName
                , optCompilerMode   = compilerMode } = opts
    let inputFileName = head nonOptions -- change it for multi-file operation
    let outputFileName = convertOutputFileName inputFileName maybeOutputFileName

    when (not $ compilerMode `elem`
            ["defaultOptions", "unrollOptions", "noSimplification", "noPrimitiveInstructionHandling"]) (do
        putStrLn $ "Invalid compiler mode \"" ++ compilerMode ++ "\""
        exitWith (ExitFailure 1))

    compilationCore functionMode inputFileName outputFileName opts dotGeneration dotFileName compilerMode

compilationCore functionMode inputFileName outputFileName commandLineOptions dotGeneration dotFileName compilerMode = do
    putStrLn $ "Starting the Standalone Feldspar Compiler..."

    removeFile outputFileName `catch` (const $ return ())
    fileDescriptor <- openFile inputFileName ReadMode
    fileContents <- hGetContents fileDescriptor
    putStrLn $ "Parsing source file with the precompiler..."
    declarationList <- return $ getDeclarationList fileContents
    moduleName <- return $ getModuleName fileContents

    let highLevelInterpreterWithModuleInfo = highLevelInterpreter moduleName inputFileName

    -- Dot generation
    case commandLineOptions of
        Options { optDotGeneration = True} -> do
            putStrLn "Dot generation enabled"
            case functionMode of
                SingleFunction functionName -> case dotFileName of
                    Just fileName -> highLevelInterpreterWithModuleInfo
                                     (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ functionName)
                    Nothing       -> highLevelInterpreterWithModuleInfo
                                     (generalInterpreterBody $ "putStr $ fs2dot " ++ functionName)
                MultiFunction -> putStrLn $ "ERROR: Dot generation requested, but not supported in multi-function mode\n"++
                                            "(use the \"-f function\" option to enable single-function mode)"
        _ -> putStrLn "Dot generation disabled"

    -- C code generation
    case functionMode of
        MultiFunction -> do
            putStrLn $ "Multi-function mode, compiling " ++ (show $ length declarationList) ++ " functions..."
            highLevelInterpreterWithModuleInfo
                (multiFunctionCompilationBody outputFileName compilerMode declarationList)
        SingleFunction functionName -> do
            putStrLn $ "Single-function mode, compiling function " ++ functionName ++ "..."
            highLevelInterpreterWithModuleInfo
                (singleFunctionCompilationBody outputFileName compilerMode functionName)

say :: String -> Interpreter ()
say = liftIO . putStrLn