diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index d5b4c35..9d116f7 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -10,19 +10,19 @@ import qualified CaseElimination as C import System.Environment import Util.FileUtil import qualified ClosureConv as CC -import qualified IR as CCIR +import qualified IR as CCIR -- import qualified IROpt -- import qualified RetRewrite as Rewrite import qualified CPSOpt as CPSOpt -import qualified IR2JS -import qualified IR2Raw +import qualified IR2JS +import qualified IR2Raw -- import qualified Stack import qualified Raw2Stack -import qualified Stack2JS +import qualified Stack2JS import qualified RawOpt -- import System.IO (isEOF) import qualified Data.ByteString as BS -import Data.ByteString.Base64 (decode) +import Data.ByteString.Base64 (decode) import qualified Data.ByteString.Char8 as BSChar8 import qualified Data.ByteString.Lazy.Char8 as BSLazyChar8 import System.IO @@ -48,16 +48,18 @@ data Flag = IRMode | JSONIRMode | LibMode + | NoRawOpt | OutputFile String | Verbose | Help - | Debug + | Debug deriving (Show, Eq) options :: [OptDescr Flag] options = [ Option ['i'] ["ir"] (NoArg IRMode) "ir interactive mode" , Option ['j'] ["json"] (NoArg JSONIRMode) "ir json interactive mode" + , Option [] ["no-rawopt"] (NoArg NoRawOpt) "disable Raw optimization" , Option ['v'] ["verbose"] (NoArg Verbose) "verbose output" , Option ['d'] ["debug"] (NoArg Debug) "debugging information in the .js file" , Option ['l'] ["lib"] (NoArg LibMode) "compiling a library" @@ -76,7 +78,8 @@ process flags fname input = do if elem LibMode flags then Export else Normal - let verbose = elem Verbose flags + let verbose = Verbose `elem` flags + noRawOpt = NoRawOpt `elem` flags case ast of Left err -> do @@ -146,24 +149,29 @@ process flags fname input = do ----- RAW OPT -------------------------------------- - let rawopt = RawOpt.rawopt raw - when verbose $ printSep "OPTIMIZING RAW OPT" - when verbose $ writeFileD "out/out.rawopt" (show rawopt) + rawopt <- do + if noRawOpt + then return raw + else do + let opt = RawOpt.rawopt raw + when verbose $ printSep "OPTIMIZING RAW OPT" + when verbose $ writeFileD "out/out.rawopt" (show opt) + return opt ----- STACK ---------------------------------------- - let stack = Raw2Stack.rawProg2Stack rawopt + let stack = Raw2Stack.rawProg2Stack rawopt when verbose $ printSep "GENARTING STACK" when verbose $ writeFileD "out/out.stack" (show stack) - let stackjs = Stack2JS.irProg2JSString compileMode debugOut stack + let stackjs = Stack2JS.irProg2JSString compileMode debugOut stack let jsFile = outFile flags (fromJust fname) - writeFile jsFile stackjs + writeFile jsFile stackjs + - case exports of Nothing -> return () Just es -> writeExports jsFile es when verbose printHr - + exitSuccess diff --git a/compiler/test/Golden.hs b/compiler/test/Golden.hs index f599c56..225ed4f 100644 --- a/compiler/test/Golden.hs +++ b/compiler/test/Golden.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + import Test.Tasty (defaultMain, TestTree, testGroup) import Test.Tasty.Golden (goldenVsStringDiff, goldenVsString, findByExtension) import System.Directory @@ -10,6 +12,17 @@ import System.Info import System.Environment -- import qualified System.IO.Strict +-- When having multiple optimizations / optional compiler stages or +-- other flags changing the output, probably want to generate all combinations +-- and run the tests on them. +newtype TestConfig = TestConfig { tcRawOpt :: Bool } + +ppTestConfig TestConfig{..} = + if tcRawOpt + then "Raw optimized" + else "Raw NOT optimized" + + getOptionalInput :: String -> IO String getOptionalInput testfile = do inputExists <- doesFileExist $ testfile ++ ".input" @@ -20,52 +33,66 @@ getOptionalInput testfile = do return "" +mkRunArgs :: TestConfig -> [String] +mkRunArgs TestConfig{..} = + if tcRawOpt + then [] + else ["--no-rawopt"] -runLocal testname = do - input <- getOptionalInput testname - readProcessWithExitCode "./local.sh" [testname] input +runLocal :: String -> TestConfig -> IO (ExitCode, String, String) +runLocal testname tc = do + input <- getOptionalInput testname + readProcessWithExitCode "./local.sh" (mkRunArgs tc ++ [testname]) input -- We use this to test the commands with timeouts. -- Observe the current value for the timeout is 2 seconds. -runTimeout n testname = do - let timeout = if os == "darwin" then "gtimeout" else "timeout" - readProcessWithExitCode timeout [show n, "./local.sh", testname] "" +runTimeout :: Int -> String -> TestConfig -> IO (ExitCode, String, String) +runTimeout n testname tc = do + let timeout = if os == "darwin" then "gtimeout" else "timeout" + readProcessWithExitCode timeout ([show n, "./local.sh"] ++ mkRunArgs tc ++ [testname]) "" -runPositiveTimeout :: Int -> String -> IO LBS.ByteString -runPositiveTimeout t testname = do - (code, out, err) <- runTimeout t testname +runPositiveTimeout :: Int -> String -> TestConfig -> IO LBS.ByteString +runPositiveTimeout t testname tc = do + (code, out, err) <- runTimeout t testname tc case code of ExitFailure _ -> return $ (LBS.fromStrict . Data.ByteString.Char8.pack) (out ++ err) ExitSuccess -> fail testname -runPositive :: String -> IO LBS.ByteString -runPositive testname = do - (code, out, err) <- runLocal testname +runPositive :: String -> TestConfig -> IO LBS.ByteString +runPositive testname tc = do + (code, out, err) <- runLocal testname tc case code of ExitSuccess -> return $ (LBS.fromStrict . Data.ByteString.Char8.pack) out ExitFailure _ -> fail testname -runNegative :: String -> IO LBS.ByteString -runNegative testname = do - (code, out, err) <- runLocal testname +runNegative :: String -> TestConfig -> IO LBS.ByteString +runNegative testname tc = do + (code, out, err) <- runLocal testname tc case code of ExitFailure _ -> return $ (LBS.fromStrict . Data.ByteString.Char8.pack) err ExitSuccess -> fail testname main :: IO () -main = do +main = do troupeDir <- getEnv "TROUPE" setCurrentDirectory troupeDir - defaultMain =<< goldenTests + -- Create tests + tests <- mapM goldenTests + [ TestConfig { tcRawOpt = True } + , TestConfig { tcRawOpt = False } + ] + -- Run tests + defaultMain $ testGroup "Troupe golden tests" tests -goldenTests = do +goldenTests :: TestConfig -> IO TestTree +goldenTests tc = do let extensions = [".trp", ".pico", ".atto", ".picox", ".femto"] negativeTestsForCompiler <- findByExtension extensions "tests/cmp" positiveTestsForRuntime <- findByExtension extensions "tests/rt/pos" @@ -74,19 +101,19 @@ goldenTests = do timeoutTestsForRuntime <- findByExtension extensions "tests/rt/timeout/blocking" divergingTestsForRuntime <- findByExtension extensions "tests/rt/timeout/diverging" - return $ (testGroup "Troupe golden tests" + return $ (testGroup ("Troupe golden tests (" ++ ppTestConfig tc ++ ")") $ map ($ tc) [ compilerTests negativeTestsForCompiler , runtimeTests $ concat [positiveTestsForRuntime, negativeTestsForRuntime, warningTestsForRuntime] , timeoutTests timeoutTestsForRuntime , divergingTests divergingTestsForRuntime ] ) -compilerTests testFiles = +compilerTests testFiles tc = testGroup "Compiler (negative) tests" [goldenVsString troupeFile goldenFile - (runNegative troupeFile) + (runNegative troupeFile tc) | troupeFile <- testFiles , let goldenFile = replaceExtension troupeFile ".golden" ] @@ -103,39 +130,38 @@ diff_n ref new = ["tests/_util/diff_n.sh", ref, new ] -- 2019-03-04: AA: we should probably use type classes... -runtimeTests testFiles = +runtimeTests testFiles tc = testGroup "Runtime tests" [ goldenVsStringDiff troupeFile diff goldenFile - (runPositive troupeFile) + (runPositive troupeFile tc) | troupeFile <- testFiles , let goldenFile = replaceExtension troupeFile ".golden" ] -timeoutTests testFiles = +timeoutTests testFiles tc = testGroup "Timeout tests" [ goldenVsStringDiff troupeFile diff goldenFile - (runPositiveTimeout 8 troupeFile) + (runPositiveTimeout 8 troupeFile tc) | troupeFile <- testFiles , let goldenFile = replaceExtension troupeFile ".golden" ] -divergingTests testFiles = +divergingTests testFiles tc = testGroup "Diverging tests" [ goldenVsStringDiff troupeFile diff_n goldenFile - (runPositiveTimeout 8 troupeFile) + (runPositiveTimeout 8 troupeFile tc) | troupeFile <- testFiles , let goldenFile = replaceExtension troupeFile ".golden" - ] + ] - \ No newline at end of file diff --git a/local.sh b/local.sh index aa2603a..47e05ca 100755 --- a/local.sh +++ b/local.sh @@ -2,7 +2,7 @@ tmp=`mktemp`.js -$TROUPE/bin/troupec $1 --output=$tmp +$TROUPE/bin/troupec $@ --output=$tmp if [ $? -eq 0 ]; then node --stack-trace-limit=1000 $TROUPE/rt/built/troupe.mjs -f=$tmp --localonly #--debug