add a generic benchmark executable

This commit is contained in:
Corey O'Connor 2013-01-27 21:41:59 -08:00
parent 9c0f1e7f3d
commit a029bda581
6 changed files with 113 additions and 30 deletions

View File

@ -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 )

11
src/Graphics/Vty/Error.hs Normal file
View File

@ -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.

View File

@ -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

View File

@ -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

48
test/benchmark.hs Normal file
View File

@ -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)

View File

@ -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