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