Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c4ebdbdf by Cheng Shao at 2026-01-09T20:23:06-05:00 compiler: make getPrim eagerly evaluate its result This commit makes `GHC.Utils.Binary.getPrim` eagerly evaluate its result, to avoid accidental laziness when future patches build other binary parsers using `getPrim`. - - - - - 66a0c4f7 by Cheng Shao at 2026-01-09T20:23:06-05:00 compiler: implement fast get/put for Word16/Word32/Word64 Previously, `GHC.Utils.Binary` contains `get`/`put` functions for `Word16`/`Word32`/`Word64` which always loads and stores them as big-endian words at a potentially unaligned address. The previous implementation is based on loads/stores of individual bytes and concatenating bytes with bitwise operations, which currently cannot be fused to a single load/store operation by GHC. This patch implements fast `get`/`put` functions for `Word16`/`Word32`/`Word64` based on a single memory load/store, with an additional `byteSwap` operation on little-endian hosts. It is based on unaligned load/store primops added since GHC 9.10, and we already require booting with at least 9.10, so it's about time to switch to this faster path. - - - - - 1 changed file: - compiler/GHC/Utils/Binary.hs Changes: ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE DerivingVia #-} @@ -160,14 +161,17 @@ import qualified Data.Set as Set import Data.Time import Data.List (unfoldr) import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import Type.Reflection ( Typeable, SomeTypeRep(..) ) import qualified Type.Reflection as Refl import GHC.Real ( Ratio(..) ) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import GHC.ByteOrder import GHC.ForeignPtr ( unsafeWithForeignPtr ) +import GHC.Exts +import GHC.IO +import GHC.Word import Unsafe.Coerce (unsafeCoerce) @@ -638,7 +642,7 @@ getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do ix <- readFastMutInt ix_r when (ix + size > sz_r) $ ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) - w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix) + !w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix) -- This is safe WRT #17760 as we we guarantee that the above line doesn't -- diverge writeFastMutInt ix_r (ix + size) @@ -651,71 +655,52 @@ getWord8 :: ReadBinHandle -> IO Word8 getWord8 h = getPrim h 1 peek putWord16 :: WriteBinHandle -> Word16 -> IO () -putWord16 h w = putPrim h 2 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) - pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) - ) +putWord16 h w = putPrim h 2 $ \(Ptr p#) -> + IO $ \s -> (# writeWord8OffAddrAsWord16# p# 0# x# s, () #) + where + !(W16# x#) = case targetByteOrder of + BigEndian -> w + LittleEndian -> byteSwap16 w getWord16 :: ReadBinHandle -> 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 h = getPrim h 2 $ \(Ptr p#) -> + IO $ \s -> case readWord8OffAddrAsWord16# p# 0# s of + (# s', w16# #) -> case targetByteOrder of + BigEndian -> (# s', W16# w16# #) + LittleEndian -> case byteSwap16 $ W16# w16# of + !w16 -> (# s', w16 #) putWord32 :: WriteBinHandle -> Word32 -> IO () -putWord32 h w = putPrim h 4 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) - ) +putWord32 h w = putPrim h 4 $ \(Ptr p#) -> + IO $ \s -> (# writeWord8OffAddrAsWord32# p# 0# x# s, () #) + where + !(W32# x#) = case targetByteOrder of + BigEndian -> w + LittleEndian -> byteSwap32 w getWord32 :: ReadBinHandle -> IO Word32 -getWord32 h = getPrim h 4 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - - return $! (w0 `shiftL` 24) .|. - (w1 `shiftL` 16) .|. - (w2 `shiftL` 8) .|. - w3 - ) +getWord32 h = getPrim h 4 $ \(Ptr p#) -> + IO $ \s -> case readWord8OffAddrAsWord32# p# 0# s of + (# s', w32# #) -> case targetByteOrder of + BigEndian -> (# s', W32# w32# #) + LittleEndian -> case byteSwap32 $ W32# w32# of + !w32 -> (# s', w32 #) putWord64 :: WriteBinHandle -> 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)) - ) +putWord64 h w = putPrim h 8 $ \(Ptr p#) -> + IO $ \s -> (# writeWord8OffAddrAsWord64# p# 0# x# s, () #) + where + !(W64# x#) = case targetByteOrder of + BigEndian -> w + LittleEndian -> byteSwap64 w getWord64 :: ReadBinHandle -> 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 - ) +getWord64 h = getPrim h 8 $ \(Ptr p#) -> + IO $ \s -> case readWord8OffAddrAsWord64# p# 0# s of + (# s', w64# #) -> case targetByteOrder of + BigEndian -> (# s', W64# w64# #) + LittleEndian -> case byteSwap64 $ W64# w64# of + !w64 -> (# s', w64 #) putByte :: WriteBinHandle -> Word8 -> IO () putByte bh !w = putWord8 bh w View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1ce1fc3ad38d192cd3b6a38cb42051... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1ce1fc3ad38d192cd3b6a38cb42051... You're receiving this email because of your account on gitlab.haskell.org.