CompilerMain.hs

{-# LANGUAGE CPP #-}
module Main where

import Feldspar.Compiler.Precompiler.Precompiler
import qualified Feldspar.Compiler.Compiler -- ONLY for improving compilation speed in normal mode

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 Control.Monad.CatchIO
import Control.Exception

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

import Language.Haskell.Interpreter

warningPrefix = "[WARNING]: "
errorPrefix   = "[ERROR  ]: "

serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature =
    "(OriginalFeldsparFunctionSignature \"" ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "\" " ++ (show $ originalFeldsparParameterNames originalFeldsparFunctionSignature) ++ ")"

generateCompileCode :: String -> String -> String -> OriginalFeldsparFunctionSignature -> String
generateCompileCode inputFileName outputFileName options originalFeldsparFunctionSignature =
    "standaloneCompile " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ " \"" ++ inputFileName ++ "\" " ++ " \""++
     outputFileName ++"\" " ++ (serializeOriginalFeldsparFunctionSignature originalFeldsparFunctionSignature) ++ " " ++ options

compileFunction :: String -> String -> String -> OriginalFeldsparFunctionSignature -> Interpreter ()
compileFunction inFileName outFileName options originalFeldsparFunctionSignature = do
    iPutStr $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "...\t"
    --result <- catchError ( interpret (generateCompileCode outputFileName options functionName) (as::IO()) ) (\_->error "error")
    result <- interpret (generateCompileCode inFileName outFileName options originalFeldsparFunctionSignature) (as::IO())
    lift result
    iPutStrLn "[OK]"

compileAllFunctions :: String -> String -> String -> [OriginalFeldsparFunctionSignature] -> Interpreter ()
compileAllFunctions inFileName outFileName options [] = return()
compileAllFunctions inFileName outFileName options (x:xs) = do
    (catchError (compileFunction inFileName outFileName options x) ( const $ iPutStrLn "[FAILED]"))
        `Control.Monad.CatchIO.catch`
            (\msg -> iPutStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall))
    compileAllFunctions inFileName outFileName options xs

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

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

-- | Interpreter body for single-function compilation
singleFunctionCompilationBody :: String -> String -> String -> OriginalFeldsparFunctionSignature -> Interpreter (IO ())
singleFunctionCompilationBody inFileName outFileName options originalFeldsparFunctionSignature = do
    iPutStrLn $ "Output file: " ++ outFileName
    iPutStrLn $ "Compiling function " ++ (originalFeldsparFunctionName originalFeldsparFunctionSignature) ++ "..."
    generateIncludeLine outFileName
    result <- interpret (generateCompileCode inFileName outFileName options originalFeldsparFunctionSignature) (as::IO())
    return result

-- | Interpreter body for multi-function compilation
multiFunctionCompilationBody :: String -> String -> String -> [OriginalFeldsparFunctionSignature] -> Interpreter (IO ())
multiFunctionCompilationBody inFileName outFileName compilerOptions declarationList = do
    iPutStrLn $ "Output file: " ++ outFileName
    generateIncludeLine outFileName
    compileAllFunctions inFileName outFileName 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]) ]
        iPutStrLn $ "Loading module " ++ moduleName ++ "..."
#ifdef RELEASE
        loadModules [inputFileName] -- globalImportList modules are package modules and shouldn't 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, c99Options"

    , 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", "c99Options"]) (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..."
    -- -- -- Input file preparations -- -- --
    removeFile (replaceExtension inputFileName ".hi") `Prelude.catch` (const $ return())
    removeFile (replaceExtension inputFileName ".o" ) `Prelude.catch` (const $ return())
    -- -- -- Output file preparations -- -- --
    renameFile outputFileName (outputFileName ++ ".bak") `Prelude.catch` (const $ return())
    -- -- -- </prepare> -- -- --
    fileDescriptor <- openFile inputFileName ReadMode
    fileContents <- hGetContents fileDescriptor
    putStrLn $ "Parsing source file with the precompiler..."
    let declarationList = getExtendedDeclarationList fileContents
    let moduleName = getModuleName fileContents

    let highLevelInterpreterWithModuleInfo = highLevelInterpreter moduleName inputFileName

    -- Dot generation
    case commandLineOptions of
        Options { optDotGeneration = True} -> do
            putStrLn "Dot generation enabled"
            case functionMode of
                SingleFunction funName -> case dotFileName of
                    Just fileName -> highLevelInterpreterWithModuleInfo
                                     (generalInterpreterBody $ "writeDot \"" ++ fileName ++ "\" " ++ funName)
                    Nothing       -> highLevelInterpreterWithModuleInfo
                                     (generalInterpreterBody $ "putStr $ fs2dot " ++ funName)
                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 
          | length declarationList == 0 -> putStrLn "Multi-function mode: Nothing to do."
          | otherwise -> do
              if length declarationList > 1
                then putStrLn $ "Multi-function mode, compiling " ++ (show $ length declarationList) ++ " functions..."
                else putStrLn $ "Multi-function mode, compiling the only function (" ++ (originalFeldsparFunctionName $ head declarationList) ++ ")..." 
              highLevelInterpreterWithModuleInfo (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList)
        SingleFunction funName -> do
            putStrLn $ "Single-function mode, compiling function " ++ funName ++ "..."
            let originalFeldsparFunctionSignatureNeeded = case filter ((==funName).originalFeldsparFunctionName) declarationList of
                                                                    [a] -> a
                                                                    []  -> error $ "Function " ++ funName ++ " not found"
                                                                    _   -> error "Unexpected error SC/01" 
            highLevelInterpreterWithModuleInfo
                (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFeldsparFunctionSignatureNeeded)

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

iPutStr :: String -> Interpreter ()
iPutStr = liftIO . putStr