module HSBencher.Methods.Builtin
(makeMethod, ghcMethod, cabalMethod,
)
where
import Control.Monad
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import System.Process
import System.Directory
import System.FilePath
import Text.Printf
import Prelude hiding (log)
import HSBencher.Types
import HSBencher.Internal.Logging (log)
import HSBencher.Internal.Utils (runLogged)
makeMethod :: BuildMethod
makeMethod = BuildMethod
{ methodName = "make"
, canBuild = (IsExactly "Makefile")
`PredOr`
InDirectoryWithExactlyOne (IsExactly "Makefile")
, concurrentBuild = False
, setThreads = Nothing
, clean = \ pathMap _ target -> do
doMake pathMap target $ \ makePath -> do
_ <- runSuccessful subtag (makePath++" clean")
return ()
, compile = \ Config{pathRegistry, runTimeOut} _bldid flags target -> do
doMake pathRegistry target $ \ makePath -> do
absolute <- liftIO getCurrentDirectory
_ <- runSuccessful subtag (makePath++" COMPILE_ARGS='"++ unwords flags ++"'")
log$ tag++"Done building with Make, assuming this benchmark needs to run in-place..."
let runit args envVars =
CommandDescr
{ command = ShellCommand (makePath++" run RUN_ARGS='"++ unwords args ++"'")
, timeout = runTimeOut
, workingDir = Just absolute
, tolerateError = False
, envVars
}
return (RunInPlace runit)
}
where
tag = " [makeMethod] "
subtag = " [make] "
doMake pathMap target action = do
isdir <- liftIO$ doesDirectoryExist target
let dir = if isdir then target
else takeDirectory target
makePath = M.findWithDefault "make" "make" pathMap
inDirectory dir (action makePath)
ghcMethod :: BuildMethod
ghcMethod = BuildMethod
{ methodName = "ghc"
, canBuild = WithExtension ".hs"
, concurrentBuild = True
, setThreads = Just $ \ n -> [ CompileParam "-threaded -rtsopts"
, RuntimeParam ("+RTS -N"++ show n++" -RTS")]
, clean = \ _cfg bldid _target -> do
let buildD = "buildoutput_" ++ bldid
liftIO$ do b <- doesDirectoryExist buildD
when b$ removeDirectoryRecursive buildD
return ()
, compile = \ Config{pathRegistry} bldid flags target -> do
let dir = takeDirectory target
file = takeBaseName target
suffix = "_"++bldid
ghcPath = M.findWithDefault "ghc" "ghc" pathRegistry
log$ tag++" Building target with GHC method: "++show target
inDirectory dir $ do
let buildD = "buildoutput_" ++ bldid
liftIO$ createDirectoryIfMissing True buildD
let dest = buildD </> file ++ suffix
_ <- runSuccessful " [ghc] " $
printf "%s %s -outputdir ./%s -o %s %s"
ghcPath file buildD dest (unwords flags)
return (StandAloneBinary$ dir </> dest)
}
where
tag = " [ghcMethod] "
cabalMethod :: BuildMethod
cabalMethod = BuildMethod
{ methodName = "cabal"
, canBuild = dotcab `PredOr`
InDirectoryWithExactlyOne dotcab
, concurrentBuild = True
, setThreads = Just $ \ n -> [ CompileParam "--ghc-option='-threaded' --ghc-option='-rtsopts'"
, RuntimeParam ("+RTS -N"++ show n++" -RTS")]
, clean = \ _ _ _target -> return ()
, compile = \ Config{pathRegistry} bldid flags target -> do
benchroot <- liftIO$ getCurrentDirectory
let suffix = "_"++bldid
cabalPath = M.findWithDefault "cabal" "cabal" pathRegistry
_ghcPath = M.findWithDefault "ghc" "ghc" pathRegistry
binD = benchroot </> "bin"
liftIO$ createDirectoryIfMissing True binD
dir <- liftIO$ getDir target
inDirectory dir $ do
let tmpdir = benchroot </> dir </> "temp"++suffix
_ <- runSuccessful tag $ "rm -rf "++tmpdir
_ <- runSuccessful tag $ "mkdir "++tmpdir
log$ tag++" Switched to "++dir++", and cleared temporary directory."
curr_dir <- liftIO$ getCurrentDirectory
log$ tag++" Curently in directory: " ++ curr_dir
let cmd0 = cabalPath++" install "++" "++unwords flags
cmd1 = cmd0++" --only-dependencies"
cmd2 = cmd0++" --bindir="++tmpdir++" ./ --program-suffix="++suffix
log$ tag++"Running cabal command for deps only: "++cmd1
_ <- runSuccessful tag cmd1
log$ tag++"Running cabal command to build benchmark: "++cmd2
_ <- runSuccessful tag cmd2
ls <- liftIO$ filesInDir tmpdir
case ls of
[f] -> do _ <- runSuccessful tag$ "mv "++tmpdir++"/"++f++" "++binD++"/"
return (StandAloneBinary$ binD </> f)
[] -> error$"No binaries were produced from building cabal file! In: "++show dir
_ -> error$"Multiple binaries were produced from building cabal file!:"
++show ls ++" In: "++show dir
}
where
dotcab = WithExtension ".cabal"
tag = " [cabalMethod] "
getDir :: FilePath -> IO FilePath
getDir path = do
b <- doesDirectoryExist path
b2 <- doesFileExist path
if b
then return path
else if b2
then return (takeDirectory path)
else error$ "getDir: benchmark target path does not exist at all: "++path
inDirectory :: (MonadIO m) => FilePath -> m a -> m a
inDirectory dir act = do
orig <- liftIO$ getCurrentDirectory
liftIO$ setCurrentDirectory dir
x <- act
liftIO$ setCurrentDirectory orig
return x
filesInDir :: FilePath -> IO [FilePath]
filesInDir d = do
inDirectory d $ do
ls <- getDirectoryContents "."
filterM doesFileExist ls
runSuccessful :: String -> String -> BenchM [B.ByteString]
runSuccessful tag cmd = do
(res,lns) <- runLogged tag cmd
case res of
ExitError code -> error$ "expected this command to succeed! But it exited with code "++show code++ ":\n "++ cmd
RunTimeOut {} -> error$ "Methods.hs/runSuccessful - error! The following command timed out:\n "++show cmd
RunCompleted {} -> return lns