Make Block.h compile with c++ compilers
[ghc.git] / testsuite / tests / perf / should_run / T4978.hs
1 module Main (main) where
2
3 import qualified Data.ByteString as S
4 import qualified Data.ByteString.Lazy as L
5 import Data.ByteString.Internal (inlinePerformIO)
6 import qualified Data.ByteString.Internal as S
7 import Data.Semigroup
8 import Data.Monoid
9 import Foreign
10 import System.IO.Unsafe
11
12 newtype Builder = Builder {
13 runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
14 }
15
16 instance Semigroup Builder where
17 (<>) = append
18 {-# INLINE (<>) #-}
19
20 instance Monoid Builder where
21 mempty = empty
22 {-# INLINE mempty #-}
23 mconcat = foldr mappend mempty
24 {-# INLINE mconcat #-}
25
26 empty :: Builder
27 empty = Builder (\ k b -> b `seq` k b)
28 {-# INLINE empty #-}
29
30 singleton :: Word8 -> Builder
31 singleton = writeN 1 . flip poke
32 {-# INLINE singleton #-}
33
34 append :: Builder -> Builder -> Builder
35 append (Builder f) (Builder g) = Builder (f . g)
36 {-# INLINE [0] append #-}
37
38 -- Our internal buffer type
39 data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
40 {-# UNPACK #-} !Int -- offset
41 {-# UNPACK #-} !Int -- used bytes
42 {-# UNPACK #-} !Int -- length left
43
44 -- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,
45 -- yielding a new chunk in the result lazy 'L.ByteString'.
46 flush :: Builder
47 flush = Builder $ \ k buf@(Buffer p o u l) ->
48 if u == 0
49 then k buf
50 else S.PS p o u : k (Buffer p (o+u) 0 l)
51
52 -- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.
53 -- The construction work takes place if and when the relevant part of
54 -- the lazy 'L.ByteString' is demanded.
55 --
56 toLazyByteString :: Builder -> L.ByteString
57 toLazyByteString m = L.fromChunks $ unsafePerformIO $ do
58 buf <- newBuffer defaultSize
59 return (runBuilder (m `append` flush) (const []) buf)
60 {-# INLINE toLazyByteString #-}
61
62 defaultSize :: Int
63 defaultSize = 32 * k - overhead
64 where k = 1024
65 overhead = 2 * sizeOf (undefined :: Int)
66
67 -- | Sequence an IO operation on the buffer
68 unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
69 unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do
70 buf' <- f buf
71 return (k buf')
72 {-# INLINE unsafeLiftIO #-}
73
74 -- | Get the size of the buffer
75 withSize :: (Int -> Builder) -> Builder
76 withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> runBuilder (f l) k buf
77
78 -- | Ensure that there are at least @n@ many bytes available.
79 ensureFree :: Int -> Builder
80 ensureFree n = n `seq` withSize $ \ l ->
81 if n <= l then empty else
82 flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
83 {-# INLINE [0] ensureFree #-}
84
85 -- | Ensure that @n@ many bytes are available, and then use @f@ to write some
86 -- bytes into the memory.
87 writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
88 writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
89 {-# INLINE [0] writeN #-}
90
91 writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
92 writeNBuffer n f (Buffer fp o u l) = do
93 withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
94 return (Buffer fp o (u+n) (l-n))
95 {-# INLINE writeNBuffer #-}
96
97 newBuffer :: Int -> IO Buffer
98 newBuffer size = do
99 fp <- S.mallocByteString size
100 return $! Buffer fp 0 0 size
101 {-# INLINE newBuffer #-}
102
103 -- Merge buffer bounds checks.
104 {-# RULES
105 "append/writeN" forall a b (f::Ptr Word8 -> IO ())
106 (g::Ptr Word8 -> IO ()) ws.
107 append (writeN a f) (append (writeN b g) ws) =
108 append (writeN (a+b) (\p -> f p >> g (p `plusPtr` a))) ws
109
110 "writeN/writeN" forall a b (f::Ptr Word8 -> IO ())
111 (g::Ptr Word8 -> IO ()).
112 append (writeN a f) (writeN b g) =
113 writeN (a+b) (\p -> f p >> g (p `plusPtr` a))
114
115 "ensureFree/ensureFree" forall a b .
116 append (ensureFree a) (ensureFree b) = ensureFree (max a b)
117 #-}
118
119 -- Test case
120
121 -- Argument must be a multiple of 4.
122 test :: Int -> Builder
123 test 0 = mempty
124 test n = singleton 1 `mappend`
125 (singleton 2 `mappend`
126 (singleton 3 `mappend`
127 (singleton 4 `mappend` test (n-4))))
128
129 main = print $ L.length $ toLazyByteString $ test 10000000