Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : master
http://hackage.haskell.org/trac/ghc/changeset/cec2c3f6f99c3eea35bf1d1eb952ad9477166999 >--------------------------------------------------------------- commit cec2c3f6f99c3eea35bf1d1eb952ad9477166999 Author: Simon Marlow <[email protected]> Date: Wed May 25 14:40:46 2011 +0100 add tibbe's perf regression test for #4978 >--------------------------------------------------------------- tests/ghc-regress/perf/should_run/T4978.hs | 125 ++++++++++++++++++++++++ tests/ghc-regress/perf/should_run/T4978.stdout | 1 + tests/ghc-regress/perf/should_run/all.T | 13 +++ 3 files changed, 139 insertions(+), 0 deletions(-) diff --git a/tests/ghc-regress/perf/should_run/T4978.hs b/tests/ghc-regress/perf/should_run/T4978.hs new file mode 100644 index 0000000..6413b01 --- /dev/null +++ b/tests/ghc-regress/perf/should_run/T4978.hs @@ -0,0 +1,125 @@ +module Main (main) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import Data.Monoid +import Foreign + +newtype Builder = Builder { + runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] + } + +instance Monoid Builder where + mempty = empty + {-# INLINE mempty #-} + mappend = append + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +empty :: Builder +empty = Builder (\ k b -> b `seq` k b) +{-# INLINE empty #-} + +singleton :: Word8 -> Builder +singleton = writeN 1 . flip poke +{-# INLINE singleton #-} + +append :: Builder -> Builder -> Builder +append (Builder f) (Builder g) = Builder (f . g) +{-# INLINE [0] append #-} + +-- Our internal buffer type +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used bytes + {-# UNPACK #-} !Int -- length left + +-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, +-- yielding a new chunk in the result lazy 'L.ByteString'. +flush :: Builder +flush = Builder $ \ k buf@(Buffer p o u l) -> + if u == 0 + then k buf + else S.PS p o u : k (Buffer p (o+u) 0 l) + +-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. +-- The construction work takes place if and when the relevant part of +-- the lazy 'L.ByteString' is demanded. +-- +toLazyByteString :: Builder -> L.ByteString +toLazyByteString m = L.fromChunks $ unsafePerformIO $ do + buf <- newBuffer defaultSize + return (runBuilder (m `append` flush) (const []) buf) +{-# INLINE toLazyByteString #-} + +defaultSize :: Int +defaultSize = 32 * k - overhead + where k = 1024 + overhead = 2 * sizeOf (undefined :: Int) + +-- | Sequence an IO operation on the buffer +unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder +unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do + buf' <- f buf + return (k buf') +{-# INLINE unsafeLiftIO #-} + +-- | Get the size of the buffer +withSize :: (Int -> Builder) -> Builder +withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> runBuilder (f l) k buf + +-- | Ensure that there are at least @n@ many bytes available. +ensureFree :: Int -> Builder +ensureFree n = n `seq` withSize $ \ l -> + if n <= l then empty else + flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) +{-# INLINE [0] ensureFree #-} + +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some +-- bytes into the memory. +writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder +writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) +{-# INLINE [0] writeN #-} + +writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer +writeNBuffer n f (Buffer fp o u l) = do + withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return (Buffer fp o (u+n) (l-n)) +{-# INLINE writeNBuffer #-} + +newBuffer :: Int -> IO Buffer +newBuffer size = do + fp <- S.mallocByteString size + return $! Buffer fp 0 0 size +{-# INLINE newBuffer #-} + +-- Merge buffer bounds checks. +{-# RULES +"append/writeN" forall a b (f::Ptr Word8 -> IO ()) + (g::Ptr Word8 -> IO ()) ws. + append (writeN a f) (append (writeN b g) ws) = + append (writeN (a+b) (\p -> f p >> g (p `plusPtr` a))) ws + +"writeN/writeN" forall a b (f::Ptr Word8 -> IO ()) + (g::Ptr Word8 -> IO ()). + append (writeN a f) (writeN b g) = + writeN (a+b) (\p -> f p >> g (p `plusPtr` a)) + +"ensureFree/ensureFree" forall a b . + append (ensureFree a) (ensureFree b) = ensureFree (max a b) + #-} + +-- Test case + +-- Argument must be a multiple of 4. +test :: Int -> Builder +test 0 = mempty +test n = singleton 1 `mappend` + (singleton 2 `mappend` + (singleton 3 `mappend` + (singleton 4 `mappend` test (n-4)))) + +main = print $ L.length $ toLazyByteString $ test 10000000 diff --git a/tests/ghc-regress/perf/should_run/T4978.stdout b/tests/ghc-regress/perf/should_run/T4978.stdout new file mode 100644 index 0000000..825319e --- /dev/null +++ b/tests/ghc-regress/perf/should_run/T4978.stdout @@ -0,0 +1 @@ +10000000 diff --git a/tests/ghc-regress/perf/should_run/all.T b/tests/ghc-regress/perf/should_run/all.T index 25c157d..6a71be2 100644 --- a/tests/ghc-regress/perf/should_run/all.T +++ b/tests/ghc-regress/perf/should_run/all.T @@ -120,3 +120,16 @@ test('T5113', compile_and_run, ['-O']) + +test('T4978', + [if_wordsize(32, + stats_num_field('bytes allocated', 4500000, + 5500000)), + if_wordsize(64, + stats_num_field('bytes allocated', 9000000, + 11000000)), + # expected value: 10137680 (amd64/Linux) + only_ways(['normal']) + ], + compile_and_run, + ['-O2']) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
