[Git][ghc/ghc][master] Don't variable-length encode magic iface constant.
Marge Bot
gitlab at gitlab.haskell.org
Thu May 21 16:22:11 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4ca0c8a1 by Andreas Klebinger at 2020-05-21T12:21:53-04:00
Don't variable-length encode magic iface constant.
We changed to use variable length encodings for many types by default,
including Word32. This makes sense for numbers but not when Word32 is
meant to represent four bytes.
I added a FixedLengthEncoding newtype to Binary who's instances
interpret their argument as a collection of bytes instead of a number.
We then use this when writing/reading magic numbers to the iface file.
I also took the libery to remove the dummy iface field.
This fixes #18180.
- - - - -
2 changed files:
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Utils/Binary.hs
Changes:
=====================================
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
-- -----------------------------------------------------------------------------
=====================================
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
@@ -512,6 +515,35 @@ getSLEB128 bh = do
let !signed = testBit byte 6
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ca0c8a17b9d3a7e8ff8a93cc9e83be5173f8e14
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ca0c8a17b9d3a7e8ff8a93cc9e83be5173f8e14
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200521/783f28e0/attachment-0001.html>
More information about the ghc-commits
mailing list