base: Remove `Monad(fail)` method and reexport `MonadFail(fail)` instead
[ghc.git] / testsuite / tests / profiling / should_run / T3001-2.hs
1
2 -- A second test for trac #3001, which segfaults when compiled by
3 -- GHC 6.10.1 and run with +RTS -hb. Most of the code is from the
4 -- binary 0.4.4 package.
5
6 {-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, MagicHash #-}
7
8 module Main (main) where
9
10 import Data.Semigroup
11
12 import Data.ByteString.Internal (inlinePerformIO)
13
14 import qualified Data.ByteString as S
15 import qualified Data.ByteString.Internal as S
16 import qualified Data.ByteString.Lazy as L
17 import qualified Data.ByteString.Lazy.Internal as L
18
19 import GHC.Exts
20 import GHC.Word
21
22 import Control.Monad
23 import Foreign
24 import System.IO.Unsafe
25 import System.IO
26
27 import Data.Char (chr,ord)
28
29 import Control.Applicative
30
31 main :: IO ()
32 main = do
33 encodeFile "test.bin" $ replicate 10000 'x'
34 print =<< (decodeFile "test.bin" :: IO String)
35
36 class Binary t where
37 put :: t -> Put
38 get :: Get t
39
40 encodeFile :: Binary a => FilePath -> a -> IO ()
41 encodeFile f v = L.writeFile f $ runPut $ put v
42
43 decodeFile :: Binary a => FilePath -> IO a
44 decodeFile f = do
45 s <- L.readFile f
46 return $ runGet (do v <- get
47 m <- isEmpty
48 m `seq` return v) s
49
50 instance Binary Word8 where
51 put = putWord8
52 get = getWord8
53
54 instance Binary Word32 where
55 put = putWord32be
56 get = getWord32be
57
58 instance Binary Int32 where
59 put i = put (fromIntegral i :: Word32)
60 get = liftM fromIntegral (get :: Get Word32)
61
62 instance Binary Int where
63 put i = put (fromIntegral i :: Int32)
64 get = liftM fromIntegral (get :: Get Int32)
65
66 instance Binary Char where
67 put a = put (ord a)
68 get = do w <- get
69 return $! chr w
70
71 instance Binary a => Binary [a] where
72 put l = put (length l) >> mapM_ put l
73 get = do n <- get
74 replicateM n get
75
76 data PairS a = PairS a !Builder
77
78 sndS :: PairS a -> Builder
79 sndS (PairS _ b) = b
80
81 newtype PutM a = Put { unPut :: PairS a }
82
83 type Put = PutM ()
84
85 instance Functor PutM where
86 fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
87
88 instance Monad PutM where
89 return a = Put $ PairS a mempty
90
91 m >>= k = Put $
92 let PairS a w = unPut m
93 PairS b w' = unPut (k a)
94 in PairS b (w `mappend` w')
95
96 m >> k = Put $
97 let PairS _ w = unPut m
98 PairS b w' = unPut k
99 in PairS b (w `mappend` w')
100
101 instance Applicative PutM where
102 pure = return
103 (<*>) = ap
104
105 tell :: Builder -> Put
106 tell b = Put $ PairS () b
107
108 runPut :: Put -> L.ByteString
109 runPut = toLazyByteString . sndS . unPut
110
111 putWord8 :: Word8 -> Put
112 putWord8 = tell . singletonB
113
114 putWord32be :: Word32 -> Put
115 putWord32be = tell . putWord32beB
116
117 -----
118
119 newtype Get a = Get { unGet :: S -> (a, S) }
120
121 data S = S {-# UNPACK #-} !S.ByteString -- current chunk
122 L.ByteString -- the rest of the input
123 {-# UNPACK #-} !Int64 -- bytes read
124
125 runGet :: Get a -> L.ByteString -> a
126 runGet m str = case unGet m (initState str) of (a, _) -> a
127
128 isEmpty :: Get Bool
129 isEmpty = do
130 S s ss _ <- getZ
131 return (S.null s && L.null ss)
132
133 initState :: L.ByteString -> S
134 initState xs = mkState xs 0
135
136 getWord32be :: Get Word32
137 getWord32be = do
138 s <- readN 4 id
139 return $! (fromIntegral (s `S.index` 0) `shiftl_w32` 24) .|.
140 (fromIntegral (s `S.index` 1) `shiftl_w32` 16) .|.
141 (fromIntegral (s `S.index` 2) `shiftl_w32` 8) .|.
142 (fromIntegral (s `S.index` 3) )
143
144 getWord8 :: Get Word8
145 getWord8 = getPtr (sizeOf (undefined :: Word8))
146
147 mkState :: L.ByteString -> Int64 -> S
148 mkState l = case l of
149 L.Empty -> S S.empty L.empty
150 L.Chunk x xs -> S x xs
151
152 readN :: Int -> (S.ByteString -> a) -> Get a
153 readN n f = fmap f $ getBytes n
154
155 shiftl_w32 :: Word32 -> Int -> Word32
156 shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
157
158 getPtr :: Storable a => Int -> Get a
159 getPtr n = do
160 (fp,o,_) <- readN n S.toForeignPtr
161 return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
162
163 getBytes :: Int -> Get S.ByteString
164 getBytes n = do
165 S s ss bytes <- getZ
166 if n <= S.length s
167 then do let (consume,rest) = S.splitAt n s
168 putZ $! S rest ss (bytes + fromIntegral n)
169 return $! consume
170 else
171 case L.splitAt (fromIntegral n) (s `joinZ` ss) of
172 (consuming, rest) ->
173 do let now = S.concat . L.toChunks $ consuming
174 putZ $! mkState rest (bytes + fromIntegral n)
175 -- forces the next chunk before this one is returned
176 if (S.length now < n)
177 then
178 fail "too few bytes"
179 else
180 return now
181
182 joinZ :: S.ByteString -> L.ByteString -> L.ByteString
183 joinZ bb lb
184 | S.null bb = lb
185 | otherwise = L.Chunk bb lb
186
187 instance Monad Get where
188 return a = Get (\s -> (a, s))
189 {-# INLINE return #-}
190
191 m >>= k = Get (\s -> let (a, s') = unGet m s
192 in unGet (k a) s')
193 {-# INLINE (>>=) #-}
194
195 instance MonadFail Get where
196 fail = error "failDesc"
197
198 instance Applicative Get where
199 pure = return
200 (<*>) = ap
201
202 getZ :: Get S
203 getZ = Get (\s -> (s, s))
204
205 putZ :: S -> Get ()
206 putZ s = Get (\_ -> ((), s))
207
208
209 instance Functor Get where
210 fmap f m = Get (\s -> case unGet m s of
211 (a, s') -> (f a, s'))
212
213 -----
214
215 singletonB :: Word8 -> Builder
216 singletonB = writeN 1 . flip poke
217
218 writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
219 writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
220
221 unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
222 unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do
223 buf' <- f buf
224 return (k buf')
225
226 append :: Builder -> Builder -> Builder
227 append (Builder f) (Builder g) = Builder (f . g)
228
229 writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
230 writeNBuffer n f (Buffer fp o u l) = do
231 withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
232 return (Buffer fp o (u+n) (l-n))
233
234 newtype Builder = Builder {
235 -- Invariant (from Data.ByteString.Lazy):
236 -- The lists include no null ByteStrings.
237 runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
238 }
239
240 data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
241 {-# UNPACK #-} !Int -- offset
242 {-# UNPACK #-} !Int -- used bytes
243 {-# UNPACK #-} !Int -- length left
244
245 toLazyByteString :: Builder -> L.ByteString
246 toLazyByteString m = L.fromChunks $ unsafePerformIO $ do
247 buf <- newBuffer defaultSize
248 return (runBuilder (m `append` flush) (const []) buf)
249
250 ensureFree :: Int -> Builder
251 ensureFree n = n `seq` withSize $ \ l ->
252 if n <= l then emptyBuilder else
253 flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
254
255 withSize :: (Int -> Builder) -> Builder
256 withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
257 runBuilder (f l) k buf
258
259 defaultSize :: Int
260 defaultSize = 32 * k - overhead
261 where k = 1024
262 overhead = 2 * sizeOf (undefined :: Int)
263
264 newBuffer :: Int -> IO Buffer
265 newBuffer size = do
266 fp <- S.mallocByteString size
267 return $! Buffer fp 0 0 size
268
269 putWord32beB :: Word32 -> Builder
270 putWord32beB w = writeN 4 $ \p -> do
271 poke p (fromIntegral (shiftr_w32 w 24) :: Word8)
272 poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)
273 poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8)
274 poke (p `plusPtr` 3) (fromIntegral (w) :: Word8)
275
276 shiftr_w32 :: Word32 -> Int -> Word32
277 shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
278
279 flush :: Builder
280 flush = Builder $ \ k buf@(Buffer p o u l) ->
281 if u == 0
282 then k buf
283 else S.PS p o u : k (Buffer p (o+u) 0 l)
284
285 emptyBuilder :: Builder
286 emptyBuilder = Builder id
287
288 instance Semigroup Builder where
289 (<>) = append
290
291 instance Monoid Builder where
292 mempty = emptyBuilder
293 mappend = (<>)
294