Don't variable-length encode magic iface constant.wip/andreask/iface_magic_numbers

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 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