module LLVM.Analysis.Util.Testing (
TestDescriptor(..),
BuildException(..),
testAgainstExpected,
buildModule,
readInputAndExpected
) where
import Control.Exception as E
import Control.Monad ( when )
import Data.Typeable ( Typeable )
import System.Directory ( findExecutable )
import System.Environment ( getEnv )
import System.Exit ( ExitCode(ExitSuccess) )
import System.FilePath
import System.FilePath.Glob
import System.IO.Error
import System.IO.Temp
import System.Process as P
import Test.Framework ( defaultMain, Test )
import Test.Framework.Providers.HUnit
import LLVM.Analysis
data BuildException = ClangFailed FilePath ExitCode
| NoBuildMethodForInput FilePath
| OptFailed FilePath ExitCode
| NoOptBinaryFound
deriving (Typeable, Show)
instance Exception BuildException
data TestDescriptor =
forall a. (Read a) => TestDescriptor {
testPattern :: String,
testExpectedMapping :: FilePath -> FilePath,
testResultBuilder :: Module -> a,
testResultComparator :: String -> a -> a -> IO ()
}
readInputAndExpected :: (Read a)
=> [String]
-> (FilePath -> IO Module)
-> (FilePath -> FilePath)
-> FilePath
-> IO (FilePath, Module, a)
readInputAndExpected optOpts parseFile expectedFunc inputFile = do
let exFile = expectedFunc inputFile
exContent <- readFile exFile
let expected = length exContent `seq` read exContent
m <- buildModule [] optOpts parseFile inputFile
return (inputFile, m, expected)
testAgainstExpected :: [String]
-> (FilePath -> IO Module)
-> [TestDescriptor]
-> IO ()
testAgainstExpected optOpts parseFile testDescriptors = do
caseSets <- mapM mkDescriptorSet testDescriptors
defaultMain $ concat caseSets
where
mkDescriptorSet :: TestDescriptor -> IO [Test]
mkDescriptorSet TestDescriptor { testPattern = pat
, testExpectedMapping = mapping
, testResultBuilder = br
, testResultComparator = cmp
} = do
testInputFiles <- namesMatching pat
inputsAndExpecteds <- mapM (readInputAndExpected optOpts parseFile mapping) testInputFiles
mapM (mkTest br cmp) inputsAndExpecteds
mkTest br cmp (file, m, expected) = do
let actual = br m
return $ testCase file $ cmp file expected actual
optify :: [String] -> FilePath -> FilePath -> IO ()
optify args inp optFile = do
opt <- findOpt
let cmd = P.proc opt ("-o" : optFile : inp : args)
(_, _, _, p) <- createProcess cmd
rc <- waitForProcess p
when (rc /= ExitSuccess) $ E.throwIO $ OptFailed inp rc
buildModule :: [String]
-> [String]
-> (FilePath -> IO Module)
-> FilePath
-> IO Module
buildModule clangOpts optOpts parseFile inputFilePath = do
clang <- catchIOError (getEnv "LLVM_CLANG") (const (return "clang"))
clangxx <- catchIOError (getEnv "LLVM_CLANGXX") (const (return "clang++"))
case takeExtension inputFilePath of
".ll" -> simpleBuilder inputFilePath
".bc" -> simpleBuilder inputFilePath
".c" -> clangBuilder inputFilePath clang
".C" -> clangBuilder inputFilePath clangxx
".cxx" -> clangBuilder inputFilePath clangxx
".cpp" -> clangBuilder inputFilePath clangxx
_ -> E.throwIO $ NoBuildMethodForInput inputFilePath
where
simpleBuilder inp
| null optOpts = parseFile inp
| otherwise =
withSystemTempFile ("opt_" ++ takeFileName inp) $ \optFname _ -> do
optify optOpts inp optFname
parseFile optFname
clangBuilder inp driver =
withSystemTempFile ("base_" ++ takeFileName inp) $ \baseFname _ -> do
let cOpts = clangOpts ++ ["-emit-llvm", "-o" , baseFname, "-c", inp]
(_, _, _, p) <- createProcess $ proc driver cOpts
rc <- waitForProcess p
when (rc /= ExitSuccess) $ E.throwIO $ ClangFailed inputFilePath rc
case null optOpts of
True -> parseFile baseFname
False ->
withSystemTempFile ("opt_" ++ takeFileName inp) $ \optFname _ -> do
optify optOpts baseFname optFname
parseFile optFname
findOpt :: IO FilePath
findOpt = do
let fbin = findBin [ "opt", "opt-3.3", "opt-3.2", "opt-3.1", "opt-3.0" ]
catchIOError (getEnv "LLVM_OPT") (const fbin)
where
findBin [] = E.throwIO NoOptBinaryFound
findBin (bin:bins) = do
b <- findExecutable bin
case b of
Just e -> return e
Nothing -> findBin bins