diff --git a/HSBencher.hs b/HSBencher.hs --- a/HSBencher.hs +++ b/HSBencher.hs @@ -9,8 +9,8 @@ -- won't list all the bindings for reexports. -- * The main entrypoints for building new benchmark suites. - defaultMainWithBechmarks, defaultMainModifyConfig, - addPlugin, + defaultMainModifyConfig, + addPlugin, addBenchmarks, -- * Command-line configuration Flag(..), @@ -30,3 +30,9 @@ import HSBencher.Internal.App import HSBencher.Harvesters import HSBencher.Internal.Config (addPlugin) + +-- | A convenience combinator for composing together with other +-- `Config` transformers. This one adds benchmarks to whatever is +-- already in the `benchlist` field. +addBenchmarks :: [Benchmark DefaultParamMeaning] -> Config -> Config +addBenchmarks ls conf = conf { benchlist = ls ++ benchlist conf } diff --git a/HSBencher/Internal/App.hs b/HSBencher/Internal/App.hs --- a/HSBencher/Internal/App.hs +++ b/HSBencher/Internal/App.hs @@ -12,7 +12,7 @@ -} module HSBencher.Internal.App - (defaultMainWithBechmarks, defaultMainModifyConfig, + (defaultMainModifyConfig, Flag(..), all_cli_options, fullUsageInfo) where @@ -162,11 +162,11 @@ ---------------------------------------- -- TODO (One option woud be dynamic feedback where if the first one -- takes a long time we don't bother doing more trials.) - nruns <- runB_runTrials fullargs benchTimeOut bldres runconfig + (retries,nruns) <- runB_runTrials fullargs benchTimeOut bldres runconfig -- (3) Produce output to the right places: ------------------------------------------ - runC_produceOutput (args,fullargs) nruns testRoot progname runconfig + runC_produceOutput (args,fullargs) (retries,nruns) testRoot progname runconfig ------------------------------------------------------------ @@ -197,15 +197,17 @@ ------------------------------------------------------------ runB_runTrials :: [String] -> Maybe Double -> BuildResult - -> [(a, ParamSetting)] -> ReaderT Config IO [RunResult] + -> [(a, ParamSetting)] -> ReaderT Config IO (Int,[RunResult]) runB_runTrials fullargs benchTimeOut bldres runconfig = do Config{ retryFailed, trials } <- ask - trialLoop 1 trials (fromMaybe 0 retryFailed) [] - where - trialLoop ind trials retries acc - | ind > trials = return $ reverse acc + let retryBudget = fromMaybe 0 retryFailed + trialLoop 1 trials retryBudget 0 [] + where + trialLoop :: Int -> Int -> Int -> Int -> [RunResult] -> ReaderT Config IO (Int,[RunResult]) + trialLoop ind trials retries retryAcc acc + | ind > trials = return (retryAcc, reverse acc) | otherwise = do - Config{ runTimeOut, shortrun, harvesters, retryFailed } <- ask + Config{ runTimeOut, shortrun, harvesters } <- ask log$ printf " Running trial %d of %d" ind trials log " ------------------------" let envVars = toEnvVars runconfig @@ -254,17 +256,17 @@ then if retries > 0 then do logT$ " Failed Trial! Retrying config, repeating trial "++ show ind++", "++show (retries - 1)++" retries left." - trialLoop ind trials (retries - 1) acc + trialLoop ind trials (retries - 1) (retryAcc + 1) acc else do logT$ " Failed Trial "++show ind++"! Out of retries, aborting remaining trials." - return (this:acc) + return (retries, this:acc) else do -- When we advance, we reset the retry counter: Config{ retryFailed } <- ask - trialLoop (ind+1) trials (fromMaybe 0 retryFailed) (this:acc) + trialLoop (ind+1) trials (fromMaybe 0 retryFailed) retryAcc (this:acc) ------------------------------------------------------------ -runC_produceOutput :: ([String], [String]) -> [RunResult] -> String -> Maybe String +runC_produceOutput :: ([String], [String]) -> (Int,[RunResult]) -> String -> Maybe String -> [(DefaultParamMeaning, ParamSetting)] -> ReaderT Config IO Bool -runC_produceOutput (args,fullargs) nruns testRoot progname runconfig = do +runC_produceOutput (args,fullargs) (retries,nruns) testRoot progname runconfig = do let numthreads = foldl (\ acc (x,_) -> case x of Threads n -> n @@ -352,7 +354,7 @@ , _ALLTIMES = unwords$ map (show . gettime) goodruns , _ALLJITTIMES = jittimes , _TRIALS = trials - + , _RETRIES = retries -- Should the user specify how the -- results over many goodruns are reduced ? -- I think so. @@ -450,11 +452,11 @@ -- benchF = get "BENCHLIST" "benchlist.txt" -- putStrLn$ hsbencher_tag ++ " Reading benchmark list from file: " error "FINISHME: defaultMain requires reading benchmark list from a file. Implement it!" --- defaultMainWithBechmarks undefined +-- defaultMainWithBenchmarks undefined -- | In this version, user provides a list of benchmarks to run, explicitly. -defaultMainWithBechmarks :: [Benchmark DefaultParamMeaning] -> IO () -defaultMainWithBechmarks benches = do +defaultMainWithBenchmarks :: [Benchmark DefaultParamMeaning] -> IO () +defaultMainWithBenchmarks benches = do defaultMainModifyConfig (\ conf -> conf{ benchlist=benches }) -- | Multiple lines of usage info help docs. @@ -523,10 +525,6 @@ -- (unwords$ versionTags version) exitSuccess - let printHelp :: [OptDescr ()] -> IO () - printHelp opts = - error "FINISHME" - ------------------------------------------------------------ putStrLn$ "\n"++hsbencher_tag++"Harvesting environment data to build Config." conf0 <- getConfig options [] @@ -551,8 +549,9 @@ let fullBenchList = case conf1 of Config{benchlist=ls} -> - (unlines [ (target ++ (unwords cmdargs)) - | Benchmark{cmdargs,target} <- ls]) + (unlines [ (maybe "" (++" = ") progname) ++ + (target ++ (unwords cmdargs)) + | Benchmark{progname, cmdargs,target} <- ls]) when showBenchs $ do putStrLn ("All benchmarks handled by this script:\n"++fullBenchList) exitSuccess unless (null errs) $ do diff --git a/HSBencher/Types.hs b/HSBencher/Types.hs --- a/HSBencher/Types.hs +++ b/HSBencher/Types.hs @@ -539,9 +539,10 @@ , _ALLJITTIMES :: String -- ^ Space separated list of numbers, JIT compile times -- (if applicable), with a 1-1 correspondence to the exec times in ALLTIMES. -- Time should not be double counted as JIT and exec time; these should be disjoint. + , _RETRIES :: Int -- ^ The number of times any trial of the benchmark was reexecuted because of failure. , _CUSTOM :: [(Tag, SomeResult)] - -- A List of custom results + -- ^ A List of custom results -- The tag corresponds to column "title" } deriving (Show,Read,Ord,Eq) @@ -584,6 +585,7 @@ , _MEDIANTIME_ALLOCRATE = Nothing , _MEDIANTIME_MEMFOOTPRINT = Nothing , _ALLJITTIMES = "" + , _RETRIES = 0 , _CUSTOM = [] } @@ -626,6 +628,7 @@ , ("MEDIANTIME_ALLOCRATE", fromMaybe "" $ fmap show $ _MEDIANTIME_ALLOCRATE r) , ("MEDIANTIME_MEMFOOTPRINT", fromMaybe "" $ fmap show $ _MEDIANTIME_MEMFOOTPRINT r) , ("ALLJITTIMES", _ALLJITTIMES r) + , ("RETRIES", show (_RETRIES r)) ] ++ map (\ (t,s) -> (t, show s)) (_CUSTOM r) diff --git a/hsbencher.cabal b/hsbencher.cabal --- a/hsbencher.cabal +++ b/hsbencher.cabal @@ -1,6 +1,6 @@ name: hsbencher -version: 1.12 +version: 1.14 -- CHANGELOG: -- 1.0 : Initial release, new flexible benchmark format. -- 1.1 : Change interface to RunInPlace @@ -42,6 +42,9 @@ -- 1.10.0.0 : add addPlugin, remove defaultPlugConf -- 1.11.0.0 : remove toRunFlags, add RuntimeArg -- 1.12 : breaking change to `BuildMethod` type: expose `Config` to `compile` +-- 1.12.1 : Update the format of "-l" printout, but its behavior is unchanged. +-- 1.13 : Add RETRIES field to the core result schema +-- 1.14 : remove terrible function with typo in name, add addBenchmarks synopsis: Launch and gather data from Haskell and non-Haskell benchmarks.