From a029bda581fc81bd88fddfbd515a6e99c034ce0e Mon Sep 17 00:00:00 2001 From: Corey O'Connor Date: Sun, 27 Jan 2013 21:41:59 -0800 Subject: [PATCH] add a generic benchmark executable --- src/Graphics/Vty/DisplayRegion.hs | 2 +- src/Graphics/Vty/Error.hs | 11 ++++++ test/BenchRenderChar.hs | 30 +++++++------- test/{Bench.hs => BenchVerticalScroll.hs} | 20 +++++----- test/benchmark.hs | 48 +++++++++++++++++++++++ vty.cabal | 32 +++++++++++++-- 6 files changed, 113 insertions(+), 30 deletions(-) create mode 100644 src/Graphics/Vty/Error.hs rename test/{Bench.hs => BenchVerticalScroll.hs} (65%) create mode 100644 test/benchmark.hs diff --git a/src/Graphics/Vty/DisplayRegion.hs b/src/Graphics/Vty/DisplayRegion.hs index b6ff68f..a98be87 100644 --- a/src/Graphics/Vty/DisplayRegion.hs +++ b/src/Graphics/Vty/DisplayRegion.hs @@ -6,7 +6,7 @@ import Data.Word -- | Region of the terminal that vty will output to. Units are columns not characters. data DisplayRegion = DisplayRegion - { region_width :: !Word + { region_width :: !Word , region_height :: !Word } deriving ( Show, Eq ) diff --git a/src/Graphics/Vty/Error.hs b/src/Graphics/Vty/Error.hs new file mode 100644 index 0000000..b5b2c0f --- /dev/null +++ b/src/Graphics/Vty/Error.hs @@ -0,0 +1,11 @@ +module Graphics.Vty.Error + where + +import Control.Exception + + +-- | The type of exceptions specific to vty. +-- +-- These have fully qualified names by default since, IMO, exception handling requires this. +data VtyException + = VtyFailure String -- | Uncategorized failure specific to vty. diff --git a/test/BenchRenderChar.hs b/test/BenchRenderChar.hs index 33c79be..ff1e8d3 100644 --- a/test/BenchRenderChar.hs +++ b/test/BenchRenderChar.hs @@ -2,31 +2,33 @@ - This is what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar images horizontally - composed should provide no worse performance than a fill render op. -} +module BenchRenderChar where import Graphics.Vty import Control.Monad ( forM_ ) import System.Time -main = do +bench_0 = do vty <- mkVty - (w, h) <- getSize vty + DisplayRegion w h <- display_bounds $ terminal vty let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']] - start_time_0 <- getClockTime forM_ test_chars $ \test_char -> do let test_image = test_image_using_renderChar test_char w h - out_pic = pic { pImage = test_image } + out_pic = pic_for_image test_image update vty out_pic - end_time_0 <- getClockTime - let start_time_1 = end_time_0 - forM_ test_chars $ \test_char -> do - let test_image = renderFill attr test_char w h - out_pic = pic { pImage = test_image } - update vty out_pic - end_time_1 <- getClockTime shutdown vty - putStrLn $ timeDiffToString $ diffClockTimes end_time_0 start_time_0 - putStrLn $ timeDiffToString $ diffClockTimes end_time_1 start_time_1 -test_image_using_renderChar c w h = vertcat $ replicate h $ horzcat $ map (renderChar attr) (replicate w c) +test_image_using_renderChar c w h = vert_cat $ replicate (fromIntegral h) + $ horiz_cat $ map (char def_attr) + (replicate (fromIntegral w) c) +bench_1 = do + vty <- mkVty + DisplayRegion w h <- display_bounds $ terminal vty + let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']] + forM_ test_chars $ \test_char -> do + let test_image = char_fill def_attr test_char w h + out_pic = pic_for_image test_image + update vty out_pic + shutdown vty diff --git a/test/Bench.hs b/test/BenchVerticalScroll.hs similarity index 65% rename from test/Bench.hs rename to test/BenchVerticalScroll.hs index 19d8aae..4ed60eb 100644 --- a/test/Bench.hs +++ b/test/BenchVerticalScroll.hs @@ -1,4 +1,4 @@ -module Main where +module BenchVerticalScroll where import Graphics.Vty hiding ( pad ) @@ -16,15 +16,9 @@ import System.Random main = do let fixed_gen = mkStdGen 0 setStdGen fixed_gen - args <- getArgs - case args of - [] -> mkVty >>= liftM2 (>>) (run $ Just 0) shutdown - ["--delay"] -> mkVty >>= liftM2 (>>) (run $ Just 1000000) shutdown - ["--slow"] -> mkVty >>= liftM2 (>>) (run Nothing ) shutdown - _ -> fail "usage: ./Bench [--slow|--delay]" + mkVty >>= liftM2 (>>) run shutdown -run (Just delay) vt = mapM_ (\p -> update vt p >> threadDelay delay) . benchgen =<< display_bounds (terminal vt) -run Nothing vt = mapM_ (update vt) (benchgen $ DisplayRegion 200 100) +run vt = mapM_ (\p -> update vt p) . benchgen =<< display_bounds (terminal vt) -- Currently, we just do scrolling. takem :: (a -> Word) -> Word -> [a] -> ([a],[a]) @@ -54,9 +48,13 @@ pad :: Word -> Image -> Image pad ml img = img <|> char_fill def_attr ' ' (ml - image_width img) 1 clines :: StdGen -> Word -> [Image] -clines g maxll = map (pad maxll . horiz_cat . map (uncurry string)) $ fold (toEnum . length . snd) (lengths maxll g1) (nums g2) +clines g maxll = map (pad maxll . horiz_cat . map (uncurry string)) + $ fold (toEnum . length . snd) (lengths maxll g1) (nums g2) where (g1,g2) = split g benchgen :: DisplayRegion -> [Picture] -benchgen (DisplayRegion w h) = take 500 $ map ((\i -> pic_for_image i) . vert_cat . take (fromEnum h)) $ tails $ clines (mkStdGen 42) w +benchgen (DisplayRegion w h) + = take 2000 $ map ((\i -> pic_for_image i) . vert_cat . take (fromEnum h)) + $ tails + $ clines (mkStdGen 80) w diff --git a/test/benchmark.hs b/test/benchmark.hs new file mode 100644 index 0000000..d62ea4a --- /dev/null +++ b/test/benchmark.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Graphics.Vty + +import qualified BenchVerticalScroll +import qualified BenchRenderChar + +import Control.Monad + +import Data.Maybe +import Data.List + +import System.Environment +import System.Posix.Process + +main = do + args <- getArgs + let benches = [ ("vertical-scroll-0", BenchVerticalScroll.main) + , ("render-char-0", BenchRenderChar.bench_0) + , ("render-char-1", BenchRenderChar.bench_1)] + help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b + case args of + ["--help"] -> help + ["-h" ] -> help + _ -> do + let args' = if args /= [] + then args + else map fst benches + results <- forM args' $ \b -> do + case lookup b benches of + Just f -> bench b f + Nothing -> fail $ "No benchmark named " ++ b + print results + return () + +bench b f = do + putStrLn $ "starting " ++ b + start_times <- getProcessTimes + f + end_times <- getProcessTimes + let user_time = userTime end_times - userTime start_times + system_time = systemTime end_times - systemTime start_times + putStrLn $ "user time: " ++ show user_time + putStrLn $ "system time: " ++ show system_time + return (b, user_time, system_time) + diff --git a/vty.cabal b/vty.cabal index f24ad71..2fb1f6f 100644 --- a/vty.cabal +++ b/vty.cabal @@ -1,5 +1,5 @@ name: vty -version: 4.7.2 +version: 4.8.0 license: BSD3 license-file: LICENSE author: AUTHORS @@ -619,9 +619,33 @@ executable vty-interactive-terminal-test utf8-string >= 0.3 && < 0.4, vector >= 0.7 --- Bench.hs --- Bench2.hs --- BenchRenderChar.hs +executable vty-benchmark + main-is: benchmarsk.hs + + default-language: Haskell2010 + + hs-source-dirs: src test + + c-sources: cbits/gwinsz.c + cbits/set_term_timing.c + cbits/mk_wcwidth.c + + include-dirs: cbits + + build-depends: base >= 4 && < 5, + bytestring, + containers, + deepseq >= 1.1 && < 1.4, + ghc-prim, + mtl >= 1.1.1.0 && < 2.2, + parallel >= 2.2 && < 3.3, + parsec >= 2 && < 4, + string-qq, + terminfo >= 0.3 && < 0.4, + unix, + utf8-string >= 0.3 && < 0.4, + vector >= 0.7 + -- ControlTable.hs -- HereDoc.hs -- Test.hs