{-# LANGUAGE CPP #-} module Main where -- ====================================== Feldspar imports ================================== import Feldspar.NameExtractor import Feldspar.Compiler.Compiler import qualified Feldspar.Compiler.Compiler as CompilerCore import Feldspar.Compiler.Backend.C.Options import qualified Feldspar.Compiler.Backend.C.Options as CoreOptions import qualified Feldspar.Compiler.Frontend.CommandLine.API.Options as StandaloneOptions import Feldspar.Compiler.Frontend.CommandLine.API.Constants import Feldspar.Compiler.Frontend.CommandLine.API.Library as StandaloneLib import Feldspar.Compiler.Backend.C.Library import Feldspar.Compiler.Frontend.CommandLine.API import Feldspar.Compiler.Imperative.Representation import Feldspar.Compiler.Backend.C.CodeGeneration import Feldspar.Compiler.Error import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint -- ====================================== System imports ================================== import System.IO import System.Exit import System.Info import System.Process import System.IO.Error import System.FilePath import System.Directory import System.Environment import System.Console.ANSI import System.Console.GetOpt -- ====================================== Control imports ================================== import Control.Monad import Control.Exception import Control.Monad.Error import Control.Monad.CatchIO -- ====================================== Other imports ================================== import Data.List import Debug.Trace import Language.Haskell.Interpreter data CompilationError = InterpreterError InterpreterError | InternalErrorCall String compileFunction :: String -> String -> CoreOptions.Options -> Int -> OriginalFunctionSignature -> Interpreter ((String, Either (Module ()) CompilationError), Int) compileFunction inFileName outFileName coreOptions linenum originalFunctionSignature = do let functionName = originalFunctionName originalFunctionSignature (SomeCompilable prg) <- interpret ("SomeCompilable " ++ functionName) (as::SomeCompilable) let compilationUnit = executePluginChain Standalone prg originalFunctionSignature { originalFunctionName = fixFunctionName $ originalFunctionName originalFunctionSignature } coreOptions -- XXX force evaluation in order to be able to catch the exceptions -- liftIO $ evaluate $ compToC coreOptions compilationUnit -- XXX somehow not enough(?!) -- counter-example: structexamples result <- liftIO $ do tempdir <- System.IO.Error.catch (getTemporaryDirectory) (\_ -> return ".") (tempfile, temph) <- openTempFile tempdir "feldspar-temp.txt" let (cCode, (resultLinenum, resultCol)) = compToC ((coreOptions, Declaration_pl), linenum) compilationUnit Control.Exception.finally (hPutStrLn temph cCode) (do hClose temph removeFileIfPossible tempfile) return $ ((functionName, Left compilationUnit), resultLinenum) return result compileAllFunctions :: String -> String -> CoreOptions.Options -> Int -> [OriginalFunctionSignature] -> Interpreter [(String, Either (Module ()) CompilationError)] compileAllFunctions inFileName outFileName options linenum [] = return [] compileAllFunctions inFileName outFileName options linenum (x:xs) = do let functionName = originalFunctionName x (compilationUnit, resultLinenum) <- (catchError (compileFunction inFileName outFileName options linenum x) (\(e::InterpreterError) -> return $ ((functionName, Right $ InterpreterError e), linenum))) `Control.Monad.CatchIO.catch` (\msg -> return $ ((functionName, Right $ InternalErrorCall $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)), linenum)) result <- compileAllFunctions inFileName outFileName options (resultLinenum + 1) xs return $ compilationUnit : result -- | Interpreter body for single-function compilation singleFunctionCompilationBody :: String -> String -> CoreOptions.Options -> OriginalFunctionSignature -> Interpreter (IO CompilationResult) singleFunctionCompilationBody inFileName outFileName coreOptions originalFunctionSignature = do liftIO $ fancyWrite $ "Compiling function " ++ (originalFunctionName originalFunctionSignature) ++ "..." (SomeCompilable prg) <- interpret ("SomeCompilable " ++ originalFunctionName originalFunctionSignature) (as::SomeCompilable) liftIO $ standaloneCompile prg inFileName outFileName originalFunctionSignature coreOptions return $ return CompilationSuccess mergeCompilationUnits :: [Module ()] -> Module () mergeCompilationUnits [] = handleError "Standalone" InvariantViolation "Called mergeCompilationUnits with an empty list" mergeCompilationUnits [x] = x mergeCompilationUnits l@(x:xs) = Module { definitions = nub $ definitions x ++ (definitions $ mergeCompilationUnits xs), -- nub is in fact a "global plugin" here moduleLabel = () } padFunctionName :: String -> String padFunctionName n = StandaloneLib.rpadWith 50 '.' $ "Function " ++ n writeErrors :: (String, Either a CompilationError) -> IO () writeErrors (functionName, Left x) = return () writeErrors (functionName, Right err) = case err of InterpreterError ie -> do withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":" printInterpreterError ie InternalErrorCall ec -> do withColor Red $ putStrLn $ "Error in function " ++ functionName ++ ":" withColor Red $ putStrLn ec writeSummary :: (String, Either a CompilationError) -> IO () writeSummary (functionName, Left x) = do withColor Cyan $ putStr $ padFunctionName functionName withColor Green $ putStrLn "[OK]" writeSummary (functionName, Right msg) = do withColor Cyan $ putStr $ padFunctionName functionName withColor Red $ putStrLn "[FAILED]" filterLefts :: [(String, Either a b)] -> [a] filterLefts [] = [] filterLefts [(_,Left x)] = [x] filterLefts [(_,Right _)] = [] filterLefts ((_,Left x):xs) = x : filterLefts xs filterLefts ((_,Right _):xs) = filterLefts xs -- | Interpreter body for multi-function compilation multiFunctionCompilationBody :: String -> String -> CoreOptions.Options -> [OriginalFunctionSignature] -> Interpreter (IO CompilationResult) multiFunctionCompilationBody inFileName outFileName coreOptions declarationList = do let (headers, linenum) = genHeaders coreOptions liftIO $ appendFile outFileName $ headers compilationUnits <- compileAllFunctions inFileName outFileName coreOptions linenum declarationList liftIO $ do mapM writeErrors compilationUnits withColor Blue $ putStrLn "\n================= [ Summary of compilation results ] =================\n" mapM writeSummary compilationUnits let mergedCompilationUnits = mergeCompilationUnits $ filterLefts compilationUnits (appendFile outFileName $ fst $ compToC ((coreOptions, Declaration_pl), linenum) mergedCompilationUnits) `Control.Exception.catch` (\msg -> withColor Red $ putStrLn $ errorPrefix ++ show (msg::Control.Exception.ErrorCall)) return $ return CompilationSuccess -- | 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 removeFileIfPossible :: String -> IO () removeFileIfPossible filename = removeFile filename `Prelude.catch` (const $ return()) fancyWrite :: String -> IO () fancyWrite s = do withColor Blue $ putStr "=== [ " withColor Cyan $ putStr $ rpad 70 s withColor Blue $ putStrLn " ] ===" main = do args <- getArgs when (length args == 0) (do putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors exitWith ExitSuccess) -- Parse options, getting a list of option actions let (actions, nonOptions, errors) = getOpt Permute StandaloneOptions.optionDescriptors args when (length errors > 0) (do putStrLn $ concat errors putStrLn $ usageInfo helpHeader StandaloneOptions.optionDescriptors exitWith (ExitFailure 1)) -- Here we thread startOptions through all supplied option actions opts <- foldl (>>=) (return StandaloneOptions.startOptions) actions when (length nonOptions /= 1) (do putStrLn "ERROR: Exactly one input file expected." exitWith (ExitFailure 1)) let StandaloneOptions.Options { StandaloneOptions.optSingleFunction = functionMode , StandaloneOptions.optOutputFileName = maybeOutputFileName , StandaloneOptions.optCompilerMode = compilerMode } = opts let inputFileName = replace (head nonOptions) "\\" "/" -- change it for multi-file operation let outputFileName = convertOutputFileName inputFileName maybeOutputFileName -- -- -- Input file preparations -- -- -- removeFileIfPossible $ replaceExtension inputFileName ".hi" removeFileIfPossible $ replaceExtension inputFileName ".o" -- -- -- Output file preparations -- -- -- renameFile outputFileName (outputFileName ++ ".bak") `Prelude.catch` (const $ return()) -- -- -- -- -- -- fileDescriptor <- openFile inputFileName ReadMode fileContents <- hGetContents fileDescriptor let declarationList = getExtendedDeclarationList fileContents let moduleName = getModuleName fileContents fancyWrite $ "Compilation target: module " ++ moduleName fancyWrite $ "Output file: " ++ outputFileName #ifdef RELEASE let needGlobal = False -- globalImportList modules are package modules and shouldn't be loaded, only imported #else let needGlobal = True -- in normal mode, we need to load them before importing them #endif let highLevelInterpreterWithModuleInfo body = highLevelInterpreter moduleName inputFileName globalImportList needGlobal False body -- C code generation case functionMode of StandaloneOptions.MultiFunction | length declarationList == 0 -> putStrLn "No functions to compile." | otherwise -> do fancyWrite $ "Number of functions to compile: " ++ (show $ length declarationList) highLevelInterpreterWithModuleInfo (multiFunctionCompilationBody inputFileName outputFileName compilerMode declarationList) return () StandaloneOptions.SingleFunction funName -> do let originalFunctionSignatureNeeded = case filter ((==funName).originalFunctionName) declarationList of [a] -> a [] -> error $ "Function " ++ funName ++ " not found" _ -> error "Unexpected error SC/01" highLevelInterpreterWithModuleInfo (singleFunctionCompilationBody inputFileName outputFileName compilerMode originalFunctionSignatureNeeded) return ()