summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Iface/Binary.hs28
-rw-r--r--compiler/GHC/Utils/Binary.hs118
2 files changed, 80 insertions, 66 deletions
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index a14cb17e04..cefe981847 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -123,20 +123,9 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
-- (This magic number does not change when we change
-- GHC interface file format)
magic <- get bh
- wantedGot "Magic" (binaryInterfaceMagic platform) magic ppr
+ wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength)
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
- (binaryInterfaceMagic platform) magic
-
- -- Note [dummy iface field]
- -- read a dummy 32/64 bit value. This field used to hold the
- -- dictionary pointer in old interface file formats, but now
- -- the dictionary pointer is after the version (where it
- -- should be). Also, the serialisation of value of type "Bin
- -- a" used to depend on the word size of the machine, now they
- -- are always 32 bits.
- case platformWordSize platform of
- PW4 -> do _ <- Binary.get bh :: IO Word32; return ()
- PW8 -> do _ <- Binary.get bh :: IO Word64; return ()
+ (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)
-- Check the interface file version and ways.
check_ver <- get bh
@@ -198,13 +187,6 @@ writeBinIface dflags hi_path mod_iface = do
let platform = targetPlatform dflags
put_ bh (binaryInterfaceMagic platform)
- -- dummy 32/64-bit field before the version/way for
- -- compatibility with older interface file formats.
- -- See Note [dummy iface field] above.
- case platformWordSize platform of
- PW4 -> Binary.put_ bh (0 :: Word32)
- PW8 -> Binary.put_ bh (0 :: Word64)
-
-- The version and way descriptor go next
put_ bh (show hiVersion)
let way_descr = getWayDescr dflags
@@ -290,10 +272,10 @@ putWithUserData log_action bh payload = do
initBinMemSize :: Int
initBinMemSize = 1024 * 1024
-binaryInterfaceMagic :: Platform -> Word32
+binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic platform
- | target32Bit platform = 0x1face
- | otherwise = 0x1face64
+ | target32Bit platform = FixedLengthEncoding 0x1face
+ | otherwise = FixedLengthEncoding 0x1face64
-- -----------------------------------------------------------------------------
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 1283dd5ffb..26a3eb811b 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -52,6 +52,9 @@ module GHC.Utils.Binary
putSLEB128,
getSLEB128,
+ -- * Fixed length encoding
+ FixedLengthEncoding(..),
+
-- * Lazy Binary I/O
lazyGet,
lazyPut,
@@ -314,18 +317,18 @@ putWord8 h !w = putPrim h 1 (\op -> poke op w)
getWord8 :: BinHandle -> IO Word8
getWord8 h = getPrim h 1 peek
--- putWord16 :: BinHandle -> Word16 -> IO ()
--- putWord16 h w = putPrim h 2 (\op -> do
--- pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
--- pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
--- )
+putWord16 :: BinHandle -> Word16 -> IO ()
+putWord16 h w = putPrim h 2 (\op -> do
+ pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
+ pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
+ )
--- getWord16 :: BinHandle -> IO Word16
--- getWord16 h = getPrim h 2 (\op -> do
--- w0 <- fromIntegral <$> peekElemOff op 0
--- w1 <- fromIntegral <$> peekElemOff op 1
--- return $! w0 `shiftL` 8 .|. w1
--- )
+getWord16 :: BinHandle -> IO Word16
+getWord16 h = getPrim h 2 (\op -> do
+ w0 <- fromIntegral <$> peekElemOff op 0
+ w1 <- fromIntegral <$> peekElemOff op 1
+ return $! w0 `shiftL` 8 .|. w1
+ )
putWord32 :: BinHandle -> Word32 -> IO ()
putWord32 h w = putPrim h 4 (\op -> do
@@ -348,38 +351,38 @@ getWord32 h = getPrim h 4 (\op -> do
w3
)
--- putWord64 :: BinHandle -> Word64 -> IO ()
--- putWord64 h w = putPrim h 8 (\op -> do
--- pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
--- pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
--- pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))
--- pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))
--- pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))
--- pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
--- pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
--- pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
--- )
-
--- getWord64 :: BinHandle -> IO Word64
--- getWord64 h = getPrim h 8 (\op -> do
--- w0 <- fromIntegral <$> peekElemOff op 0
--- w1 <- fromIntegral <$> peekElemOff op 1
--- w2 <- fromIntegral <$> peekElemOff op 2
--- w3 <- fromIntegral <$> peekElemOff op 3
--- w4 <- fromIntegral <$> peekElemOff op 4
--- w5 <- fromIntegral <$> peekElemOff op 5
--- w6 <- fromIntegral <$> peekElemOff op 6
--- w7 <- fromIntegral <$> peekElemOff op 7
-
--- return $! (w0 `shiftL` 56) .|.
--- (w1 `shiftL` 48) .|.
--- (w2 `shiftL` 40) .|.
--- (w3 `shiftL` 32) .|.
--- (w4 `shiftL` 24) .|.
--- (w5 `shiftL` 16) .|.
--- (w6 `shiftL` 8) .|.
--- w7
--- )
+putWord64 :: BinHandle -> Word64 -> IO ()
+putWord64 h w = putPrim h 8 (\op -> do
+ pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
+ pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
+ pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))
+ pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))
+ pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))
+ pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
+ pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
+ pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
+ )
+
+getWord64 :: BinHandle -> IO Word64
+getWord64 h = getPrim h 8 (\op -> do
+ w0 <- fromIntegral <$> peekElemOff op 0
+ w1 <- fromIntegral <$> peekElemOff op 1
+ w2 <- fromIntegral <$> peekElemOff op 2
+ w3 <- fromIntegral <$> peekElemOff op 3
+ w4 <- fromIntegral <$> peekElemOff op 4
+ w5 <- fromIntegral <$> peekElemOff op 5
+ w6 <- fromIntegral <$> peekElemOff op 6
+ w7 <- fromIntegral <$> peekElemOff op 7
+
+ return $! (w0 `shiftL` 56) .|.
+ (w1 `shiftL` 48) .|.
+ (w2 `shiftL` 40) .|.
+ (w3 `shiftL` 32) .|.
+ (w4 `shiftL` 24) .|.
+ (w5 `shiftL` 16) .|.
+ (w6 `shiftL` 8) .|.
+ w7
+ )
putByte :: BinHandle -> Word8 -> IO ()
putByte bh !w = putWord8 bh w
@@ -513,6 +516,35 @@ getSLEB128 bh = do
return (val',shift',signed)
-- -----------------------------------------------------------------------------
+-- Fixed length encoding instances
+
+-- Sometimes words are used to represent a certain bit pattern instead
+-- of a number. Using FixedLengthEncoding we will write the pattern as
+-- is to the interface file without the variable length encoding we usually
+-- apply.
+
+-- | Encode the argument in it's full length. This is different from many default
+-- binary instances which make no guarantee about the actual encoding and
+-- might do things use variable length encoding.
+newtype FixedLengthEncoding a = FixedLengthEncoding { unFixedLength :: a }
+
+instance Binary (FixedLengthEncoding Word8) where
+ put_ h (FixedLengthEncoding x) = putByte h x
+ get h = FixedLengthEncoding <$> getByte h
+
+instance Binary (FixedLengthEncoding Word16) where
+ put_ h (FixedLengthEncoding x) = putWord16 h x
+ get h = FixedLengthEncoding <$> getWord16 h
+
+instance Binary (FixedLengthEncoding Word32) where
+ put_ h (FixedLengthEncoding x) = putWord32 h x
+ get h = FixedLengthEncoding <$> getWord32 h
+
+instance Binary (FixedLengthEncoding Word64) where
+ put_ h (FixedLengthEncoding x) = putWord64 h x
+ get h = FixedLengthEncoding <$> getWord64 h
+
+-- -----------------------------------------------------------------------------
-- Primitive Word writes
instance Binary Word8 where
View Lorry Controller Status