GitLab

Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC

Commits:

7731667b

by Andreas Klebinger at 2026-09-15T06:13:26+00:00

.hi files: Various encoding improvements

Binders: Encode non-linear binders more efficiently.

There is no need to serialize the Many type. We just use one bit to
encode that there is an implicit Many as multiplicity when writing to
disk.

Names: Use the low rather than high bit to encode the "compactness".

Since we encode name references as LEB128 using the high bit forces
5-byte references. By using the low bit we can actually compress the
small references when when storing name references using putName.

This allows use to LEB128 encode the combination of tag + value efficiently.

instance Binary Integer:

We used to use a tag byte to store if it fits in a Int64, and if not the
sign and then encode the actual value as LEB128.

Instead we now just encode as SLEB128. The only real downside is that we
have to discover during LEB decoding if we need to swap from Int to
Integer. This saves one byte for small values.

instance Binary iteral:

Don't encode it pointwise. Instead encode the Literal con tag + LitNumberType in a single tag
byte. Followed by the actual value if we deal with number literals.

This saves a byte per literal for small numbers.

`IfaceApp`: There is no real benefit to avoid collapsing chains of
applications. So we add a explicit constructor for n-ary applications.

We could do this just in the Binary instance. But in this case I felt
there is no real downside to express this in the type itself. So I
added:

IfaceApps IfaceExpr [IfaceExpr]

Of course we use a small trick. We use parts of the IFaceExpr tag space
to encode arity of the application. So we don't have to store the length
of the list in the common case.

Saves ~1 byte per argument. Exactly one for small applications. If we
serialize the list length slightly less.

`IfaceAlt`: Improve the encoding

We avoid storing the length for the always-empty lists on _DEFAULT and
literal alternatives by dispatching on the alt type.

`IfaceCase`: Add a special case for single default alts, encoded via
one of the tag bits from `IfaceExpr`.

Generally .hi files get a few % smaller. With a relative big variance with some files
getting more then 20% smaller.

-------------------------
Metric Decrease:
if_ifacetype
-------------------------

14 changed files:

+ changelog.d/T27808-iface-encoding-improvements
compiler/GHC/CoreToIface.hs
compiler/GHC/Iface/Binary.hs
compiler/GHC/Iface/Rename.hs
compiler/GHC/Iface/Syntax.hs
compiler/GHC/Iface/Type.hs
compiler/GHC/IfaceToCore.hs
compiler/GHC/Types/Literal.hs
compiler/GHC/Types/Unique.hs
compiler/GHC/Utils/Binary.hs
+ testsuite/tests/utils/should_run/Binary_Literal.hs
+ testsuite/tests/utils/should_run/Binary_Literal.stdout
testsuite/tests/utils/should_run/all.T
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs

Changes:

changelog.d/T27808-iface-encoding-improvements

 +section: compiler
 +synopsis: Improved ``.hi`` file encoding resulting in less space used on disk.
 +issues: #27808
 +mrs: !16683
 +description: {
 +  This was mostly done by moving from simple pointwise encoding to adding
 +  special cases for common cases.
 +}

compiler/GHC/CoreToIface.hs

@@ -651,16 +651,19 @@ toIfaceApp (Var v) as
  toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
  mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
 -mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
 +-- `mkIfaceApp` is just a smart constructor for the IfaceApp[s] constructors.
 +-- See Note [Iface applications] in GHC.Iface.Syntax
 +mkIfaceApps f as = mkIfaceApp f (map toIfaceExpr as)
  ---------------------
  toIfaceVar :: Id -> IfaceExpr
  toIfaceVar v
      | isBootUnfolding (idUnfolding v)
      = -- See Note [Inlining and hs-boot files]
 -      IfaceApp (IfaceApp (IfaceExt noinline_id)
 -                         (IfaceType (toIfaceType ty)))
 -               (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
 +      IfaceApps (IfaceExt noinline_id)
 +                [IfaceType (toIfaceType ty), IfaceExt name]
 +                -- don't use mkIfaceApps, or infinite loop since it ends up calling
 +                -- toIfaceVar indirectly again.
      | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
                                        -- Foreign calls have special syntax

compiler/GHC/Iface/Binary.hs

@@ -741,25 +741,38 @@ In more detail:
    Tuples aren't included in the wired-in names map: see (ST1) below
  * Serialisation is done by `putName`:
 -  - When we serialise a compact Name,
 -    we serialise it as a single 32-bit word:
 -      10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
 -    where xxxx is the tag, and yyyy is the payload.
 -    The function `wiredInNamesOkay` checks that the wired-in names all have
 -    uniques that fit into the `yyy` field.
 +  - When we serialise a compact Name, we serialise its Unique, split by
 +    `unpkUniqueGrimily` into the tag character and the payload:
++
 +      yyyyyyyy yyyyyyyy yyyyyyyx xxxxxxx1
 +      \________ payload _______/\_ tag _/^ marker bit
++
 +    Why are we storing the marker/tag in the low rather than high bits? Because
 +    we LEB128 encode the whole word when writing to disk so we want to keep as
 +    many of the high bits zero as possible to allow for shorter encodings. See
 +    also wrinkle ST3.
++
 +    Tags are 8 bits by construction, and there is a check that the actual unique
 +    part fits in 22 bits which `wiredInNamesOkay` (in GHC.Builtin) checks for all
 +    known-key names.
    - When we serialise a non-compact name:
        - We look it up in the (stateful, growing) symbol table
 -      - If it not there we add it to the symbol table
 -      - We serialise the occurrenc to a single 32-bit word:
 -          00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
 -        where `xxxxx` is an index into the symbol table.
 +      - If it is not there we add it to the symbol table
 +      - We serialise the occurrence as
 -* Deserialision is done by `getName`.  We read a 32-bit word
 -  - If the MSB is `10` it must be a compact name, so we use
 +          0xxxxxxx xxxxxxxx xxxxxxxx xxxxxxx0
++
 +        In other words we simply shift the index by a bit.
 +        The high bit is currently unused. But `putSymtabNameRef`
 +        asserts that `ix` fits in 30 bits.
++
 +* Deserialisation is done by `getSymtabName`, which dispatches on the low bit
 +  of the word it reads:
 +  - If it is 1 it must be a compact name, so we reassemble the Unique and use
      `lookupCompactName` to get from the Unique to the Name.
 -  - If the MSB is `00` it must be a non-compact Name,
 -    so we look it up in the symbol table.
 +  - If it is 0 it must be a non-compact Name, so we look it up in the
 +    symbol table.
  Wrinkles:
@@ -785,6 +798,20 @@ Wrinkles:
    `isCompactName` that tests for `knownUniqueTupleName` and then the
    TyConRepNames would be serialised as non-compact names, and everything would
    work. Fewer tests, but Typeable-heavy code might have bigger interface files.
++
 +(ST3) Both kinds of Name are serialised as a single `Word32`, which is serialized to
 +  disk in it's ULEB128 encoded variable-length form (see `putULEB128`).
 +  This has consequences as it means we want to keep the high bits zero where possible
 +  to allow for a shorter ULEB128 encoding.
++
 +  This is why we put both the tag and the marker bit at the LSB end of the word. They
 +  are always present. But by putting them at the low end we ensure LEB128 encoding
 +  still works as expected, producing smaller encodings for compact names with small
 +  uniques.
++
 +  The downside is that we steal one bit from non-compact names for which the marker
 +  bit and tag would have been zero either way. But in practice this matters far less
 +  than ensuring built in (compact) names encode well.
  -}
  isCompactName :: Name -> Bool
@@ -803,6 +830,31 @@ lookupCompactName u
    where
       (tag, ix) = unpkUniqueGrimily u
 +-- | Write a reference to a symbol table index.
 +-- See Note [Symbol table representation of names]
 +putSymtabNameRef :: WriteBinHandle -> Int -> IO ()
 +{-# INLINE putSymtabNameRef #-}
 +putSymtabNameRef bh ix
 +  = assertPpr (ix >= 0 && ix < (1 `shiftL` 30))
 +              (text "putSymtabNameRef: symbol table index out of range:" <+> int ix) $
 +    -- Bit 0 == False marks a symbol table reference
 +    put_ bh ((fromIntegral ix `shiftL` 1) :: Word32)
++
 +-- | Write a reference to a compact (known-key) 'Name'.
 +-- See Note [Symbol table representation of names]
 +putCompactNameRef :: WriteBinHandle -> Unique -> IO ()
 +{-# INLINE putCompactNameRef #-}
 +putCompactNameRef bh uniq
 +  = -- INVARIANTS:
 +    --    * 8 bits tag (true by construction)
 +    --    * the payload fits in 22 bits (checked for all known keys elsewhere)
 +    -- Bit 0 == True marks a compact (known-key) name
 +    put_ bh (   (fromIntegral payload `shiftL` 9)
 +            .|. (fromIntegral (ord tag) `shiftL` 1)
 +            .|. 1 :: Word32)
 +  where
 +    (tag, payload) = unpkUniqueGrimily uniq
++
  -- See Note [Symbol table representation of names]
  putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
  putName BinSymbolTable{
@@ -810,16 +862,12 @@ putName BinSymbolTable{
                 bin_symtab_next = symtab_next }
          bh name
    | isCompactName name
 -  , let (c, u) = unpkUniqueGrimily (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
 -  = -- assert (u < 2^(22 :: Int))
 -    put_ bh (0x80000000
 -             .|. (fromIntegral (ord c) `shiftL` 22)
 -             .|. (fromIntegral u :: Word32))
 +  = putCompactNameRef bh (nameUnique name)
    | otherwise
    = do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
         case lookupNameEnv symtab_map name of
 -         Just off -> put_ bh (fromIntegral off :: Word32)
 +         Just off -> putSymtabNameRef bh off
           Nothing -> do
            off <- freshIndex
            let mod = nameModule name
@@ -829,12 +877,11 @@ putName BinSymbolTable{
            let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
            writeIORef symtab_map_ref $! ( symtab_map',  symtab_tbl' )
 -          put_ bh (fromIntegral off :: Word32)
 +          putSymtabNameRef bh off
    where
      freshIndex :: IO Int
      freshIndex = do
        off <- readFastMutInt symtab_next
 -      -- massert (off < 2^(30 :: Int))
        writeFastMutInt symtab_next (off+1)
        return off
@@ -843,12 +890,10 @@ getSymtabName :: SymbolTable Name
                -> ReadBinHandle -> IO Name
  getSymtabName symtab bh = do
      i :: Word32 <- get bh
 -    case i .&. 0xC0000000 of
 -      0x00000000 -> return $! symtab ! fromIntegral i
 -      0x80000000 -> return $! lookupCompactName u
 -        where
 -          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
 -          ix  = fromIntegral i .&. 0x003FFFFF
 -          u   = mkUniqueGrimilyWithTag tag ix
+-
 -      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
 +    if i .&. 1 == 0
 +      then -- Symbol table reference, written by putSymtabNameRef
 +           return $! symtab ! fromIntegral (i `shiftR` 1)
 +      else -- Compact name, written by putCompactNameRef
 +           let tag     = chr (fromIntegral ((i `shiftR` 1) .&. 0xFF))
 +               payload = fromIntegral (i `shiftR` 9) :: Word64
 +           in return $! lookupCompactName (mkUniqueGrimilyWithTag tag payload)

compiler/GHC/Iface/Rename.hs

@@ -828,6 +828,8 @@ rnIfaceExpr (IfaceLam lam_bndr expr)
      = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
  rnIfaceExpr (IfaceApp fun arg)
      = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
 +rnIfaceExpr (IfaceApps fun args)
 +    = IfaceApps <$> rnIfaceExpr fun <*> rnIfaceExprs args
  rnIfaceExpr (IfaceCase scrut case_bndr alts)
      = IfaceCase <$> rnIfaceExpr scrut
                  <*> pure case_bndr

compiler/GHC/Iface/Syntax.hs

@@ -10,7 +10,8 @@ module GHC.Iface.Syntax (
          IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
          IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
 -        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
 +        IfaceExpr(..), mkIfaceApp,
 +        IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
          IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
          IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
          IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -96,8 +97,8 @@ import GHC.Utils.Fingerprint
  import GHC.Utils.Binary
  import GHC.Utils.Outputable as Outputable
  import GHC.Utils.Panic
 -import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith,
 -                       zipWithEqual )
 +import GHC.Utils.Misc( dropList, filterByList, notNull,
 +                       unzipWith, zipWithEqual )
  import GHC.Data.FastString
  import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue)
@@ -700,6 +701,11 @@ data IfaceExpr
    | IfaceTuple  TupleSort [IfaceExpr]   -- Saturated; type arguments omitted
    | IfaceLam    IfaceLamBndr IfaceExpr
    | IfaceApp    IfaceExpr IfaceExpr
 +        -- ^ Application to exactly one argument.
 +        -- See Note [Iface applications]
 +  | IfaceApps   IfaceExpr [IfaceExpr]
 +        -- ^ Application to two or more arguments.
 +        -- See Note [Iface applications]
    | IfaceCase   IfaceExpr IfLclName [IfaceAlt]
    | IfaceECase  IfaceExpr IfaceType     -- See Note [Empty case alternatives]
    | IfaceLet    (IfaceBinding IfaceLetBndr) IfaceExpr
@@ -710,6 +716,18 @@ data IfaceExpr
    | IfaceFCall  ForeignCall IfaceType
    | IfaceTick   IfaceTickish IfaceExpr    -- from Tick tickish E
 +-- | Apply an expression to a (possibly empty) list of arguments, maintaining
 +-- the invariants of 'IfaceApp' and 'IfaceApps'.
 +-- See Note [Iface applications].
 +mkIfaceApp :: IfaceExpr -> [IfaceExpr] -> IfaceExpr
 +mkIfaceApp fun args = go fun args
 +  where
 +    go (IfaceApp f a)   as = go f (a : as)
 +    go (IfaceApps f fs) as = go f (fs ++ as)
++
 +    go f []  = f
 +    go f [a] = IfaceApp f a
 +    go f as  = IfaceApps f as
  data IfaceTickish
    = IfaceHpcTick    Module Int               -- from HpcTick x
@@ -745,6 +763,30 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
  data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
  {-
 +Note [Iface applications]
 +~~~~~~~~~~~~~~~~~~~~~~~~~
 +A Core application chain (f a1 a2 ... an) could be represented by a chain of
 +n nested IfaceApp nodes like Core does. However this is generally a worse
 +representation for *serialization* which is the main purpose of the Iface type.
++
 +So we keep the single argument constructor as it's fairly common, and add one
 +to represent multiple arguments:
++
 +  * IfaceApp  f a        -- exactly one argument
 +  * IfaceApps f [a1,..]  -- two or more arguments
++
 +with two invariants:
++
 +  (1) The argument list of an IfaceApps has at least two elements.
 +      (A one-argument application is an IfaceApp, and a zero-argument
 +      "application" is just the head itself.)
++
 +  (2) The head of an IfaceApp or IfaceApps is never itself an IfaceApp or
 +      IfaceApps: application chains are fully flattened.
++
 +The smart constructor 'mkIfaceApp' establishes both invariants; producers
 +should use it rather than building IfaceApps directly.
++
  Note [Empty case alternatives]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  In Iface syntax an IfaceCase does not record the types of the alternatives,
@@ -1797,7 +1839,8 @@ pprIfaceExpr _ (IfaceLitRubbish tc r)
      <> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" })
      <> parens (ppr r)
 -pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 +pprIfaceExpr add_par app@(IfaceApp _ _)  = add_par (pprIfaceApp app [])
 +pprIfaceExpr add_par app@(IfaceApps _ _) = add_par (pprIfaceApp app [])
  pprIfaceExpr add_par i@(IfaceLam _ _)
    = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow,
@@ -1869,9 +1912,13 @@ pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs)
  ------------------
  pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
 -pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
 +-- NB: IfaceApps must print exactly like the equivalent IfaceApp chain, so
 +-- that --show-iface output does not depend on which one the producer emitted.
 +pprIfaceApp (IfaceApp fun arg)   args = pprIfaceApp fun $
                                            nest 2 (pprParendIfaceExpr arg) : args
 -pprIfaceApp fun                args = sep (pprParendIfaceExpr fun : args)
 +pprIfaceApp (IfaceApps fun as)   args = pprIfaceApp fun $
 +                                          map (nest 2 . pprParendIfaceExpr) as ++ args
 +pprIfaceApp fun                  args = sep (pprParendIfaceExpr fun : args)
  ------------------
  instance Outputable IfaceConAlt where
@@ -2170,6 +2217,7 @@ freeNamesIfExpr (IfaceCo co)          = freeNamesIfCoercion co
  freeNamesIfExpr (IfaceTuple _ as)     = fnList freeNamesIfExpr as
  freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body
  freeNamesIfExpr (IfaceApp f a)        = freeNamesIfExpr f &&& freeNamesIfExpr a
 +freeNamesIfExpr (IfaceApps f as)      = freeNamesIfExpr f &&& fnList freeNamesIfExpr as
  freeNamesIfExpr (IfaceCast e co)      = freeNamesIfExpr e &&& freeNamesIfCoercion co
  freeNamesIfExpr (IfaceTick t e)       = freeNamesIfTickish t &&& freeNamesIfExpr e
  freeNamesIfExpr (IfaceECase e ty)     = freeNamesIfExpr e &&& freeNamesIfType ty
@@ -2830,17 +2878,46 @@ infixl 9 .<<|.
  x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
  {-# INLINE (.<<|.) #-}
 +-- Encoding shortcuts:
 +-- Since only IfaceDataAlt can have binders
 +-- we can skip the binder list for DEFAULT and Literal alternatives.
  instance Binary IfaceAlt where
      put_ bh (IfaceAlt a b c) = do
          put_ bh a
 -        put_ bh b
 +        case a of
 +          IfaceDataAlt {}  -> put_ bh b
 +          _                -> assertPpr (null b) (ppr a $$ ppr b) $ return ()
          put_ bh c
      get bh = do
          a <- get bh
 -        b <- get bh
 +        b <- case a of
 +               IfaceDataAlt {}  -> get bh
 +               _                -> return []
          c <- get bh
          return (IfaceAlt a b c)
 +{- Note [IfaceExpr encoding shortcuts]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +We use a full byte to encode the constructor tag for `IfaceExpr`.
 +This leaves room to encode additional information. Concretely we
 +use:
++
 +0  .. 14: "Simple" constructor tags.
 +15 .. 22: "IfaceApps", encoding the constructor *and* arity.
 +      23: "IfaceCase" for a case with a single default alternative.
++
 +Note [Binary encoding of IfaceApps]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +For IfaceApps we use the following scheme:
++
 +  * arity 2..8:  one byte encoding the arity as (15 + (n-2))
 +                 Which is followed by the head expression and then exactly `arity` arguments.
++
 +  * arity > 8:   tag 22, and we serialize the argument count as a ULEB128, followed by the
 +                 head expression and arguments.
++
 +This saves us one byte per application with `2 <= arity <= 8`.
 +-}
  instance Binary IfaceExpr where
      put_ bh (IfaceLcl aa) = do
          putByte bh 0
@@ -2864,6 +2941,12 @@ instance Binary IfaceExpr where
          putByte bh 5
          put_ bh ag
          put_ bh ah
 +    -- See Note [IfaceExpr encoding shortcuts]
 +    put_ bh (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak]) = do
 +        putByte bh 23
 +        put_ bh ai
 +        put_ bh aj
 +        put_ bh ak
      put_ bh (IfaceCase ai aj ak) = do
          putByte bh 6
          put_ bh ai
@@ -2899,6 +2982,17 @@ instance Binary IfaceExpr where
          putByte bh 14
          put_ bh r
          put_ bh torc
 +    -- See Note [Iface applications] and Note [Binary encoding of IfaceApps]
 +    -- and Note [IfaceExpr encoding shortcuts]
 +    put_ bh (IfaceApps fun args) = do
 +        let !n = length args
 +        massertPpr (n >= 2) (text "put_ IfaceApps" <+> ppr n)
 +        if n <= maxIfaceAppsTagArity
 +          then putByte bh (fromIntegral (ifaceAppsTag0 + n - 2))
 +          else do putByte bh (fromIntegral ifaceAppsBigTag)
 +                  put_ bh n
 +        put_ bh fun
 +        mapM_ (put_ bh) args
      get bh = do
          h <- getByte bh
          case h of
@@ -2944,7 +3038,41 @@ instance Binary IfaceExpr where
 -> do r <- get bh
                       torc <- get bh
                       return (IfaceLitRubbish torc r)
 +            -- Tags 15..21 encode an IfaceApps of arity 2..8 in the tag itself;
 +            -- tag 22 is followed by an explicit (LEB128) argument count.
 +            -- See Note [Binary encoding of IfaceApps]
 +            15 -> getApps 2
 +            16 -> getApps 3
 +            17 -> getApps 4
 +            18 -> getApps 5
 +            19 -> getApps 6
 +            20 -> getApps 7
 +            21 -> getApps 8
 +            22 -> do n <- get bh
 +                     getApps n
 +            -- case scrut of bndr { DEFAULT -> rhs}
 +            23 -> do ai <- get bh
 +                     aj <- get bh
 +                     ak <- get bh
 +                     return (IfaceCase ai aj [IfaceAlt IfaceDefaultAlt [] ak])
              _ -> panic ("get IfaceExpr " ++ show h)
 +      where
 +        getApps :: Int -> IO IfaceExpr
 +        getApps n = do fun  <- get bh
 +                       args <- replicateM n (get bh)
 +                       return (IfaceApps fun args)
 +-- | Tag used for an 'IfaceApps' with exactly two arguments and start
 +-- of the ifaceApps tag range.
 +ifaceAppsTag0 :: Int
 +ifaceAppsTag0 = 15
++
 +-- | Highest arity encoded directly in tag byte.
 +maxIfaceAppsTagArity :: Int
 +maxIfaceAppsTagArity = 8
++
 +-- | Tag for an 'IfaceApps' whose arity is serialized as ULEB128.
 +ifaceAppsBigTag :: Int
 +ifaceAppsBigTag = 22
  instance Binary IfaceTickish where
      put_ bh (IfaceHpcTick m ix) = do
@@ -3211,6 +3339,7 @@ instance NFData IfaceExpr where
      IfaceTuple sort exprs -> rnf sort `seq` rnf exprs
      IfaceLam bndr expr -> rnf bndr `seq` rnf expr
      IfaceApp e1 e2 -> rnf e1 `seq` rnf e2
 +    IfaceApps e es -> rnf e `seq` rnf es
      IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts
      IfaceECase e ty -> rnf e `seq` rnf ty
      IfaceLet bind e -> rnf bind `seq` rnf e

compiler/GHC/Iface/Type.hs

@@ -1073,7 +1073,18 @@ pprIfaceTyConBinders suppress_sig = sep . map go
        where
          ppr_bndr = pprIfaceTvBndr bndr suppress_sig
 +-- | IfaceBndr shortcuts:
 +--
 +-- In the vast majority of cases binder multiplicity is `Many` so storing it is
 +-- a pure waste of space. Instead of storing (Many, Name, Ty) we simply store
 +-- (Name,Ty) in the common case where multiplicity == Many.
  instance Binary IfaceBndr where
 +    put_ bh (IfaceIdBndr (mult, name, ty))
 +      -- The implicit Many shortcut.
 +      | mult == many_ty = do
 +            putByte bh 2
 +            put_ bh name
 +            put_ bh ty
      put_ bh (IfaceIdBndr aa) = do
              putByte bh 0
              put_ bh aa
@@ -1085,8 +1096,11 @@ instance Binary IfaceBndr where
              case h of
 -> do aa <- get bh
                        return (IfaceIdBndr aa)
 -              _ -> do ab <- get bh
 +              1 -> do ab <- get bh
                        return (IfaceTvBndr ab)
 +              _ -> do name <- get bh
 +                      ty <- get bh
 +                      return (IfaceIdBndr (many_ty, name, ty))
  instance Binary IfaceOneShot where
      put_ bh IfaceNoOneShot =

compiler/GHC/IfaceToCore.hs

@@ -1446,6 +1446,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
      ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
      ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
      ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
 +    ifTopFreeName (IfaceApps f _)                   = ifTopFreeName f
      ifTopFreeName (IfaceExt n)                      = Just n
      ifTopFreeName _                                 = Nothing
@@ -1682,6 +1683,9 @@ tcIfaceExpr (IfaceLam (bndr, os) body)
  tcIfaceExpr (IfaceApp fun arg)
    = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
 +tcIfaceExpr (IfaceApps fun args)
 +  = mkApps <$> tcIfaceExpr fun <*> mapM tcIfaceExpr args
++
  tcIfaceExpr (IfaceECase scrut ty)
    = do { scrut' <- tcIfaceExpr scrut
         ; ty' <- tcIfaceType ty

compiler/GHC/Types/Literal.hs

@@ -167,7 +167,7 @@ data LitNumType
    | LitNumWord16  -- ^ @Word16#@ - exactly 16 bits
    | LitNumWord32  -- ^ @Word32#@ - exactly 32 bits
    | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits
 -  deriving (Data,Enum,Eq,Ord)
 +  deriving (Data,Enum,Eq,Ord,Bounded)
  -- | Indicate if a numeric literal type supports negative numbers
  litNumIsSigned :: LitNumType -> Bool
@@ -259,6 +259,38 @@ for more details.
  -}
 +{-
 +Note [Binary Literal encoding]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +Rather than write `LitNumType` into it's own tag byte we encode it in the
 +surplus space of the `Literal` tag space.
++
 +This means for `Literal` tag 0 .. 5 are the non-num literals.
 +Literals 6 .. (maxBound LitNumType) encode the LitNumType.
++
 +We could use the `LitNumType` information to slightly improve the encoding of
 +the actual values too. But we just write/read them at Integer for simplicity for
 +now.
 +-}
++
 +-- | The 'Binary' tag byte of @'LitNumber' nt _@.
 +--
 +-- These continue the tags of the non-numeric 'Literal' constructors. The
 +-- mapping is total and part of the interface file format.
 +-- See Note [Binary Literal encoding].
 +litNumTypeTag :: LitNumType -> Word8
 +litNumTypeTag nt =
 +  -- 6 .. 16
 +  6 + (fromIntegral $ fromEnum nt)
++
 +-- | The inverse of 'litNumTypeTag'. 'Nothing' for a tag which isn't the tag
 +-- of a numeric literal. See Note [Binary Literal encoding].
 +litNumTypeOfTag :: Word8 -> Maybe LitNumType
 +litNumTypeOfTag tag
 +  | tag >= 6 && tag <= 16
 +  = Just (toEnum $ (fromIntegral tag) - 6)
 +  | otherwise = Nothing
++
  instance Binary Literal where
      put_ bh (LitChar aa)     = do putByte bh 0; put_ bh aa
      put_ bh (LitString ab)   = do putByte bh 1; put_ bh ab
@@ -269,9 +301,10 @@ instance Binary Literal where
          = do putByte bh 5
               put_ bh aj
               put_ bh fod
 +    -- The LitNumType is part of the tag byte.
 +    -- See Note [Binary Literal encoding]
      put_ bh (LitNumber nt i)
 -        = do putByte bh 6
 -             put_ bh nt
 +        = do putByte bh (litNumTypeTag nt)
               put_ bh i
      put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit)
       -- We use IfaceLitRubbish; see Note [Rubbish literals], item (6)
@@ -296,11 +329,11 @@ instance Binary Literal where
                      aj <- get bh
                      fod <- get bh
                      return (LitLabel aj fod)
 -              6 -> do
 -                    nt <- get bh
 -                    i  <- get bh
 -                    return (LitNumber nt i)
 -              _ -> pprPanic "Binary:Literal" (int (fromIntegral h))
 +              _ | Just nt <- litNumTypeOfTag h
 +                -> do i <- get bh
 +                      return (LitNumber nt i)
 +                | otherwise
 +                -> pprPanic "Binary:Literal" (int (fromIntegral h))
  instance NFData Literal where
      rnf (LitChar c) = rnf c

compiler/GHC/Types/Unique.hs

@@ -393,7 +393,7 @@ unpkUnique u = case unpkUniqueGrimily u of
  isValidKnownKeyUnique :: Unique -> Bool
  isValidKnownKeyUnique u =
      case unpkUniqueGrimily u of
 -      (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
 +      (c, x) -> ord c < 0xff && x < (1 `shiftL` 22)
  {-
  ************************************************************************

compiler/GHC/Utils/Binary.hs

@@ -148,7 +148,7 @@ import GHCi.FFI
  import GHCi.Message
  import Control.DeepSeq
 -import Control.Monad            ( when, (<$!>), unless, forM_, void )
 +import Control.Monad            ( when, unless, forM_, void )
  import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
  import Data.Array
  import Data.Array.Base (unsafeFreezeIOArray)
@@ -173,7 +173,6 @@ import Data.Proxy
  import Data.Set                 ( Set )
  import qualified Data.Set as Set
  import Data.Time hiding ( Nominal )
 -import Data.List (unfoldr)
  import System.IO as IO
  import System.IO.Error          ( mkIOError, eofErrorType )
  import Type.Reflection          ( Typeable, SomeTypeRep(..) )
@@ -188,6 +187,7 @@ import GHC.ForeignPtr           ( unsafeWithForeignPtr )
  import GHC.Exts
  import GHC.IO
  import GHC.Word
 +import GHC.Num (Integer(IS))
  import Unsafe.Coerce (unsafeCoerce)
  import GHC.Serialized
@@ -805,6 +805,7 @@ getULEB128 bh =
  {-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
  {-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
  {-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
 +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Integer -> IO () #-}
  putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
  putSLEB128 bh initial = go initial
    where
@@ -1123,86 +1124,91 @@ instance Binary IsBootInterface where
                          False -> NotBoot
  {-
 -Finally - a reasonable portable Integer instance.
 +Note [Integer serialisation]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +We simply encode Integer as SLEB128 unconditionally.
 -We used to encode values in the Int32 range as such,
 -falling back to a string of all things. In either case
 -we stored a tag byte to discriminate between the two cases.
 +This is a tradeoff:
 +It allows shorter encodings for the common case of small values. And we don't need
 +to prefix the string with a byte carrying any information about size or sign.
 -This made some sense as it's highly portable but also not very
 -efficient.
 +However it means large Integer values will pay some overhead. Their encoding can
 +go from 9 (1 prefix, 8 value) to 10 bytes. Such values will also end up encoding
 +into a `Integer` accumulator rather than a simple Word64#.
 -However GHC stores a surprisingly large number of large Integer
 -values. In the examples looked at between 25% and 50% of Integers
 -serialized were outside of the Int32 range.
 +In practice interface files have enough small values to make this tradeoff worthwhile.
 +We could also restore this benefit by using one or two *bits* rather than a full
 +byte for the prefix. I imagine this would be worthwhile in runtime, but I've not
 +gone as for for the sake of avoiding complexity.
 -Consider a value like `2724268014499746065`, some sort of hash
 -actually generated by GHC.
 -In the old scheme this was encoded as a list of 19 chars. This
 -gave a size of 77 Bytes, one for the length of the list and 76
 -since we encode chars as Word32 as well.
 -We can easily do better. The new plan is:
+-
 -* Start with a tag byte
 -  * 0 => Int64 (LEB128 encoded)
 -  * 1 => Negative large integer
 -  * 2 => Positive large integer
 -* Followed by the value:
 -  * Int64 is encoded as usual
 -  * Large integers are encoded as a list of bytes (Word8).
 -    We use Data.Bits which defines a bit order independent of the representation.
 -    Values are stored LSB first.
+-
 -This means our example value `2724268014499746065` is now only 10 bytes large.
 -* One byte tag
 -* One byte for the length of the [Word8] list.
 -* 8 bytes for the actual date.
+-
 -The new scheme also does not depend in any way on
 -architecture specific details.
+-
 -We still use this scheme even with LEB128 available,
 -as it has less overhead for truly large numbers. (> maxBound :: Int64)
+-
 -The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
  -}
  instance Binary Integer where
 -    put_ bh i
 -      | i >= lo64 && i <= hi64 = do
 -          putWord8 bh 0
 -          put_ bh (fromIntegral i :: Int64)
 -      | otherwise = do
 -          if i < 0
 -            then putWord8 bh 1
 -            else putWord8 bh 2
 -          put_ bh (unroll $ abs i)
 +    -- See Note [Integer serialisation]
 +    put_ bh (IS i)
 +      = putSLEB128 bh (I# i)
 +    put_ bh large_i
 +      = putSLEB128 bh large_i
        where
 -        lo64 = fromIntegral (minBound :: Int64)
 -        hi64 = fromIntegral (maxBound :: Int64)
 -    get bh = do
 -      int_kind <- getWord8 bh
 -      case int_kind of
 -        0 -> fromIntegral <$!> (get bh :: IO Int64)
 -        -- Large integer
 -        1 -> negate <$!> getInt
 -        2 -> getInt
 -        _ -> panic "Binary Integer - Invalid byte"
 -        where
 -          getInt :: IO Integer
 -          getInt = roll <$!> (get bh :: IO [Word8])
+-
 -unroll :: Integer -> [Word8]
 -unroll = unfoldr step
 -  where
 -    step 0 = Nothing
 -    step i = Just (fromIntegral i, i `shiftR` 8)
 +    get bh = getSLEB128Integer bh
 -roll :: [Word8] -> Integer
 -roll   = foldl' unstep 0 . reverse
 +-- | Read an SLEB128 encoded 'Integer'.
 +--
 +-- Unlike 'getSLEB128' this doesn't require a 'FiniteBits' instance, which
 +-- 'Integer' lacks. See Note [Integer serialisation].
 +getSLEB128Integer :: ReadBinHandle -> IO Integer
 +getSLEB128Integer bh = go_word 0 0
    where
 -    unstep a b = a `shiftL` 8 .|. fromIntegral b
 +    -- Accumulate in a Word64 for as long as possible
 +    go_word :: Int -> Word64 -> IO Integer
 +    go_word !shift !acc = do
 +        byte <- getByte bh
 +        let !byteVal = clearBit byte 7
 +        let more = testBit byte 7
 +        let !shift' = shift + 7 -- bits read *after* this step
 +        -- Check if the payload still fits in the accumulator,
 +        -- if not swap to a Integer accumulator.
 +        if shift' <= 64
 +          then do
 +            let !acc' = acc .|. (fromIntegral byteVal `unsafeShiftL` shift)
 +            if more
 +              then go_word shift' acc'
 +              else return $! signExtendWord shift' acc' (testBit byte 6)
 +          else do
 +            -- They don't, so from here on out we use Integer arithmetic.
 +            let !acc' = toInteger acc .|. (toInteger byteVal `shiftL` shift)
 +            if more
 +              then go_big shift' acc'
 +              else return $! signExtendInteger shift' acc' (testBit byte 6)
++
 +    go_big :: Int -> Integer -> IO Integer
 +    go_big !shift !acc = do
 +        byte <- getByte bh
 +        let !acc' = acc .|. (toInteger (clearBit byte 7) `shiftL` shift)
 +        let !more = testBit byte 7
 +        let !shift' = shift + 7
 +        if more
 +          then go_big shift' acc'
 +          else return $! signExtendInteger shift' acc' (testBit byte 6)
++
 +    -- Sign extend a value of which we read `shift` bits into a Word64.
 +    -- `shift` is always <= 64 here, so the result always fits into an Int64.
 +    signExtendWord :: Int -> Word64 -> Bool -> Integer
 +    signExtendWord !shift !acc signed
 +      | not signed
 +      = toInteger acc
 +      | shift < 64
 +      -- set high bits not encoded in the payload
 +      = toInteger (fromIntegral (acc .|. (complement 0 `unsafeShiftL` shift)) :: Int64)
 +      | otherwise
 +      = toInteger (fromIntegral acc :: Int64)
++
 +    -- Sign extend into an Integer.
 +    signExtendInteger :: Int -> Integer -> Bool -> Integer
 +    signExtendInteger !shift !acc signed
 +      | signed = acc - (1 `shiftL` shift)
 +      | otherwise = acc
      {-

testsuite/tests/utils/should_run/Binary_Literal.hs

 +{-# LANGUAGE ScopedTypeVariables #-}
 +{-# LANGUAGE TypeApplications    #-}
 +-- LLM generated test. So if it's weird it's for no good reason.
 +--
 +-- Property tests for the 'Binary' instance of 'Literal' in GHC.Types.Literal.
 +--
 +-- We check that
 +--  * arbitrary literals round trip through 'put_' and 'get',
 +--  * a whole batch of literals written into one buffer reads back in order,
 +--    that is the reader consumes exactly the bytes the writer produced,
 +--  * and, since numeric literals carry an 'Integer', that the SLEB128 based
 +--    'Binary Integer' instance agrees with a reference implementation.
 +module Main (main) where
++
 +import GHC.Data.FastString
 +import GHC.Platform ( genericPlatform )
 +import GHC.Types.Basic ( FunctionOrData(..) )
 +import GHC.Types.Literal
 +import GHC.Types.Literal.Floating
 +import GHC.Utils.Binary
++
 +import Control.Monad ( replicateM )
 +import Data.Bits
 +import qualified Data.ByteString as BS
 +import Data.Ratio ( (%) )
 +import Data.Word
 +import GHC.Float ( castFloatToWord32, castWord32ToFloat
 +                 , castDoubleToWord64, castWord64ToDouble )
 +import Numeric ( showHex )
 +import System.IO.Unsafe ( unsafePerformIO )
++
 +import MiniQuickCheck
++
 +--------------------------------------------------------------------------------
 +-- Encoding and decoding
++
 +-- | 'LitLabel' contains a 'FastString', which the 'Binary' instance writes
 +-- through a table in the handle's user data. Interface files fill this in with
 +-- a deduplication table. We only need something that round trips, so we write
 +-- the bytes of the string inline.
 +withFastStringWriter :: WriteBinHandle -> WriteBinHandle
 +withFastStringWriter = addWriterToUserData (BinaryWriter (\bh fs -> put_ bh (bytesFS fs)))
++
 +withFastStringReader :: ReadBinHandle -> ReadBinHandle
 +withFastStringReader = addReaderToUserData (BinaryReader (\bh -> mkFastStringByteString <$> get bh))
++
 +-- | Serialise the values and also return the position after the last of them.
 +encodeAll :: Binary a => [a] -> (BS.ByteString, Bin ())
 +encodeAll xs = unsafePerformIO $ do
 +  bh <- withFastStringWriter <$> openBinMem 1024
 +  mapM_ (put_ bh) xs
 +  end <- tellBinWriter bh
 +  bs <- withBinBuffer bh (return . BS.copy)
 +  return (bs, end)
++
 +encode :: Binary a => a -> BS.ByteString
 +encode x = fst (encodeAll [x])
++
 +-- | Read back @n@ values and check that doing so consumed exactly the bytes
 +-- the writer produced, no more and no less.
 +decodeAll :: Binary a => Int -> (BS.ByteString, Bin ()) -> [a]
 +decodeAll n (bs, end) = unsafePerformIO $ do
 +  bh <- withFastStringReader <$> unsafeUnpackBinBuffer bs
 +  xs <- replicateM n (get bh)
 +  end' <- tellBinReader bh
 +  if end' == end
 +    then return xs
 +    else fail $ "reader stopped at " ++ show end' ++ ", writer at " ++ show end
++
 +roundTrip :: Binary a => [a] -> [a]
 +roundTrip xs = decodeAll (length xs) (encodeAll xs)
++
 +roundTrip1 :: Binary a => a -> a
 +roundTrip1 x = case roundTrip [x] of
 +  [x'] -> x'
 +  _    -> error "roundTrip1"
++
 +--------------------------------------------------------------------------------
 +-- Literals with structural equality and a Show instance
++
 +-- | 'Literal' has neither a 'Show' instance nor an 'Eq' instance which compares
 +-- all fields: 'LitLabel' ignores the 'FunctionOrData' and 'LitFloating'
 +-- identifies the different representations of the same value. For a
 +-- serialisation test we want the stricter notion.
 +newtype Lit = Lit Literal
++
 +instance Show Lit where
 +  show (Lit l) = showLit l
++
 +instance Eq Lit where
 +  Lit a == Lit b = eqLit a b
++
 +eqLit :: Literal -> Literal -> Bool
 +eqLit (LitLabel fs1 fod1) (LitLabel fs2 fod2)
 +  = fs1 == fs2 && fod1 == fod2
 +eqLit (LitFloating ty1 v1) (LitFloating ty2 v2)
 +  -- 'Eq LitFloating' compares NaNs bitwise but identifies different
 +  -- representations of the same value; the derived 'Show' distinguishes the
 +  -- representations but not NaN payloads. Together they compare structurally.
 +  = ty1 == ty2 && v1 == v2 && show v1 == show v2
 +eqLit a b = a == b
++
 +showLit :: Literal -> String
 +showLit lit = case lit of
 +  LitChar c        -> "LitChar " ++ show c
 +  LitNumber nt i   -> "LitNumber " ++ showLitNumType nt ++ " " ++ show i
 +  LitString bs     -> "LitString " ++ show bs
 +  LitNullAddr      -> "LitNullAddr"
 +  LitRubbish {}    -> "LitRubbish"
 +  LitFloating ty v -> "LitFloating " ++ show ty ++ " (" ++ show v ++ ") " ++ bits ty v
 +  LitLabel fs fod  -> "LitLabel " ++ show (bytesFS fs) ++ " " ++ showFod fod
 +  where
 +    -- The bit pattern is needed to tell apart NaNs.
 +    bits LitFloat  v = "0x" ++ showHex (castFloatToWord32  (litFloatingToHostFloat  v)) ""
 +    bits LitDouble v = "0x" ++ showHex (castDoubleToWord64 (litFloatingToHostDouble v)) ""
++
 +    showFod IsFunction = "IsFunction"
 +    showFod IsData     = "IsData"
++
 +showLitNumType :: LitNumType -> String
 +showLitNumType nt = case nt of
 +  LitNumBigNat -> "LitNumBigNat"
 +  LitNumInt    -> "LitNumInt"
 +  LitNumInt8   -> "LitNumInt8"
 +  LitNumInt16  -> "LitNumInt16"
 +  LitNumInt32  -> "LitNumInt32"
 +  LitNumInt64  -> "LitNumInt64"
 +  LitNumWord   -> "LitNumWord"
 +  LitNumWord8  -> "LitNumWord8"
 +  LitNumWord16 -> "LitNumWord16"
 +  LitNumWord32 -> "LitNumWord32"
 +  LitNumWord64 -> "LitNumWord64"
++
 +--------------------------------------------------------------------------------
 +-- Generators
++
 +-- | A number in @[0, n)@. Uses the high bits of the LCG state, which are the
 +-- more random ones.
 +choose :: Int -> Gen Int
 +choose n = (`mod` n) . fromIntegral . (`shiftR` 32) <$> arbitraryWord64
++
 +oneOf :: [Gen a] -> Gen a
 +oneOf gens = do
 +  i <- choose (length gens)
 +  gens !! i
++
 +listOf :: Int -> Gen a -> Gen [a]
 +listOf maxLen gen = do
 +  n <- choose (maxLen + 1)
 +  replicateM n gen
++
 +-- | 'MiniQuickCheck's 'Integer' instance generates values of up to 192 bits,
 +-- which rarely hit the boundaries of the SLEB128 encoding. So we mix in small
 +-- values and values around powers of two.
 +genInteger :: Gen Integer
 +genInteger = oneOf
 +  [ arbitrary
 +  , fromIntegral . subtract 300 <$> choose 601
 +  , do k <- choose 200
 +       d <- subtract 2 <$> choose 5
 +       neg <- arbitrary
 +       let v = 2 ^ k + toInteger d
 +       return (if neg then negate v else v)
 +  ]
++
 +genLitNumType :: Gen LitNumType
 +genLitNumType = oneOf (map pure [LitNumBigNat ..])
++
 +-- | Numeric literals are always in range for their type, see
 +-- Note [Word/Int underflow/overflow] in GHC.Types.Literal. The encoding is
 +-- free to rely on that, so we generate only such literals.
 +genLitNumber :: Gen Literal
 +genLitNumber = do
 +  nt <- genLitNumType
 +  i  <- genInteger
 +  -- 'mkLitNumberWrap' wraps into the range of the fixed width types but
 +  -- refuses negative 'BigNat's.
 +  let i' | LitNumBigNat <- nt = abs i
 +         | otherwise          = i
 +  return (mkLitNumberWrap genericPlatform nt i')
++
 +-- | Random bit patterns, so that we also get infinities, negative zero,
 +-- subnormals and NaNs with various payloads.
 +genFloat :: Gen Float
 +genFloat = castWord32ToFloat <$> arbitrary
++
 +genDouble :: Gen Double
 +genDouble = castWord64ToDouble <$> arbitrary
++
 +genRational :: Gen Rational
 +genRational = do
 +  n <- genInteger
 +  NonZero d <- arbitrary @(NonZero Integer)
 +  return (n % d)
++
 +genLitFloating :: Gen LitFloating
 +genLitFloating = oneOf
 +  [ floatToLitFloating <$> genFloat
 +  , doubleToLitFloating <$> genDouble
 +  , rationalToLitFloating <$> genRational
 +  ]
++
 +genLitFloatingType :: Gen LitFloatingType
 +genLitFloatingType = oneOf [ pure LitFloat, pure LitDouble ]
++
 +genByteString :: Gen BS.ByteString
 +genByteString = BS.pack <$> listOf 64 arbitrary
++
 +genFunctionOrData :: Gen FunctionOrData
 +genFunctionOrData = oneOf [ pure IsFunction, pure IsData ]
++
 +-- | Any literal except 'LitRubbish', which has no 'Binary' encoding, see
 +-- Note [Rubbish literals] in GHC.Types.Literal.
 +genLiteral :: Gen Literal
 +genLiteral = oneOf
 +  [ LitChar <$> arbitrary
 +  , genLitNumber
 +  , LitString <$> genByteString
 +  , pure LitNullAddr
 +  , LitFloating <$> genLitFloatingType <*> genLitFloating
 +  , LitLabel <$> (mkFastStringByteString <$> genByteString) <*> genFunctionOrData
 +  ]
++
 +instance Arbitrary Lit where
 +  arbitrary = Lit <$> genLiteral
++
 +newtype Lits = Lits [Lit]
 +  deriving (Eq, Show)
++
 +instance Arbitrary Lits where
 +  arbitrary = Lits <$> listOf 32 arbitrary
++
 +newtype I = I Integer
 +  deriving (Eq, Show)
++
 +instance Arbitrary I where
 +  arbitrary = I <$> genInteger
++
 +--------------------------------------------------------------------------------
 +-- Properties
++
 +-- | Reference implementation of the SLEB128 encoding.
 +slebRef :: Integer -> [Word8]
 +slebRef = go
 +  where
 +    go val =
 +      let byte = fromIntegral (val .&. 0x7f) :: Word8
 +          val' = val `shiftR` 7
 +          signBit = testBit byte 6
 +          done = (val' == 0 && not signBit) || (val' == -1 && signBit)
 +      in if done
 +          then [byte]
 +          else setBit byte 7 : go val'
++
 +prop_literalRoundTrip :: Lit -> PropertyCheck
 +prop_literalRoundTrip (Lit l) = Lit (roundTrip1 l) === Lit l
++
 +prop_literalBatchRoundTrip :: Lits -> PropertyCheck
 +prop_literalBatchRoundTrip (Lits ls) = Lits (map Lit (roundTrip [ l | Lit l <- ls ])) === Lits ls
++
 +prop_integerRoundTrip :: I -> PropertyCheck
 +prop_integerRoundTrip (I i) = roundTrip1 i === i
++
 +prop_integerEncoding :: I -> PropertyCheck
 +prop_integerEncoding (I i) = BS.unpack (encode i) === slebRef i
++
 +tests :: Test
 +tests = Group "Binary"
 +  [ Group "Literal"
 +      [ Property "round trip" prop_literalRoundTrip
 +      , Property "batch round trip" prop_literalBatchRoundTrip
 +      ]
 +  , Group "Integer"
 +      [ Property "round trip" prop_integerRoundTrip
 +      , Property "SLEB128 encoding" prop_integerEncoding
 +      ]
 +  ]
++
 +main :: IO ()
 +main = runTestsMain (Iterations 1000) tests

testsuite/tests/utils/should_run/Binary_Literal.stdout

 +Group Binary
 +  Group Literal
 +    Running round trip
 +      Passed 1000 iterations
 +    Running batch round trip
 +      Passed 1000 iterations
 +  Group Integer
 +    Running round trip
 +      Passed 1000 iterations
 +    Running SLEB128 encoding
 +      Passed 1000 iterations

testsuite/tests/utils/should_run/all.T

  test('T15953', [ignore_stdout, js_skip], makefile_test, [])
++
 +# Property tests for the 'Binary Literal' instance, which also exercises
 +# GHCs 'Binary Integer' instance.
 +test('Binary_Literal', [mini_quickcheck], multimod_compile_and_run,
 +     ['Binary_Literal', '-package ghc'])

utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs

@@ -60,6 +60,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
  import qualified Data.Text as T
  import Haddock.Options (Visibility (..))
 +import qualified Data.Bits as Bits
  data InterfaceFile = InterfaceFile
    { ifLinkEnv :: LinkEnv
@@ -143,7 +144,7 @@ binaryInterfaceMagic = 0xD0Cface
  --
  binaryInterfaceVersion :: Word16
  #if MIN_VERSION_ghc(9,11,0) && !MIN_VERSION_ghc(10,2,0)
 -binaryInterfaceVersion = 47
 +binaryInterfaceVersion = 48
  binaryInterfaceVersionCompatibility :: [Word16]
  binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -274,7 +275,7 @@ putName
      do
        (symtab_map, symtab_tbl) <- readIORef symtab_map_ref
        case lookupNameEnv symtab_map name of
 -        Just off -> put_ bh (fromIntegral off :: Word32)
 +        Just off -> putNameIndex (fromIntegral off :: Word32)
          Nothing -> do
            off <- freshIndex
            let mod' = nameModule name
@@ -283,8 +284,10 @@ putName
            let !symtab_map' = extendNameEnv symtab_map name off
            let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms)
            writeIORef symtab_map_ref $! (symtab_map', symtab_tbl')
 -          put_ bh (fromIntegral off :: Word32)
 +          putNameIndex (fromIntegral off)
    where
 +    putNameIndex :: Word32 -> IO ()
 +    putNameIndex off = put_ bh (off `Bits.shiftL` 1)
      freshIndex :: IO Int
      freshIndex = do
        off <- readFastMutInt symtab_next