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