gitlab-ci: Disable submodule linter for now
[ghc.git] / compiler / utils / Binary.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE PolyKinds #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE GADTs #-}
6 {-# LANGUAGE MultiWayIf #-}
7
8 {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
9 -- We always optimise this, otherwise performance of a non-optimised
10 -- compiler is severely affected
11
12 --
13 -- (c) The University of Glasgow 2002-2006
14 --
15 -- Binary I/O library, with special tweaks for GHC
16 --
17 -- Based on the nhc98 Binary library, which is copyright
18 -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
19 -- Under the terms of the license for that software, we must tell you
20 -- where you can obtain the original version of the Binary library, namely
21 -- http://www.cs.york.ac.uk/fp/nhc98/
22
23 module Binary
24 ( {-type-} Bin,
25 {-class-} Binary(..),
26 {-type-} BinHandle,
27 SymbolTable, Dictionary,
28
29 openBinMem,
30 -- closeBin,
31
32 seekBin,
33 seekBy,
34 tellBin,
35 castBin,
36 isEOFBin,
37 withBinBuffer,
38
39 writeBinMem,
40 readBinMem,
41
42 putAt, getAt,
43
44 -- * For writing instances
45 putByte,
46 getByte,
47
48 -- * Lazy Binary I/O
49 lazyGet,
50 lazyPut,
51
52 -- * User data
53 UserData(..), getUserData, setUserData,
54 newReadState, newWriteState,
55 putDictionary, getDictionary, putFS,
56 ) where
57
58 #include "HsVersions.h"
59
60 -- The *host* architecture version:
61 #include "../includes/MachDeps.h"
62
63 import GhcPrelude
64
65 import {-# SOURCE #-} Name (Name)
66 import FastString
67 import PlainPanic
68 import UniqFM
69 import FastMutInt
70 import Fingerprint
71 import BasicTypes
72 import SrcLoc
73
74 import Foreign
75 import Data.Array
76 import Data.ByteString (ByteString)
77 import qualified Data.ByteString.Internal as BS
78 import qualified Data.ByteString.Unsafe as BS
79 import Data.IORef
80 import Data.Char ( ord, chr )
81 import Data.Time
82 import Type.Reflection
83 import Type.Reflection.Unsafe
84 import Data.Kind (Type)
85 import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
86 import Control.Monad ( when )
87 import System.IO as IO
88 import System.IO.Unsafe ( unsafeInterleaveIO )
89 import System.IO.Error ( mkIOError, eofErrorType )
90 import GHC.Real ( Ratio(..) )
91 import GHC.Serialized
92
93 type BinArray = ForeignPtr Word8
94
95 ---------------------------------------------------------------
96 -- BinHandle
97 ---------------------------------------------------------------
98
99 data BinHandle
100 = BinMem { -- binary data stored in an unboxed array
101 bh_usr :: UserData, -- sigh, need parameterized modules :-)
102 _off_r :: !FastMutInt, -- the current offset
103 _sz_r :: !FastMutInt, -- size of the array (cached)
104 _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
105 }
106 -- XXX: should really store a "high water mark" for dumping out
107 -- the binary data to a file.
108
109 getUserData :: BinHandle -> UserData
110 getUserData bh = bh_usr bh
111
112 setUserData :: BinHandle -> UserData -> BinHandle
113 setUserData bh us = bh { bh_usr = us }
114
115 -- | Get access to the underlying buffer.
116 --
117 -- It is quite important that no references to the 'ByteString' leak out of the
118 -- continuation lest terrible things happen.
119 withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
120 withBinBuffer (BinMem _ ix_r _ arr_r) action = do
121 arr <- readIORef arr_r
122 ix <- readFastMutInt ix_r
123 withForeignPtr arr $ \ptr ->
124 BS.unsafePackCStringLen (castPtr ptr, ix) >>= action
125
126
127 ---------------------------------------------------------------
128 -- Bin
129 ---------------------------------------------------------------
130
131 newtype Bin a = BinPtr Int
132 deriving (Eq, Ord, Show, Bounded)
133
134 castBin :: Bin a -> Bin b
135 castBin (BinPtr i) = BinPtr i
136
137 ---------------------------------------------------------------
138 -- class Binary
139 ---------------------------------------------------------------
140
141 class Binary a where
142 put_ :: BinHandle -> a -> IO ()
143 put :: BinHandle -> a -> IO (Bin a)
144 get :: BinHandle -> IO a
145
146 -- define one of put_, put. Use of put_ is recommended because it
147 -- is more likely that tail-calls can kick in, and we rarely need the
148 -- position return value.
149 put_ bh a = do _ <- put bh a; return ()
150 put bh a = do p <- tellBin bh; put_ bh a; return p
151
152 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
153 putAt bh p x = do seekBin bh p; put_ bh x; return ()
154
155 getAt :: Binary a => BinHandle -> Bin a -> IO a
156 getAt bh p = do seekBin bh p; get bh
157
158 openBinMem :: Int -> IO BinHandle
159 openBinMem size
160 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
161 | otherwise = do
162 arr <- mallocForeignPtrBytes size
163 arr_r <- newIORef arr
164 ix_r <- newFastMutInt
165 writeFastMutInt ix_r 0
166 sz_r <- newFastMutInt
167 writeFastMutInt sz_r size
168 return (BinMem noUserData ix_r sz_r arr_r)
169
170 tellBin :: BinHandle -> IO (Bin a)
171 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
172
173 seekBin :: BinHandle -> Bin a -> IO ()
174 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
175 sz <- readFastMutInt sz_r
176 if (p >= sz)
177 then do expandBin h p; writeFastMutInt ix_r p
178 else writeFastMutInt ix_r p
179
180 seekBy :: BinHandle -> Int -> IO ()
181 seekBy h@(BinMem _ ix_r sz_r _) off = do
182 sz <- readFastMutInt sz_r
183 ix <- readFastMutInt ix_r
184 let ix' = ix + off
185 if (ix' >= sz)
186 then do expandBin h ix'; writeFastMutInt ix_r ix'
187 else writeFastMutInt ix_r ix'
188
189 isEOFBin :: BinHandle -> IO Bool
190 isEOFBin (BinMem _ ix_r sz_r _) = do
191 ix <- readFastMutInt ix_r
192 sz <- readFastMutInt sz_r
193 return (ix >= sz)
194
195 writeBinMem :: BinHandle -> FilePath -> IO ()
196 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
197 h <- openBinaryFile fn WriteMode
198 arr <- readIORef arr_r
199 ix <- readFastMutInt ix_r
200 withForeignPtr arr $ \p -> hPutBuf h p ix
201 hClose h
202
203 readBinMem :: FilePath -> IO BinHandle
204 -- Return a BinHandle with a totally undefined State
205 readBinMem filename = do
206 h <- openBinaryFile filename ReadMode
207 filesize' <- hFileSize h
208 let filesize = fromIntegral filesize'
209 arr <- mallocForeignPtrBytes filesize
210 count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
211 when (count /= filesize) $
212 error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
213 hClose h
214 arr_r <- newIORef arr
215 ix_r <- newFastMutInt
216 writeFastMutInt ix_r 0
217 sz_r <- newFastMutInt
218 writeFastMutInt sz_r filesize
219 return (BinMem noUserData ix_r sz_r arr_r)
220
221 -- expand the size of the array to include a specified offset
222 expandBin :: BinHandle -> Int -> IO ()
223 expandBin (BinMem _ _ sz_r arr_r) off = do
224 sz <- readFastMutInt sz_r
225 let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
226 arr <- readIORef arr_r
227 arr' <- mallocForeignPtrBytes sz'
228 withForeignPtr arr $ \old ->
229 withForeignPtr arr' $ \new ->
230 copyBytes new old sz
231 writeFastMutInt sz_r sz'
232 writeIORef arr_r arr'
233
234 -- -----------------------------------------------------------------------------
235 -- Low-level reading/writing of bytes
236
237 putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
238 putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
239 ix <- readFastMutInt ix_r
240 sz <- readFastMutInt sz_r
241 when (ix + size > sz) $
242 expandBin h (ix + size)
243 arr <- readIORef arr_r
244 withForeignPtr arr $ \op -> f (op `plusPtr` ix)
245 writeFastMutInt ix_r (ix + size)
246
247 getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
248 getPrim (BinMem _ ix_r sz_r arr_r) size f = do
249 ix <- readFastMutInt ix_r
250 sz <- readFastMutInt sz_r
251 when (ix + size > sz) $
252 ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
253 arr <- readIORef arr_r
254 w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
255 writeFastMutInt ix_r (ix + size)
256 return w
257
258 putWord8 :: BinHandle -> Word8 -> IO ()
259 putWord8 h w = putPrim h 1 (\op -> poke op w)
260
261 getWord8 :: BinHandle -> IO Word8
262 getWord8 h = getPrim h 1 peek
263
264 putWord16 :: BinHandle -> Word16 -> IO ()
265 putWord16 h w = putPrim h 2 (\op -> do
266 pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
267 pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
268 )
269
270 getWord16 :: BinHandle -> IO Word16
271 getWord16 h = getPrim h 2 (\op -> do
272 w0 <- fromIntegral <$> peekElemOff op 0
273 w1 <- fromIntegral <$> peekElemOff op 1
274 return $! w0 `shiftL` 8 .|. w1
275 )
276
277 putWord32 :: BinHandle -> Word32 -> IO ()
278 putWord32 h w = putPrim h 4 (\op -> do
279 pokeElemOff op 0 (fromIntegral (w `shiftR` 24))
280 pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
281 pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
282 pokeElemOff op 3 (fromIntegral (w .&. 0xFF))
283 )
284
285 getWord32 :: BinHandle -> IO Word32
286 getWord32 h = getPrim h 4 (\op -> do
287 w0 <- fromIntegral <$> peekElemOff op 0
288 w1 <- fromIntegral <$> peekElemOff op 1
289 w2 <- fromIntegral <$> peekElemOff op 2
290 w3 <- fromIntegral <$> peekElemOff op 3
291
292 return $! (w0 `shiftL` 24) .|.
293 (w1 `shiftL` 16) .|.
294 (w2 `shiftL` 8) .|.
295 w3
296 )
297
298 putWord64 :: BinHandle -> Word64 -> IO ()
299 putWord64 h w = putPrim h 8 (\op -> do
300 pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
301 pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
302 pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))
303 pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))
304 pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))
305 pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
306 pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
307 pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
308 )
309
310 getWord64 :: BinHandle -> IO Word64
311 getWord64 h = getPrim h 8 (\op -> do
312 w0 <- fromIntegral <$> peekElemOff op 0
313 w1 <- fromIntegral <$> peekElemOff op 1
314 w2 <- fromIntegral <$> peekElemOff op 2
315 w3 <- fromIntegral <$> peekElemOff op 3
316 w4 <- fromIntegral <$> peekElemOff op 4
317 w5 <- fromIntegral <$> peekElemOff op 5
318 w6 <- fromIntegral <$> peekElemOff op 6
319 w7 <- fromIntegral <$> peekElemOff op 7
320
321 return $! (w0 `shiftL` 56) .|.
322 (w1 `shiftL` 48) .|.
323 (w2 `shiftL` 40) .|.
324 (w3 `shiftL` 32) .|.
325 (w4 `shiftL` 24) .|.
326 (w5 `shiftL` 16) .|.
327 (w6 `shiftL` 8) .|.
328 w7
329 )
330
331 putByte :: BinHandle -> Word8 -> IO ()
332 putByte bh w = putWord8 bh w
333
334 getByte :: BinHandle -> IO Word8
335 getByte h = getWord8 h
336
337 -- -----------------------------------------------------------------------------
338 -- Primitive Word writes
339
340 instance Binary Word8 where
341 put_ = putWord8
342 get = getWord8
343
344 instance Binary Word16 where
345 put_ h w = putWord16 h w
346 get h = getWord16 h
347
348 instance Binary Word32 where
349 put_ h w = putWord32 h w
350 get h = getWord32 h
351
352 instance Binary Word64 where
353 put_ h w = putWord64 h w
354 get h = getWord64 h
355
356 -- -----------------------------------------------------------------------------
357 -- Primitive Int writes
358
359 instance Binary Int8 where
360 put_ h w = put_ h (fromIntegral w :: Word8)
361 get h = do w <- get h; return $! (fromIntegral (w::Word8))
362
363 instance Binary Int16 where
364 put_ h w = put_ h (fromIntegral w :: Word16)
365 get h = do w <- get h; return $! (fromIntegral (w::Word16))
366
367 instance Binary Int32 where
368 put_ h w = put_ h (fromIntegral w :: Word32)
369 get h = do w <- get h; return $! (fromIntegral (w::Word32))
370
371 instance Binary Int64 where
372 put_ h w = put_ h (fromIntegral w :: Word64)
373 get h = do w <- get h; return $! (fromIntegral (w::Word64))
374
375 -- -----------------------------------------------------------------------------
376 -- Instances for standard types
377
378 instance Binary () where
379 put_ _ () = return ()
380 get _ = return ()
381
382 instance Binary Bool where
383 put_ bh b = putByte bh (fromIntegral (fromEnum b))
384 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
385
386 instance Binary Char where
387 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
388 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
389
390 instance Binary Int where
391 put_ bh i = put_ bh (fromIntegral i :: Int64)
392 get bh = do
393 x <- get bh
394 return $! (fromIntegral (x :: Int64))
395
396 instance Binary a => Binary [a] where
397 put_ bh l = do
398 let len = length l
399 if (len < 0xff)
400 then putByte bh (fromIntegral len :: Word8)
401 else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32)
402 mapM_ (put_ bh) l
403 get bh = do
404 b <- getByte bh
405 len <- if b == 0xff
406 then get bh
407 else return (fromIntegral b :: Word32)
408 let loop 0 = return []
409 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
410 loop len
411
412 instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
413 put_ bh arr = do
414 put_ bh $ bounds arr
415 put_ bh $ elems arr
416 get bh = do
417 bounds <- get bh
418 xs <- get bh
419 return $ listArray bounds xs
420
421 instance (Binary a, Binary b) => Binary (a,b) where
422 put_ bh (a,b) = do put_ bh a; put_ bh b
423 get bh = do a <- get bh
424 b <- get bh
425 return (a,b)
426
427 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
428 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
429 get bh = do a <- get bh
430 b <- get bh
431 c <- get bh
432 return (a,b,c)
433
434 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
435 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
436 get bh = do a <- get bh
437 b <- get bh
438 c <- get bh
439 d <- get bh
440 return (a,b,c,d)
441
442 instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
443 put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;
444 get bh = do a <- get bh
445 b <- get bh
446 c <- get bh
447 d <- get bh
448 e <- get bh
449 return (a,b,c,d,e)
450
451 instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
452 put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;
453 get bh = do a <- get bh
454 b <- get bh
455 c <- get bh
456 d <- get bh
457 e <- get bh
458 f <- get bh
459 return (a,b,c,d,e,f)
460
461 instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where
462 put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g
463 get bh = do a <- get bh
464 b <- get bh
465 c <- get bh
466 d <- get bh
467 e <- get bh
468 f <- get bh
469 g <- get bh
470 return (a,b,c,d,e,f,g)
471
472 instance Binary a => Binary (Maybe a) where
473 put_ bh Nothing = putByte bh 0
474 put_ bh (Just a) = do putByte bh 1; put_ bh a
475 get bh = do h <- getWord8 bh
476 case h of
477 0 -> return Nothing
478 _ -> do x <- get bh; return (Just x)
479
480 instance (Binary a, Binary b) => Binary (Either a b) where
481 put_ bh (Left a) = do putByte bh 0; put_ bh a
482 put_ bh (Right b) = do putByte bh 1; put_ bh b
483 get bh = do h <- getWord8 bh
484 case h of
485 0 -> do a <- get bh ; return (Left a)
486 _ -> do b <- get bh ; return (Right b)
487
488 instance Binary UTCTime where
489 put_ bh u = do put_ bh (utctDay u)
490 put_ bh (utctDayTime u)
491 get bh = do day <- get bh
492 dayTime <- get bh
493 return $ UTCTime { utctDay = day, utctDayTime = dayTime }
494
495 instance Binary Day where
496 put_ bh d = put_ bh (toModifiedJulianDay d)
497 get bh = do i <- get bh
498 return $ ModifiedJulianDay { toModifiedJulianDay = i }
499
500 instance Binary DiffTime where
501 put_ bh dt = put_ bh (toRational dt)
502 get bh = do r <- get bh
503 return $ fromRational r
504
505 --to quote binary-0.3 on this code idea,
506 --
507 -- TODO This instance is not architecture portable. GMP stores numbers as
508 -- arrays of machine sized words, so the byte format is not portable across
509 -- architectures with different endianness and word size.
510 --
511 -- This makes it hard (impossible) to make an equivalent instance
512 -- with code that is compilable with non-GHC. Do we need any instance
513 -- Binary Integer, and if so, does it have to be blazing fast? Or can
514 -- we just change this instance to be portable like the rest of the
515 -- instances? (binary package has code to steal for that)
516 --
517 -- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs
518
519 instance Binary Integer where
520 put_ bh i
521 | i >= lo32 && i <= hi32 = do
522 putWord8 bh 0
523 put_ bh (fromIntegral i :: Int32)
524 | otherwise = do
525 putWord8 bh 1
526 put_ bh (show i)
527 where
528 lo32 = fromIntegral (minBound :: Int32)
529 hi32 = fromIntegral (maxBound :: Int32)
530
531 get bh = do
532 int_kind <- getWord8 bh
533 case int_kind of
534 0 -> fromIntegral <$> (get bh :: IO Int32)
535 _ -> do str <- get bh
536 case reads str of
537 [(i, "")] -> return i
538 _ -> fail ("Binary integer: got " ++ show str)
539
540 {-
541 -- This code is currently commented out.
542 -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for
543 -- discussion.
544
545 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
546 put_ bh (J# s# a#) = do
547 putByte bh 1
548 put_ bh (I# s#)
549 let sz# = sizeofByteArray# a# -- in *bytes*
550 put_ bh (I# sz#) -- in *bytes*
551 putByteArray bh a# sz#
552
553 get bh = do
554 b <- getByte bh
555 case b of
556 0 -> do (I# i#) <- get bh
557 return (S# i#)
558 _ -> do (I# s#) <- get bh
559 sz <- get bh
560 (BA a#) <- getByteArray bh sz
561 return (J# s# a#)
562
563 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
564 putByteArray bh a s# = loop 0#
565 where loop n#
566 | n# ==# s# = return ()
567 | otherwise = do
568 putByte bh (indexByteArray a n#)
569 loop (n# +# 1#)
570
571 getByteArray :: BinHandle -> Int -> IO ByteArray
572 getByteArray bh (I# sz) = do
573 (MBA arr) <- newByteArray sz
574 let loop n
575 | n ==# sz = return ()
576 | otherwise = do
577 w <- getByte bh
578 writeByteArray arr n w
579 loop (n +# 1#)
580 loop 0#
581 freezeByteArray arr
582 -}
583
584 {-
585 data ByteArray = BA ByteArray#
586 data MBA = MBA (MutableByteArray# RealWorld)
587
588 newByteArray :: Int# -> IO MBA
589 newByteArray sz = IO $ \s ->
590 case newByteArray# sz s of { (# s, arr #) ->
591 (# s, MBA arr #) }
592
593 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
594 freezeByteArray arr = IO $ \s ->
595 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
596 (# s, BA arr #) }
597
598 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
599 writeByteArray arr i (W8# w) = IO $ \s ->
600 case writeWord8Array# arr i w s of { s ->
601 (# s, () #) }
602
603 indexByteArray :: ByteArray# -> Int# -> Word8
604 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
605
606 -}
607 instance (Binary a) => Binary (Ratio a) where
608 put_ bh (a :% b) = do put_ bh a; put_ bh b
609 get bh = do a <- get bh; b <- get bh; return (a :% b)
610
611 instance Binary (Bin a) where
612 put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32)
613 get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32)))
614
615 -- -----------------------------------------------------------------------------
616 -- Instances for Data.Typeable stuff
617
618 instance Binary TyCon where
619 put_ bh tc = do
620 put_ bh (tyConPackage tc)
621 put_ bh (tyConModule tc)
622 put_ bh (tyConName tc)
623 put_ bh (tyConKindArgs tc)
624 put_ bh (tyConKindRep tc)
625 get bh =
626 mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
627
628 instance Binary VecCount where
629 put_ bh = putByte bh . fromIntegral . fromEnum
630 get bh = toEnum . fromIntegral <$> getByte bh
631
632 instance Binary VecElem where
633 put_ bh = putByte bh . fromIntegral . fromEnum
634 get bh = toEnum . fromIntegral <$> getByte bh
635
636 instance Binary RuntimeRep where
637 put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b
638 put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
639 put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps
640 put_ bh LiftedRep = putByte bh 3
641 put_ bh UnliftedRep = putByte bh 4
642 put_ bh IntRep = putByte bh 5
643 put_ bh WordRep = putByte bh 6
644 put_ bh Int64Rep = putByte bh 7
645 put_ bh Word64Rep = putByte bh 8
646 put_ bh AddrRep = putByte bh 9
647 put_ bh FloatRep = putByte bh 10
648 put_ bh DoubleRep = putByte bh 11
649 #if __GLASGOW_HASKELL__ >= 807
650 put_ bh Int8Rep = putByte bh 12
651 put_ bh Word8Rep = putByte bh 13
652 put_ bh Int16Rep = putByte bh 14
653 put_ bh Word16Rep = putByte bh 15
654 #endif
655
656 get bh = do
657 tag <- getByte bh
658 case tag of
659 0 -> VecRep <$> get bh <*> get bh
660 1 -> TupleRep <$> get bh
661 2 -> SumRep <$> get bh
662 3 -> pure LiftedRep
663 4 -> pure UnliftedRep
664 5 -> pure IntRep
665 6 -> pure WordRep
666 7 -> pure Int64Rep
667 8 -> pure Word64Rep
668 9 -> pure AddrRep
669 10 -> pure FloatRep
670 11 -> pure DoubleRep
671 #if __GLASGOW_HASKELL__ >= 807
672 12 -> pure Int8Rep
673 13 -> pure Word8Rep
674 14 -> pure Int16Rep
675 15 -> pure Word16Rep
676 #endif
677 _ -> fail "Binary.putRuntimeRep: invalid tag"
678
679 instance Binary KindRep where
680 put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k
681 put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr
682 put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b
683 put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b
684 put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r
685 put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r
686
687 get bh = do
688 tag <- getByte bh
689 case tag of
690 0 -> KindRepTyConApp <$> get bh <*> get bh
691 1 -> KindRepVar <$> get bh
692 2 -> KindRepApp <$> get bh <*> get bh
693 3 -> KindRepFun <$> get bh <*> get bh
694 4 -> KindRepTYPE <$> get bh
695 5 -> KindRepTypeLit <$> get bh <*> get bh
696 _ -> fail "Binary.putKindRep: invalid tag"
697
698 instance Binary TypeLitSort where
699 put_ bh TypeLitSymbol = putByte bh 0
700 put_ bh TypeLitNat = putByte bh 1
701 get bh = do
702 tag <- getByte bh
703 case tag of
704 0 -> pure TypeLitSymbol
705 1 -> pure TypeLitNat
706 _ -> fail "Binary.putTypeLitSort: invalid tag"
707
708 putTypeRep :: BinHandle -> TypeRep a -> IO ()
709 -- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
710 -- relations.
711 -- See Note [Mutually recursive representations of primitive types]
712 putTypeRep bh rep
713 | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
714 = put_ bh (0 :: Word8)
715 putTypeRep bh (Con' con ks) = do
716 put_ bh (1 :: Word8)
717 put_ bh con
718 put_ bh ks
719 putTypeRep bh (App f x) = do
720 put_ bh (2 :: Word8)
721 putTypeRep bh f
722 putTypeRep bh x
723 putTypeRep bh (Fun arg res) = do
724 put_ bh (3 :: Word8)
725 putTypeRep bh arg
726 putTypeRep bh res
727 putTypeRep _ _ = fail "Binary.putTypeRep: Impossible"
728
729 getSomeTypeRep :: BinHandle -> IO SomeTypeRep
730 getSomeTypeRep bh = do
731 tag <- get bh :: IO Word8
732 case tag of
733 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
734 1 -> do con <- get bh :: IO TyCon
735 ks <- get bh :: IO [SomeTypeRep]
736 return $ SomeTypeRep $ mkTrCon con ks
737
738 2 -> do SomeTypeRep f <- getSomeTypeRep bh
739 SomeTypeRep x <- getSomeTypeRep bh
740 case typeRepKind f of
741 Fun arg res ->
742 case arg `eqTypeRep` typeRepKind x of
743 Just HRefl ->
744 case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
745 Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
746 _ -> failure "Kind mismatch in type application" []
747 _ -> failure "Kind mismatch in type application"
748 [ " Found argument of kind: " ++ show (typeRepKind x)
749 , " Where the constructor: " ++ show f
750 , " Expects kind: " ++ show arg
751 ]
752 _ -> failure "Applied non-arrow"
753 [ " Applied type: " ++ show f
754 , " To argument: " ++ show x
755 ]
756 3 -> do SomeTypeRep arg <- getSomeTypeRep bh
757 SomeTypeRep res <- getSomeTypeRep bh
758 if
759 | App argkcon _ <- typeRepKind arg
760 , App reskcon _ <- typeRepKind res
761 , Just HRefl <- argkcon `eqTypeRep` tYPErep
762 , Just HRefl <- reskcon `eqTypeRep` tYPErep
763 -> return $ SomeTypeRep $ Fun arg res
764 | otherwise -> failure "Kind mismatch" []
765 _ -> failure "Invalid SomeTypeRep" []
766 where
767 tYPErep :: TypeRep TYPE
768 tYPErep = typeRep
769
770 failure description info =
771 fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
772 ++ map (" "++) info
773
774 instance Typeable a => Binary (TypeRep (a :: k)) where
775 put_ = putTypeRep
776 get bh = do
777 SomeTypeRep rep <- getSomeTypeRep bh
778 case rep `eqTypeRep` expected of
779 Just HRefl -> pure rep
780 Nothing -> fail $ unlines
781 [ "Binary: Type mismatch"
782 , " Deserialized type: " ++ show rep
783 , " Expected type: " ++ show expected
784 ]
785 where expected = typeRep :: TypeRep a
786
787 instance Binary SomeTypeRep where
788 put_ bh (SomeTypeRep rep) = putTypeRep bh rep
789 get = getSomeTypeRep
790
791 -- -----------------------------------------------------------------------------
792 -- Lazy reading/writing
793
794 lazyPut :: Binary a => BinHandle -> a -> IO ()
795 lazyPut bh a = do
796 -- output the obj with a ptr to skip over it:
797 pre_a <- tellBin bh
798 put_ bh pre_a -- save a slot for the ptr
799 put_ bh a -- dump the object
800 q <- tellBin bh -- q = ptr to after object
801 putAt bh pre_a q -- fill in slot before a with ptr to q
802 seekBin bh q -- finally carry on writing at q
803
804 lazyGet :: Binary a => BinHandle -> IO a
805 lazyGet bh = do
806 p <- get bh -- a BinPtr
807 p_a <- tellBin bh
808 a <- unsafeInterleaveIO $ do
809 -- NB: Use a fresh off_r variable in the child thread, for thread
810 -- safety.
811 off_r <- newFastMutInt
812 getAt bh { _off_r = off_r } p_a
813 seekBin bh p -- skip over the object for now
814 return a
815
816 -- -----------------------------------------------------------------------------
817 -- UserData
818 -- -----------------------------------------------------------------------------
819
820 -- | Information we keep around during interface file
821 -- serialization/deserialization. Namely we keep the functions for serializing
822 -- and deserializing 'Name's and 'FastString's. We do this because we actually
823 -- use serialization in two distinct settings,
824 --
825 -- * When serializing interface files themselves
826 --
827 -- * When computing the fingerprint of an IfaceDecl (which we computing by
828 -- hashing its Binary serialization)
829 --
830 -- These two settings have different needs while serializing Names:
831 --
832 -- * Names in interface files are serialized via a symbol table (see Note
833 -- [Symbol table representation of names] in BinIface).
834 --
835 -- * During fingerprinting a binding Name is serialized as the OccName and a
836 -- non-binding Name is serialized as the fingerprint of the thing they
837 -- represent. See Note [Fingerprinting IfaceDecls] for further discussion.
838 --
839 data UserData =
840 UserData {
841 -- for *deserialising* only:
842 ud_get_name :: BinHandle -> IO Name,
843 ud_get_fs :: BinHandle -> IO FastString,
844
845 -- for *serialising* only:
846 ud_put_nonbinding_name :: BinHandle -> Name -> IO (),
847 -- ^ serialize a non-binding 'Name' (e.g. a reference to another
848 -- binding).
849 ud_put_binding_name :: BinHandle -> Name -> IO (),
850 -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)
851 ud_put_fs :: BinHandle -> FastString -> IO ()
852 }
853
854 newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's
855 -> (BinHandle -> IO FastString)
856 -> UserData
857 newReadState get_name get_fs
858 = UserData { ud_get_name = get_name,
859 ud_get_fs = get_fs,
860 ud_put_nonbinding_name = undef "put_nonbinding_name",
861 ud_put_binding_name = undef "put_binding_name",
862 ud_put_fs = undef "put_fs"
863 }
864
865 newWriteState :: (BinHandle -> Name -> IO ())
866 -- ^ how to serialize non-binding 'Name's
867 -> (BinHandle -> Name -> IO ())
868 -- ^ how to serialize binding 'Name's
869 -> (BinHandle -> FastString -> IO ())
870 -> UserData
871 newWriteState put_nonbinding_name put_binding_name put_fs
872 = UserData { ud_get_name = undef "get_name",
873 ud_get_fs = undef "get_fs",
874 ud_put_nonbinding_name = put_nonbinding_name,
875 ud_put_binding_name = put_binding_name,
876 ud_put_fs = put_fs
877 }
878
879 noUserData :: a
880 noUserData = undef "UserData"
881
882 undef :: String -> a
883 undef s = panic ("Binary.UserData: no " ++ s)
884
885 ---------------------------------------------------------
886 -- The Dictionary
887 ---------------------------------------------------------
888
889 type Dictionary = Array Int FastString -- The dictionary
890 -- Should be 0-indexed
891
892 putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO ()
893 putDictionary bh sz dict = do
894 put_ bh sz
895 mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))
896 -- It's OK to use nonDetEltsUFM here because the elements have indices
897 -- that array uses to create order
898
899 getDictionary :: BinHandle -> IO Dictionary
900 getDictionary bh = do
901 sz <- get bh
902 elems <- sequence (take sz (repeat (getFS bh)))
903 return (listArray (0,sz-1) elems)
904
905 ---------------------------------------------------------
906 -- The Symbol Table
907 ---------------------------------------------------------
908
909 -- On disk, the symbol table is an array of IfExtName, when
910 -- reading it in we turn it into a SymbolTable.
911
912 type SymbolTable = Array Int Name
913
914 ---------------------------------------------------------
915 -- Reading and writing FastStrings
916 ---------------------------------------------------------
917
918 putFS :: BinHandle -> FastString -> IO ()
919 putFS bh fs = putBS bh $ bytesFS fs
920
921 getFS :: BinHandle -> IO FastString
922 getFS bh = do
923 l <- get bh :: IO Int
924 getPrim bh l (\src -> pure $! mkFastStringBytes src l )
925
926 putBS :: BinHandle -> ByteString -> IO ()
927 putBS bh bs =
928 BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
929 put_ bh l
930 putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l)
931
932 getBS :: BinHandle -> IO ByteString
933 getBS bh = do
934 l <- get bh :: IO Int
935 BS.create l $ \dest -> do
936 getPrim bh l (\src -> BS.memcpy dest src l)
937
938 instance Binary ByteString where
939 put_ bh f = putBS bh f
940 get bh = getBS bh
941
942 instance Binary FastString where
943 put_ bh f =
944 case getUserData bh of
945 UserData { ud_put_fs = put_fs } -> put_fs bh f
946
947 get bh =
948 case getUserData bh of
949 UserData { ud_get_fs = get_fs } -> get_fs bh
950
951 -- Here to avoid loop
952 instance Binary LeftOrRight where
953 put_ bh CLeft = putByte bh 0
954 put_ bh CRight = putByte bh 1
955
956 get bh = do { h <- getByte bh
957 ; case h of
958 0 -> return CLeft
959 _ -> return CRight }
960
961 instance Binary PromotionFlag where
962 put_ bh NotPromoted = putByte bh 0
963 put_ bh IsPromoted = putByte bh 1
964
965 get bh = do
966 n <- getByte bh
967 case n of
968 0 -> return NotPromoted
969 1 -> return IsPromoted
970 _ -> fail "Binary(IsPromoted): fail)"
971
972 instance Binary Fingerprint where
973 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
974 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
975
976 instance Binary FunctionOrData where
977 put_ bh IsFunction = putByte bh 0
978 put_ bh IsData = putByte bh 1
979 get bh = do
980 h <- getByte bh
981 case h of
982 0 -> return IsFunction
983 1 -> return IsData
984 _ -> panic "Binary FunctionOrData"
985
986 instance Binary TupleSort where
987 put_ bh BoxedTuple = putByte bh 0
988 put_ bh UnboxedTuple = putByte bh 1
989 put_ bh ConstraintTuple = putByte bh 2
990 get bh = do
991 h <- getByte bh
992 case h of
993 0 -> do return BoxedTuple
994 1 -> do return UnboxedTuple
995 _ -> do return ConstraintTuple
996
997 instance Binary Activation where
998 put_ bh NeverActive = do
999 putByte bh 0
1000 put_ bh AlwaysActive = do
1001 putByte bh 1
1002 put_ bh (ActiveBefore src aa) = do
1003 putByte bh 2
1004 put_ bh src
1005 put_ bh aa
1006 put_ bh (ActiveAfter src ab) = do
1007 putByte bh 3
1008 put_ bh src
1009 put_ bh ab
1010 get bh = do
1011 h <- getByte bh
1012 case h of
1013 0 -> do return NeverActive
1014 1 -> do return AlwaysActive
1015 2 -> do src <- get bh
1016 aa <- get bh
1017 return (ActiveBefore src aa)
1018 _ -> do src <- get bh
1019 ab <- get bh
1020 return (ActiveAfter src ab)
1021
1022 instance Binary InlinePragma where
1023 put_ bh (InlinePragma s a b c d) = do
1024 put_ bh s
1025 put_ bh a
1026 put_ bh b
1027 put_ bh c
1028 put_ bh d
1029
1030 get bh = do
1031 s <- get bh
1032 a <- get bh
1033 b <- get bh
1034 c <- get bh
1035 d <- get bh
1036 return (InlinePragma s a b c d)
1037
1038 instance Binary RuleMatchInfo where
1039 put_ bh FunLike = putByte bh 0
1040 put_ bh ConLike = putByte bh 1
1041 get bh = do
1042 h <- getByte bh
1043 if h == 1 then return ConLike
1044 else return FunLike
1045
1046 instance Binary InlineSpec where
1047 put_ bh NoUserInline = putByte bh 0
1048 put_ bh Inline = putByte bh 1
1049 put_ bh Inlinable = putByte bh 2
1050 put_ bh NoInline = putByte bh 3
1051
1052 get bh = do h <- getByte bh
1053 case h of
1054 0 -> return NoUserInline
1055 1 -> return Inline
1056 2 -> return Inlinable
1057 _ -> return NoInline
1058
1059 instance Binary RecFlag where
1060 put_ bh Recursive = do
1061 putByte bh 0
1062 put_ bh NonRecursive = do
1063 putByte bh 1
1064 get bh = do
1065 h <- getByte bh
1066 case h of
1067 0 -> do return Recursive
1068 _ -> do return NonRecursive
1069
1070 instance Binary OverlapMode where
1071 put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s
1072 put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s
1073 put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s
1074 put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s
1075 put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
1076 get bh = do
1077 h <- getByte bh
1078 case h of
1079 0 -> (get bh) >>= \s -> return $ NoOverlap s
1080 1 -> (get bh) >>= \s -> return $ Overlaps s
1081 2 -> (get bh) >>= \s -> return $ Incoherent s
1082 3 -> (get bh) >>= \s -> return $ Overlapping s
1083 4 -> (get bh) >>= \s -> return $ Overlappable s
1084 _ -> panic ("get OverlapMode" ++ show h)
1085
1086
1087 instance Binary OverlapFlag where
1088 put_ bh flag = do put_ bh (overlapMode flag)
1089 put_ bh (isSafeOverlap flag)
1090 get bh = do
1091 h <- get bh
1092 b <- get bh
1093 return OverlapFlag { overlapMode = h, isSafeOverlap = b }
1094
1095 instance Binary FixityDirection where
1096 put_ bh InfixL = do
1097 putByte bh 0
1098 put_ bh InfixR = do
1099 putByte bh 1
1100 put_ bh InfixN = do
1101 putByte bh 2
1102 get bh = do
1103 h <- getByte bh
1104 case h of
1105 0 -> do return InfixL
1106 1 -> do return InfixR
1107 _ -> do return InfixN
1108
1109 instance Binary Fixity where
1110 put_ bh (Fixity src aa ab) = do
1111 put_ bh src
1112 put_ bh aa
1113 put_ bh ab
1114 get bh = do
1115 src <- get bh
1116 aa <- get bh
1117 ab <- get bh
1118 return (Fixity src aa ab)
1119
1120 instance Binary WarningTxt where
1121 put_ bh (WarningTxt s w) = do
1122 putByte bh 0
1123 put_ bh s
1124 put_ bh w
1125 put_ bh (DeprecatedTxt s d) = do
1126 putByte bh 1
1127 put_ bh s
1128 put_ bh d
1129
1130 get bh = do
1131 h <- getByte bh
1132 case h of
1133 0 -> do s <- get bh
1134 w <- get bh
1135 return (WarningTxt s w)
1136 _ -> do s <- get bh
1137 d <- get bh
1138 return (DeprecatedTxt s d)
1139
1140 instance Binary StringLiteral where
1141 put_ bh (StringLiteral st fs) = do
1142 put_ bh st
1143 put_ bh fs
1144 get bh = do
1145 st <- get bh
1146 fs <- get bh
1147 return (StringLiteral st fs)
1148
1149 instance Binary a => Binary (Located a) where
1150 put_ bh (L l x) = do
1151 put_ bh l
1152 put_ bh x
1153
1154 get bh = do
1155 l <- get bh
1156 x <- get bh
1157 return (L l x)
1158
1159 instance Binary RealSrcSpan where
1160 put_ bh ss = do
1161 put_ bh (srcSpanFile ss)
1162 put_ bh (srcSpanStartLine ss)
1163 put_ bh (srcSpanStartCol ss)
1164 put_ bh (srcSpanEndLine ss)
1165 put_ bh (srcSpanEndCol ss)
1166
1167 get bh = do
1168 f <- get bh
1169 sl <- get bh
1170 sc <- get bh
1171 el <- get bh
1172 ec <- get bh
1173 return (mkRealSrcSpan (mkRealSrcLoc f sl sc)
1174 (mkRealSrcLoc f el ec))
1175
1176 instance Binary SrcSpan where
1177 put_ bh (RealSrcSpan ss) = do
1178 putByte bh 0
1179 put_ bh ss
1180
1181 put_ bh (UnhelpfulSpan s) = do
1182 putByte bh 1
1183 put_ bh s
1184
1185 get bh = do
1186 h <- getByte bh
1187 case h of
1188 0 -> do ss <- get bh
1189 return (RealSrcSpan ss)
1190 _ -> do s <- get bh
1191 return (UnhelpfulSpan s)
1192
1193 instance Binary Serialized where
1194 put_ bh (Serialized the_type bytes) = do
1195 put_ bh the_type
1196 put_ bh bytes
1197 get bh = do
1198 the_type <- get bh
1199 bytes <- get bh
1200 return (Serialized the_type bytes)
1201
1202 instance Binary SourceText where
1203 put_ bh NoSourceText = putByte bh 0
1204 put_ bh (SourceText s) = do
1205 putByte bh 1
1206 put_ bh s
1207
1208 get bh = do
1209 h <- getByte bh
1210 case h of
1211 0 -> return NoSourceText
1212 1 -> do
1213 s <- get bh
1214 return (SourceText s)
1215 _ -> panic $ "Binary SourceText:" ++ show h