[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 15 Sep '26
by Andreas Klebinger (＠AndreasK) 15 Sep '26
15 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
d1eab429 by Andreas Klebinger at 2026-09-15T06:23:34+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
=====================================
@@ -0,0 +1,8 @@
+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
14 -> 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
0 -> 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(..) )
@@ -181,6 +180,8 @@ import Type.Reflection.Unsafe
import qualified Type.Reflection as Refl
import GHC.Real ( Ratio(..) )
import GHC.Float
+import GHC.Num.Integer ( Integer(IS) )
+
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import GHC.ByteOrder
@@ -805,6 +806,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 +1125,91 @@ instance Binary IsBootInterface where
False -> NotBoot
{-
-Finally - a reasonable portable Integer instance.
-
-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 made some sense as it's highly portable but also not very
-efficient.
-
-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.
+Note [Integer serialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We simply encode Integer as SLEB128 unconditionally.
-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.
+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.
-We can easily do better. The new plan is:
+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#.
-* 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.
+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.
-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
=====================================
@@ -0,0 +1,280 @@
+{-# 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
=====================================
@@ -0,0 +1,11 @@
+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
=====================================
@@ -1 +1,6 @@
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1eab429f379e70d1d4115823305c3c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1eab429f379e70d1d4115823305c3c…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/9.14.2-rc2] 8 commits: Strip ticks when desugaring bool guards
by Zubin (＠wz1000) 15 Sep '26
by Zubin (＠wz1000) 15 Sep '26
15 Sep '26
Zubin pushed to branch wip/9.14.2-rc2 at Glasgow Haskell Compiler / GHC
Commits:
5d61a09a by Brian McKenna at 2026-09-15T11:40:21+05:30
Strip ticks when desugaring bool guards
The special `considerAccessible` pattern was broken when compiling
with debug info. Compiling with debug info wraps expressions with
`SourceNote` ticks, which broke the internals of the
`desugarBoolGuard` function. Ticks are now ignored within this
function.
Fixes #27360
(cherry picked from commit d43a7b7ad90047f1445c88d796ee7b15a0a605d7)
- - - - -
9b378798 by Brian McKenna at 2026-09-15T11:40:43+05:30
Ignore ticks in the pattern-match term oracle
The term-oracle in the pattern-match checker is keyed by a canonical
form of the scrutinee, computed by `makeDictsCoherent`. That canonical
form was tick-sensitive: two occurrences of an otherwise identical
expression that happened to carry different ticks were treated as
distinct values, breaking long-distance information.
This shows up in practice under `-finfo-table-map`, because the
desugarer wraps every record-selector use site in a `SourceNote`
carrying that site's span. For example:
data Box = Box { unBox :: Maybe Int }
f b = case unBox b of
Nothing -> 0
Just _ -> let Just x = unBox b in x
The two `unBox b` expressionss carry different SourceNote spans, the
pattern-match checker sees them as different, the long-distance
information from the outer `Just _` branch never reaches the
let-pattern, and `Just x = unBox b` is wrongly reported as
non-exhaustive.
We now strip all ticks in `makeDictsCoherent`. This is documented as
Wrinkle (UD1) of Note [Unique dictionaries in the TmOracle CoreMap].
Fixes #27314
(cherry picked from commit b388d0934c0933c1cdb47226489634e229239d0a)
- - - - -
dc9736e2 by Duncan Coutts at 2026-09-15T11:40:43+05:30
Fix failing test GcStaticPointers for non-moving GC
Minor mistake in asserting something before checking for that same
thing.
Specifically, Bdescr asserts HEAP_ALLOCED_GC, but Bdescr was being used
prior to a guard that checks HEAP_ALLOCED_GC. The solution is just to
move the use of Bdescr after the guard.
Thanks to Simon Jakobi for identifying the problem.
(cherry picked from commit 42918646169c7c5ba61912b39b5f5147bf1d255c)
- - - - -
26b4579d by Luite Stegeman at 2026-09-15T11:40:43+05:30
rts: fix ctoi_tuple_spill_words getting out of sync
Fix a few places that were not updating ctoi_tuple_spill_words
correctly, leading to corruption/crashes when dealing with large
unboxed tuples in bytecode:
- captureContinuationAndAbort
- findRetryFrameHelper/findAtomicallyFrameHelper
- interpretBCO bci_BRK_FUN
fixes #27633
(cherry picked from commit 192be0b6b861725613a9be5cb1587fb8cdf68bd3)
- - - - -
d83131b0 by Luite Stegeman at 2026-09-15T11:41:19+05:30
rts: Fix missing memory barrier in eval_thunk_selector (#27477)
unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the
indirectee, leading to segfaults and corruption during GC on
weakly-ordered architectures.
Fixes #27477
(cherry picked from commit 06eee015be4e361fe9cb33e8a608ab2ea1386b52)
- - - - -
230be88b by Zubin Duggal at 2026-09-15T11:49:08+05:30
ci: bootstrap with GHC 9.10.3 and 9.12.4
- - - - -
b959b17f by Zubin Duggal at 2026-09-15T11:49:11+05:30
Prepare 9.14.2-rc2
-------------------------
Metric Decrease:
T4029
-------------------------
- - - - -
37caf921 by Zubin Duggal at 2026-09-15T11:49:11+05:30
fixup! Prepare 9.14.2-rc2
- - - - -
46 changed files:
- .gitlab-ci.yml
- − changelog.d/27626
- − changelog.d/27627
- − changelog.d/27703
- − changelog.d/27704
- − changelog.d/27717
- − changelog.d/T26423
- − changelog.d/T26716
- − changelog.d/T27202
- − changelog.d/T27308
- − changelog.d/T27440
- − changelog.d/T27455
- − changelog.d/T27583
- − changelog.d/T27586
- − changelog.d/T27639
- − changelog.d/T27657
- − changelog.d/T27705
- − changelog.d/arm_ncg_fixes_T27430
- − changelog.d/llvm-23
- − changelog.d/unit-index
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- docs/users_guide/9.14.2-notes.rst
- libraries/base/changelog.md
- rts/Continuation.c
- rts/Interpreter.c
- rts/Schedule.c
- rts/sm/Evac.c
- rts/sm/NonMovingMark.c
- + testsuite/tests/bytecode/T27633/Obj.hs
- + testsuite/tests/bytecode/T27633/T27633a.hs
- + testsuite/tests/bytecode/T27633/T27633a.stdout
- + testsuite/tests/bytecode/T27633/T27633b.hs
- + testsuite/tests/bytecode/T27633/T27633b.stdout
- + testsuite/tests/bytecode/T27633/all.T
- + testsuite/tests/ghci.debugger/scripts/T27633c.hs
- + testsuite/tests/ghci.debugger/scripts/T27633c.script
- + testsuite/tests/ghci.debugger/scripts/T27633c.stdout
- + testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs
- testsuite/tests/ghci.debugger/scripts/all.T
- + testsuite/tests/pmcheck/should_compile/T27314.hs
- + testsuite/tests/pmcheck/should_compile/T27360.hs
- testsuite/tests/pmcheck/should_compile/all.T
- + testsuite/tests/rts/T27477.hs
- + testsuite/tests/rts/T27477.stdout
- testsuite/tests/rts/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a0257f81be0b8336d8c40225b49a6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a0257f81be0b8336d8c40225b49a6…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 15 Sep '26
by Andreas Klebinger (＠AndreasK) 15 Sep '26
15 Sep '26
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
=====================================
@@ -0,0 +1,8 @@
+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
14 -> 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
0 -> 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
=====================================
@@ -0,0 +1,280 @@
+{-# 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
=====================================
@@ -0,0 +1,11 @@
+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
=====================================
@@ -1 +1,6 @@
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7731667bbbac2203710218c74c25de0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7731667bbbac2203710218c74c25de0…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/dcoutts/io-manager-selectbis] 7 commits: Refactor (and rename) removeFromQueues, to simplify I/O managers
by Duncan Coutts (＠dcoutts) 15 Sep '26
by Duncan Coutts (＠dcoutts) 15 Sep '26
15 Sep '26
Duncan Coutts pushed to branch wip/dcoutts/io-manager-selectbis at Glasgow Haskell Compiler / GHC
Commits:
067b3379 by Duncan Coutts at 2026-09-14T22:30:51+01:00
Refactor (and rename) removeFromQueues, to simplify I/O managers
Rename it to unblockAndAppendToRunQueue which better reflects what it is
intended to do.
The post-condition for unblockAndAppendToRunQueue is that the TSO is on
the run queue or it is in the process of migrating to another cap.
Previously it achieved that by always directly adding the TSO to the run
queue itself.
But this actually made things more complicated for the I/O managers,
because it meant they needed a separate code path for notifying for
cancellation compared to notifying for completion. The general
notification code would always add the TSO to the run queue itself.
So the improvement is to allow different cases in
unblockAndAppendToRunQueue to achieve the same outcome in different
ways: either directly adding to the run queue or calling helper
functions that do so themselves.
This then allows the new I/O managers to share code between the sync and
async cancellation, and to reuse their notifyIOCompletion helpers for
cancellation. This avoids a source of bugs where the completion path may
be updated but the cancellation path may be forgotten, or similarly in
future for sync/async operations.
Update all the existing in-RTS I/O managers, and the posix timeout code.
- - - - -
a5c3c2d2 by Duncan Coutts at 2026-09-14T22:52:02+01:00
Document that awaitCompletedTimeoutsOrIO expects an empty run queue
This was true before but implicit and not relied on much. It's better to
be explicit, and allow things to depend on it.
- - - - -
9f90058c by Duncan Coutts at 2026-09-14T22:52:58+01:00
Store the I/O opcode and fd in the StgAsyncIOOp
This will be useful in several I/O managers and it is handy for logging
and debugging.
It also doesn't increase the size of the StgAsyncIOOp structure. There
was enough spare padding space already.
Update the poll I/O manager to set the new fields.
Add a helper function to convert the enum IOReadOrWrite into the enum
IOOpCode. Also change IOReadOrWrite to be an enum without a typedef, for
consistency with other enumerations in IOManager.h
- - - - -
9e823372 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Add a new I/O manager based on select()
Yes, this is the second such I/O manager, but it is a modern
re-implementation based on the new in-RTS I/O manager infrastructure. So
it is cleaner and faster than the old select I/O manager.
Why do we need another I/O manager based on select? Why isn't the poll()
one good enough as a baseline portable unix I/O manager? Because macOS.
Apple Inc. is why we cannot have nice things.
The man page for poll on macOS documents the fact that it does not work.
At least, it does not work for all files. Specifically, it does not work
for device files. Whereas macOS select() does work for device files.
Aaaaarg!
We _do_ want to deprecate and remove the old select I/O manager, but due to
macOS we cannot do that until we have a replacement. This is that
replacement. Until of course a nice new k-queue I/O manager arrives,
which could become the new default for macOS and FreeBSD.
Interestingly, this select I/O manager is actually faster than the poll
one, on Linix, in some circumstances: specifically when many Haskell
threads are waiting on the same fd. The poll I/O manager does O(n) work
for n threads waiting on I/O, whereas the select one does O(fds) work
for the number of fds that threads are waiting on. Usually this is 1:1,
so it's not noticable, but one can concoct extreme benchmarks to show
the difference.
- - - - -
ec1c4b93 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Minor updates in the poll I/O manager to keep in sync with select
This keeps it in sync with select one. The changes are based on code review
while implementing the new select I/O manager. The two I/O managers are so
similar in structure that it makes sense to try to minimise the diff between
them. This should aid understanding, and fixes to both in future.
- - - - -
ffb39393 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Document the new select I/O manager in the user guide
in the RTS section about I/O managers.
And add a changelog entry.
- - - - -
2c4ecfe6 by Duncan Coutts at 2026-09-14T22:54:11+01:00
Use selectbis I/O manager by default for CI coverage
This should not be committed to master.
It would be nice however to get better CI coverage of non-default I/O
managers.
- - - - -
20 changed files:
- + changelog.d/select-io-manager
- docs/users_guide/runtime_control.rst
- libraries/base/src/GHC/RTS/Flags.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- rts/RaiseAsync.c
- rts/configure.ac
- rts/include/rts/Flags.h
- rts/include/rts/storage/Closures.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- + rts/posix/SelectBis.c
- + rts/posix/SelectBis.h
- rts/posix/Timeout.c
- rts/posix/Timeout.h
- rts/rts.cabal
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
Changes:
=====================================
changelog.d/select-io-manager
=====================================
@@ -0,0 +1,19 @@
+section: rts
+issues: #27519
+mrs: !16359
+synopsis:
+ New I/O manager based on select()
+description:
+ There is a new I/O manager on Posix systems based on select(). This exists
+ primarily to support macOS, where the poll() API does not work correctly
+ (specifically it is documented not to work for device files). It is the new
+ default I/O manager for the non-threaded RTS for the macOS platform.
+
+ This is intended to allow the legacy select I/O manager to be retired. It is
+ also a stop-gap measure until a kqueue I/O manager is added.
+
+ The new implementation is marginally faster in some cases. It scales better
+ for timers, O(log n) rather than O(m). For threads waiting on I/O it is
+ necessarily still O(n). If used to wait on fds > 1024 it will throw an IO
+ exception rather than terminating the RTS, as was the behaviour of the old
+ select I/O manager.
=====================================
docs/users_guide/runtime_control.rst
=====================================
@@ -1441,15 +1441,30 @@ limited.
Currently the available I/O managers are:
================ ========= ============
- Name Platforms RTS way
+I/O manager name Platforms RTS way
================ ========= ============
``select`` Posix Non-threaded
-``poll`` Posix Non-threaded
+``selectbis`` Posix Non-threaded
+``poll`` Posix(*) Non-threaded
``mio`` All Threaded
``win32-legacy`` Windows Non-threaded
``winio`` Windows Both
================ ========= ============
+(*) The ``poll`` I/O manager is not available on macOS due to platform
+limitations.
+
+Currently the default I/O manager on each platform is:
+
+========= ============ ===================
+Platform RTS way default I/O manager
+========= ============ ===================
+macOS Non-threaded ``selectbis``
+Posix Non-threaded ``poll``
+Windows Non-threaded ``win32-legacy``
+all Threaded ``mio``
+========= ============ ===================
+
.. rts-flag:: --io-manager=(name)
Select the I/O manager to use. On some combinations of platform and
@@ -1474,7 +1489,8 @@ This is because it uses a linked list for timers.
This I/O manager is highly portable and its code is very mature: it is the I/O
manager that has been used by GHC in the single-threaded RTS on Posix platforms
-since time immemorial.
+since time immemorial. It is likely to be retired, once the ``poll`` and
+``selectbis`` I/O managers are mature enough to cover all use cases.
Timer resolution: on 64bit platforms it supports microsecond precision timers
while on 32bit platforms it only supports millisecond precision. Timer accuracy
@@ -1485,6 +1501,29 @@ support 1024 open files. More specifically it supports file descriptors with
numerical value up to 1024 but no higher. It will terminate the RTS (and thus
typically the process) if this limit is exceeded.
+The ``selectbis`` I/O manager
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This I/O manager based on the classic Posix ``select()`` API. It supports
+waiting on I/O readiness on non-blocking file descriptors (i.e. not disk files).
+It is implemented within the RTS and is currently available only in the
+non-threaded RTS.
+
+It scales poorly for I/O readiness notification: costing O(n) in the number of
+threads that are waiting on I/O simultaneously. It scales well for timers:
+most timer operations cost O(log n) in the number of simultaneous timers. This
+is because it uses a heap data structure for timers.
+
+Timer resolution: this I/O manager supports microsecond precision timers.
+
+Limitation: on most platforms where it is available this I/O manager can only
+support 1024 open files. More specifically it supports file descriptors with
+numerical value up to 1024 but no higher. It will throw an IO exception if this
+limit is exceeded.
+
+This I/O manager exists primarily to support macOS, due to ``poll()`` not
+working properly on macOS, while ``select()`` does work. It's name reflects
+the fact that it is the second I/O manager to be based on ``select()``.
+
The ``poll`` I/O manager
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1512,6 +1551,10 @@ limit can be adjusted using OS facilities (e.g. the ``ulimit`` command).
Exceeding this limit will cause the RTS (and thus typically the process) to
terminate.
+This I/O manager is not available on macOS due to the ``poll()`` API not
+working for all file types on macOS. Specifically the macOS man page for
+``poll`` documents that it does not work for device files.
+
The ``mio`` I/O manager
~~~~~~~~~~~~~~~~~~~~~~~
This I/O manager is based on several platform-specific APIs. It supports
=====================================
libraries/base/src/GHC/RTS/Flags.hs
=====================================
@@ -393,10 +393,11 @@ internal_to_base_MiscFlags i@Internal.MiscFlags{..} =
internal_to_base_ioManager Internal.IoManagerFlagAuto = IoManagerFlagAuto
internal_to_base_ioManager Internal.IoManagerFlagSelect = IoManagerFlagSelect
#if __GLASGOW_HASKELL__ >= 1000
+ internal_to_base_ioManager Internal.IoManagerFlagSelectBis = IoManagerFlagAuto
internal_to_base_ioManager Internal.IoManagerFlagPoll = IoManagerFlagAuto
- -- This is a lie, we cannot translate poll. We cannot translate
- -- accurately because want to freeze the API of the the compat RTS flags
- -- here. Using "auto" is the least bad translation.
+ -- This is a lie, we cannot translate these new I/O managers. We cannot
+ -- translate accurately because want to freeze the API of the the compat
+ -- RTS flags here. Using "auto" is the least bad translation.
-- https://github.com/haskell/core-libraries-committee/issues/362
#endif
internal_to_base_ioManager Internal.IoManagerFlagMIO = IoManagerFlagMIO
=====================================
libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
=====================================
@@ -182,6 +182,7 @@ data MiscFlags = MiscFlags
data IoManagerFlag =
IoManagerFlagAuto
| IoManagerFlagSelect -- ^ Unix only, non-threaded RTS only
+ | IoManagerFlagSelectBis -- ^ Unix only, non-threaded RTS only
| IoManagerFlagPoll -- ^ Unix only, non-threaded RTS only
| IoManagerFlagMIO -- ^ cross-platform, threaded RTS only
| IoManagerFlagWinIO -- ^ Windows only
=====================================
rts/IOManager.c
=====================================
@@ -33,6 +33,11 @@
#include "posix/Signals.h"
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+#include "posix/SelectBis.h"
+#include "posix/Timeout.h"
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
#include "posix/Poll.h"
#include "posix/Timeout.h"
@@ -117,6 +122,14 @@ parseIOManagerFlag(const char *iomgrstr, IO_MANAGER_FLAG *flag)
return IOManagerAvailable;
#else
return IOManagerUnavailable;
+#endif
+ }
+ else if (strcmp("selectbis", iomgrstr) == 0) {
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ *flag = IO_MNGR_FLAG_SELECTBIS;
+ return IOManagerAvailable;
+#else
+ return IOManagerUnavailable;
#endif
}
else if (strcmp("poll", iomgrstr) == 0) {
@@ -226,6 +239,8 @@ void selectIOManager(void)
#else // !defined(THREADED_RTS)
#if defined(IOMGR_DEFAULT_NON_THREADED_SELECT)
iomgr_type = IO_MANAGER_SELECT;
+#elif defined(IOMGR_DEFAULT_NON_THREADED_SELECTBIS)
+ iomgr_type = IO_MANAGER_SELECTBIS;
#elif defined(IOMGR_DEFAULT_NON_THREADED_POLL)
iomgr_type = IO_MANAGER_POLL;
#elif defined(IOMGR_DEFAULT_NON_THREADED_WINIO)
@@ -244,6 +259,12 @@ void selectIOManager(void)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MNGR_FLAG_SELECTBIS:
+ iomgr_type = IO_MANAGER_SELECTBIS;
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MNGR_FLAG_POLL:
iomgr_type = IO_MANAGER_POLL;
@@ -291,6 +312,10 @@ char * showIOManager(void)
case IO_MANAGER_SELECT:
return "select";
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return "selectbis";
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return "poll";
@@ -347,6 +372,12 @@ void initCapabilityIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ initCapabilityIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
initCapabilityIOManagerPoll(iomgr);
@@ -380,6 +411,12 @@ void freeCapabilityIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ freeCapabilityIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
freeCapabilityIOManagerPoll(iomgr);
@@ -464,6 +501,7 @@ restartIOManager(CapIOManager *iomgr, Capability **pcap)
break;
#endif
/* The IO_MANAGER_SELECT needs no initialisation */
+ /* The IO_MANAGER_SELECTBIS needs no initialisation */
/* The IO_MANAGER_POLL needs no initialisation */
/* No impl for any of the Windows I/O managers, since no forking. */
@@ -555,8 +593,14 @@ void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
markClosureTable(evac, user, &iomgr->aiop_table);
evac(user, (StgClosure **)(void *)&iomgr->timeout_queue);
break;
@@ -600,6 +644,11 @@ bool anyPendingTimeoutsOrIO(CapIOManager *iomgr)
|| (iomgr->sleeping_queue != END_TSO_QUEUE);
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return anyPendingTimeoutsOrIOSelectBis(iomgr);
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return anyPendingTimeoutsOrIOPoll(iomgr);
@@ -659,6 +708,12 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ pollCompletedTimeoutsOrIOSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
pollCompletedTimeoutsOrIOPoll(iomgr);
@@ -685,6 +740,7 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr)
bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
{
debugTrace(DEBUG_iomanager, "waiting for completed IO or timeouts");
+ ASSERT(emptyRunQueue(iomgr->cap));
bool completed = true; // wait completed or interrupted?
switch (iomgr_type) {
#if defined(IOMGR_ENABLED_SELECT)
@@ -693,6 +749,12 @@ bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ completed = awaitCompletedTimeoutsOrIOSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
completed = awaitCompletedTimeoutsOrIOPoll(iomgr);
@@ -734,6 +796,12 @@ void interruptIOManager(CapIOManager *iomgr)
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ interruptIOManagerSelectBis(iomgr);
+ break;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
interruptIOManagerPoll(iomgr);
@@ -761,10 +829,10 @@ void interruptIOManager(CapIOManager *iomgr)
/* CMM primop. Result is true on success, or false on allocation failure. */
-IOSubmitResult syncIOWaitReady(CapIOManager *iomgr,
- StgTSO *tso,
- IOReadOrWrite rw,
- HsInt fd)
+IOSubmitResult syncIOWaitReady(CapIOManager *iomgr,
+ StgTSO *tso,
+ enum IOReadOrWrite rw,
+ HsInt fd)
{
debugTrace(DEBUG_iomanager,
"thread %ld waiting for %s I/O readiness on fd %d",
@@ -783,6 +851,10 @@ IOSubmitResult syncIOWaitReady(CapIOManager *iomgr,
return IOSubmitResultAsyncContinue;
}
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ return syncIOWaitReadySelectBis(iomgr, tso, rw, fd);
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
return syncIOWaitReadyPoll(iomgr, tso, rw, fd);
@@ -803,6 +875,13 @@ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso)
&iomgr->blocked_queue_hd,
&iomgr->blocked_queue_tl,
tso);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
+ break;
+#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+ syncIOCancelSelectBis(iomgr, tso);
break;
#endif
#if defined(IOMGR_ENABLED_POLL)
@@ -817,11 +896,14 @@ void syncIOCancel(CapIOManager *iomgr, StgTSO *tso)
&iomgr->blocked_queue_tl,
tso);
abandonWorkRequest(tso->block_info.async_reqID);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
break;
#endif
default:
barf("syncIOCancel not supported for I/O manager %d", iomgr_type);
}
+ ASSERT(tso->why_blocked == NotBlocked);
}
@@ -848,8 +930,14 @@ bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay)
return true;
}
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
return syncDelayTimeout(iomgr, tso, us_delay);
#endif
#if defined(IOMGR_ENABLED_WIN32_LEGACY)
@@ -883,10 +971,18 @@ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso)
case IO_MANAGER_SELECT:
ASSERT(tso->why_blocked == (BlockedOnDelay | BlockInfoForceNonClosure));
removeThreadFromQueue(iomgr->cap, &iomgr->sleeping_queue, tso);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
break;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ case IO_MANAGER_SELECTBIS:
+#endif
#if defined(IOMGR_ENABLED_POLL)
case IO_MANAGER_POLL:
+#endif
syncDelayCancelTimeout(iomgr, tso);
break;
#endif
@@ -900,6 +996,7 @@ void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso)
default:
barf("syncDelayCancel not supported for I/O manager %d", iomgr_type);
}
+ ASSERT(tso->why_blocked == NotBlocked);
}
=====================================
rts/IOManager.h
=====================================
@@ -53,6 +53,9 @@ extern bool rts_IOManagerIsWin32Native;
#if defined(IOMGR_BUILD_SELECT) && !defined(THREADED_RTS)
#define IOMGR_ENABLED_SELECT
#endif
+#if defined(IOMGR_BUILD_SELECTBIS) && !defined(THREADED_RTS)
+ #define IOMGR_ENABLED_SELECTBIS
+#endif
#if defined(IOMGR_BUILD_POLL) && !defined(THREADED_RTS)
#define IOMGR_ENABLED_POLL
#endif
@@ -95,6 +98,8 @@ extern bool rts_IOManagerIsWin32Native;
#else // !defined(THREADED_RTS)
#if defined(IOMGR_DEFAULT_NON_THREADED_SELECT)
#define IOMGR_DEFAULT_STR "select"
+#elif defined(IOMGR_DEFAULT_NON_THREADED_SELECTBIS)
+ #define IOMGR_DEFAULT_STR "selectbis"
#elif defined(IOMGR_DEFAULT_NON_THREADED_POLL)
#define IOMGR_DEFAULT_STR "poll"
#elif defined(IOMGR_DEFAULT_NON_THREADED_WINIO)
@@ -115,6 +120,11 @@ extern bool rts_IOManagerIsWin32Native;
#else
#define IOMGR_ENABLED_STR_SELECT ""
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ #define IOMGR_ENABLED_STR_SELECTBIS " selectbis"
+#else
+ #define IOMGR_ENABLED_STR_SELECTBIS ""
+#endif
#if defined(IOMGR_ENABLED_POLL)
#define IOMGR_ENABLED_STR_POLL " poll"
#else
@@ -137,6 +147,7 @@ extern bool rts_IOManagerIsWin32Native;
#endif
#define IOMGRS_ENABLED_STR \
IOMGR_ENABLED_STR_SELECT \
+ IOMGR_ENABLED_STR_SELECTBIS \
IOMGR_ENABLED_STR_POLL \
IOMGR_ENABLED_STR_MIO \
IOMGR_ENABLED_STR_WINIO \
@@ -150,6 +161,9 @@ typedef enum {
#if defined(IOMGR_ENABLED_SELECT)
IO_MANAGER_SELECT,
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ IO_MANAGER_SELECTBIS,
+#endif
#if defined(IOMGR_ENABLED_POLL)
IO_MANAGER_POLL,
#endif
@@ -212,7 +226,19 @@ char * showIOManager(void);
*/
bool is_io_mng_native_p (void);
+/* Values for StgAsyncIOOp.operation.
+ *
+ * Note: this is encoded in 6 bits in StgAsyncIOOp.
+ */
+enum IOOpCode {
+ IOOpCodeWaitRead = 0,
+ IOOpCodeWaitWrite = 1
+ /* This will be extended, e.g. for Read/Write */
+};
+
/* Values for StgAsyncIOOp.outcome.
+ *
+ * Note: this is encoded in 2 bits in StgAsyncIOOp.
*/
enum IOOpOutcome {
IOOpOutcomeInFlight = 0,
@@ -314,7 +340,17 @@ void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr);
/* Several code paths are almost identical between read and write paths. In
* such cases we use a shared code path with an enum to say which we're doing.
*/
-typedef enum { IORead = 0, IOWrite = 1 } IOReadOrWrite;
+enum IOReadOrWrite { IORead = 0, IOWrite = 1 };
+
+INLINE_HEADER enum IOOpCode convIOReadOrWriteToIOOpCode (enum IOReadOrWrite rw)
+{
+ // The codes are compatible:
+ ASSERT((int) IOOpCodeWaitRead == (int) IORead &&
+ (int) IOOpCodeWaitWrite == (int) IOWrite);
+
+ return (enum IOOpCode) rw;
+}
+
/* Synchronous operations: I/O and delays. As synchronous operations they
* necessarily operate on threads. The thread is suspended until the operation
@@ -351,13 +387,16 @@ enum IOSubmitResultCodes {
};
/* Called from CMM primop */
-IOSubmitResult syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd);
+IOSubmitResult syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso,
+ enum IOReadOrWrite rw, HsInt fd);
+/* Cancel the I/O the TSO is blocked on and add the TSO to the run queue */
void syncIOCancel(CapIOManager *iomgr, StgTSO *tso);
/* Called from CMM primop */
bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay);
+/* Cancel the timeout the TSO is blocked on and add the TSO to the run queue */
void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso);
#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_WIN32_LEGACY)
@@ -390,6 +429,11 @@ void pollCompletedTimeoutsOrIO(CapIOManager *iomgr);
* does complete (or we get a signal with a handler) and process the
* completions as appropriate.
*
+ * This should _only_ be called when there are no runnable threads and it is
+ * thus accepable to block and wait for I/O or timeouts. Notably this means it
+ * must _not_ be used in the threaded RTS (where it is unacceptable to block
+ * a capability).
+ *
* Upon returning true this guarantees that the scheduler run queue is
* non-empty or that the scheduler is no longer in the running state.
* Succinctly, the post-condition in the return true case is
=====================================
rts/IOManagerInternals.h
=====================================
@@ -14,12 +14,20 @@
#include "IOManager.h"
-#if defined(IOMGR_ENABLED_POLL)
-#include <poll.h> /* for struct pollfd */
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
#include "ClosureTable.h"
#include "TimeoutQueue.h"
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+#include <sys/select.h> /* for fd_set */
+#endif
+
+#if defined(IOMGR_ENABLED_POLL)
+#include <poll.h> /* for struct pollfd */
+#endif
+
#include "BeginPrivate.h"
/* The per-capability data structures belonging to the I/O manager.
@@ -46,19 +54,26 @@ struct _CapIOManager {
StgTSO *sleeping_queue;
#endif
-#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECT) \
+ || defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
#if defined(HAVE_PREEMPTION)
/* FDs for waking up the I/O manager when it is blocked waiting */
int interrupt_fd_r, interrupt_fd_w;
#endif
#endif
-#if defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_POLL) \
+ || defined(IOMGR_ENABLED_SELECTBIS)
/* AIOP and timeout collections shared by several I/O manager impls */
ClosureTable aiop_table;
StgTimeoutQueue *timeout_queue;
#endif
+#if defined(IOMGR_ENABLED_SELECTBIS)
+ fd_set *rfds, *wfds;
+#endif
+
#if defined(IOMGR_ENABLED_POLL)
/* Auxiliary table with size and indexes matching the aiop_table. This is
* aliased to the tail of the full poll table, which has a head entry for
=====================================
rts/RaiseAsync.c
=====================================
@@ -28,7 +28,7 @@
static void blockedThrowTo (Capability *cap,
StgTSO *target, MessageThrowTo *msg);
-static void removeFromQueues(Capability *cap, StgTSO *tso);
+static void unblockAndAppendToRunQueue(Capability *cap, StgTSO *tso);
static void removeFromMVarBlockedQueue (StgTSO *tso);
@@ -62,8 +62,10 @@ throwToSingleThreaded__ (Capability *cap, StgTSO *tso, StgClosure *exception,
return;
}
- // Remove it from any blocking queues
- removeFromQueues(cap,tso);
+ // Remove it from any blocking queues and add it to the run queue
+ unblockAndAppendToRunQueue(cap,tso);
+ ASSERT(tso->why_blocked == NotBlocked ||
+ tso->why_blocked == ThreadMigrating);
raiseAsync(cap, tso, exception, stop_at_atomically, stop_here);
}
@@ -471,7 +473,7 @@ check_target:
blockedThrowTo(cap,target,msg);
return THROWTO_BLOCKED;
} else {
- removeFromQueues(cap,target);
+ unblockAndAppendToRunQueue(cap,target);
raiseAsync(cap, target, msg->exception, false, NULL);
return THROWTO_SUCCESS;
}
@@ -612,16 +614,7 @@ awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso)
tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE;
}
-/* -----------------------------------------------------------------------------
- Remove a thread from blocking queues.
-
- This is for use when we raise an exception in another thread, which
- may be blocked.
-
- Precondition: we have exclusive access to the TSO, via the same set
- of conditions as throwToSingleThreaded() (c.f.).
- -------------------------------------------------------------------------- */
-
+// Helper for unblockAndAppendToRunQueue
static void
removeFromMVarBlockedQueue (StgTSO *tso)
{
@@ -664,13 +657,24 @@ removeFromMVarBlockedQueue (StgTSO *tso)
tso->_link = END_TSO_QUEUE;
}
+/* -----------------------------------------------------------------------------
+ Remove a thread from blocking queues (if any) and add it to the run queue
+ (if it wasn't on the run queue already).
+
+ This is for use when we raise an exception in another thread, which
+ may be blocked.
+
+ Precondition: we have exclusive access to the TSO, via the same set
+ of conditions as throwToSingleThreaded() (c.f.).
+ -------------------------------------------------------------------------- */
+
static void
-removeFromQueues(Capability *cap, StgTSO *tso)
+unblockAndAppendToRunQueue(Capability *cap, StgTSO *tso)
{
switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) {
- case NotBlocked:
- case ThreadMigrating:
+ case NotBlocked: // Already on the run queue
+ case ThreadMigrating: // Not added to the run queue
return;
case BlockedOnSTM:
@@ -680,16 +684,16 @@ removeFromQueues(Capability *cap, StgTSO *tso)
// perhaps have a debugging test to make sure that this really
// happens and that the 'zombie' transaction does not get
// committed.
- goto done;
+ break;
case BlockedOnMVar:
case BlockedOnMVarRead:
removeFromMVarBlockedQueue(tso);
- goto done;
+ break;
case BlockedOnBlackHole:
// nothing to do
- goto done;
+ break;
case BlockedOnMsgThrowTo:
{
@@ -709,18 +713,19 @@ removeFromQueues(Capability *cap, StgTSO *tso)
case BlockedOnDoProc:
// These blocking reasons are only used by some I/O managers
syncIOCancel(cap->iomgr, tso);
- goto done;
+ return;
case BlockedOnDelay:
// This blocking reasons is only used by some I/O managers
syncDelayCancel(cap->iomgr, tso);
- goto done;
+ return;
default:
- barf("removeFromQueues: %d", tso->why_blocked);
+ barf("unblockAndAppendToRunQueue: %d", tso->why_blocked);
}
- done:
+ // The cases above that use return add the TSO to the run queue themselves
+ // (or don't need to). For the rest (that use break) we do it here.
appendToRunQueue(cap, tso);
RELEASE_STORE(&tso->why_blocked, NotBlocked);
}
=====================================
rts/configure.ac
=====================================
@@ -368,6 +368,15 @@ GHC_IOMANAGER_ENABLE([select], [EnableIOManagerSelect], [IOMGR_BUILD_SELECT],
[AC_MSG_ERROR([sys/select.h required by select I/O manager])],[])
fi])
+GHC_IOMANAGER_ENABLE([selectbis], [EnableIOManagerSelectBis], [IOMGR_BUILD_SELECTBIS],
+ [if test "$HostOS" = "mingw32"; then
+ EnableIOManagerSelectBis=NO
+ else
+ AC_CHECK_HEADER([sys/select.h],
+ [EnableIOManagerSelectBis=YES],
+ [AC_MSG_ERROR([sys/select.h required by selectbis I/O manager])],[])
+ fi])
+
GHC_IOMANAGER_ENABLE([poll], [EnableIOManagerPoll], [IOMGR_BUILD_POLL],
[if test "$HostOS" = "mingw32"; then
EnableIOManagerPoll=NO
@@ -407,6 +416,7 @@ if test "$HostOS" = "mingw32"; then
else
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [select], [EnableIOManagerSelect])
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [poll], [EnableIOManagerPoll])
+ GHC_IOMANAGER_DEFAULT_SELECT([IOManagerNonThreadedDefault], [selectbis], [EnableIOManagerSelectBis])
GHC_IOMANAGER_DEFAULT_SELECT([IOManagerThreadedDefault], [mio], [EnableIOManagerMIO])
fi
GHC_IOMANAGER_DEFAULT_CHECK_NOT_EMPTY([IOManagerNonThreadedDefault],[non-threaded])
@@ -419,6 +429,9 @@ dnl Now define CPP vars for the default ones (threaded and non-threaded)
GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
[select], [IOMGR_DEFAULT_NON_THREADED_SELECT])
+GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
+ [selectbis], [IOMGR_DEFAULT_NON_THREADED_SELECTBIS])
+
GHC_IOMANAGER_DEFAULT_AC_DEFINE([IOManagerNonThreadedDefault], [non-threaded],
[poll], [IOMGR_DEFAULT_NON_THREADED_POLL])
=====================================
rts/include/rts/Flags.h
=====================================
@@ -258,6 +258,7 @@ typedef enum _IO_MANAGER_FLAG {
/* All other choices pick only the requested one, with no fallback. */
IO_MNGR_FLAG_SELECT, /* Unix only, non-threaded RTS only */
+ IO_MNGR_FLAG_SELECTBIS, /* Unix only, non-threaded RTS only */
IO_MNGR_FLAG_POLL, /* Unix only, non-threaded RTS only */
IO_MNGR_FLAG_MIO, /* cross-platform, threaded RTS only */
IO_MNGR_FLAG_WINIO, /* Windows only */
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -823,6 +823,8 @@ typedef struct {
// In the threaded way there is one I/O manager per capability. We have
// to handle cross-capability I/O op cancellation specially, so we need
// to know which capability an aiop is being managed on.
+ //
+ // We could probably afford to steal some bits here if needed.
uint16_t capno;
// This tells us which thing the notify union above contains. It is a
@@ -837,7 +839,30 @@ typedef struct {
// 3: IOOpOutcomeCancelled: cancelled, no further detail.
uint16_t outcome: 2;
- // 12 bits going spare!
+ // The I/O operation we are performing. It is a value from enum IOOpCode,
+ // but we don't use the enum type here due to portability concerns for
+ // this C bitfield.
+ //
+ // The size of this field, allows us up to 64 opcodes.
+ uint16_t operation: 6;
+
+ // 6 bits going spare!
+ uint16_t padding: 6;
+
+ // The file descriptor the operation is on. This is used in several I/O
+ // managers to group StgAsyncIOOps by fd. In particular this is needed
+ // for cancelling all wait-notification ops when closing an fd. It is
+ // also handy for logging and debugging.
+ //
+ // Note that it is technically possible to stuff Win32 HANDLEs into here,
+ // but no Win32 I/O manager does this _yet_. See:
+ // https://learn.microsoft.com/en-us/windows/win32/winprog64/interprocess-comm…
+ // > 64-bit versions of Windows use 32-bit handles for interoperability.
+ // > When sharing a handle between 32-bit and 64-bit applications, only
+ // > the lower 32 bits are significant, so it is safe to truncate the
+ // > handle (when passing it from 64-bit to 32-bit) or sign-extend the
+ // > handle (when passing it from 32-bit to 64-bit).
+ uint32_t fd;
union {
// For successful outcomes, this is the result code of the operation.
@@ -850,10 +875,6 @@ typedef struct {
uint32_t error;
};
- // Round it up to 2 words on 64bit platforms.
- // This is also space for future extension, without increasing the size.
- uint32_t padding;
-
// Note that because we use fixed size Ctypes here then the size in words
// of this heap object is different on 32bit and 64bit platforms.
// We handle this in the INFO_TABLE_CONSTR decl for stg_ASYNCIOOP using
=====================================
rts/posix/Poll.c
=====================================
@@ -132,7 +132,7 @@ the aiop_table, but still allows the full_poll_table to have an extra entry.
/* Forward declarations */
static bool enlargeTables(CapIOManager *iomgr);
static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop);
-static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+static void removeFromTables(CapIOManager *iomgr, int i);
static void reportPollError(int res, nfds_t nfds) STG_NORETURN;
@@ -172,7 +172,7 @@ void freeCapabilityIOManagerPoll(CapIOManager *iomgr)
/* Used to implement syncIOWaitReady. */
IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
- IOReadOrWrite rw, HsInt fd)
+ enum IOReadOrWrite rw, HsInt fd)
{
StgAsyncIOOp *aiop;
aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp));
@@ -188,7 +188,7 @@ IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
}
IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
- IOReadOrWrite rw, int fd)
+ enum IOReadOrWrite rw, int fd)
{
if (RTS_UNLIKELY(isFullClosureTable(&iomgr->aiop_table))) {
bool ok = enlargeTables(iomgr);
@@ -203,9 +203,11 @@ IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
/* The syncIO wrapper or CMM primop filled in the notify and live fields,
* we fill the rest.
*/
- aiop->capno = iomgr->cap->no;
- aiop->index = ix;
- aiop->outcome = IOOpOutcomeInFlight;
+ aiop->capno = iomgr->cap->no;
+ aiop->index = ix;
+ aiop->outcome = IOOpOutcomeInFlight;
+ aiop->operation = convIOReadOrWriteToIOOpCode(rw);
+ aiop->fd = fd;
/* Fill in the corresponding entry in the aiop_poll_table */
iomgr->aiop_poll_table[ix] = (struct pollfd) {
@@ -222,20 +224,7 @@ void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso)
StgAsyncIOOp *aiop = tso->block_info.aiop;
ASSERT(aiop->notify_type == NotifyTSO);
ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop);
- ioCancel(iomgr, aiop);
- setTsoIOOpOutcome(tso, aiop->outcome, aiop->result);
- /* We cannot use the normal notifyIOCompletion here. We are in the context
- * of throwTo, interrupting a thread blocked on IO via an async exception.
- * We don't put the TSO back on the run queue or change the why_blocked
- * status, as that is done by removeFromQueues (in the throwTo* functions).
- */
-
- /* We are in the TSO case, where the aiop was only reachable from the TSO
- * itself, and thus it is now no longer be reachable at all.
- */
- IF_NONMOVING_WRITE_BARRIER_ENABLED {
- updateRemembSetPushClosure(iomgr->cap, (StgClosure *)aiop);
- }
+ asyncIOCancelPoll(iomgr, aiop);
}
@@ -246,29 +235,14 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop)
* because each aiop is GC heap allocated, so cannot be recycled until it
* is no longer retained by the application.
*/
- ASSERT(aiop->notify_type != NotifyTSO);
if (indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop) {
- ioCancel(iomgr, aiop);
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
notifyIOCompletion(iomgr, aiop);
}
}
-static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop)
-{
- int ix = aiop->index;
- int ix_from; int ix_to;
- removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
- &ix_from, &ix_to);
- if (ix_to != ix_from) {
- StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
- aiop_to->index = ix_to;
- iomgr->aiop_poll_table[ix_to] = iomgr->aiop_poll_table[ix_from];
- }
- aiop->outcome = IOOpOutcomeCancelled;
-}
-
-
bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr)
{
return !isEmptyTimeoutQueue(iomgr->timeout_queue)
@@ -313,6 +287,15 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
}
+/* Called from poll/awaitCompletedTimeoutsOrIOPoll after a successful poll()
+ * call to process all the I/O completions.
+ *
+ * We match up the I/O completion notifications from the system call against
+ * the pending I/O operations from the aiop_table, and use notifyIOCompletion
+ * on each completed aiop.
+ *
+ * Returns true if the poll() was interupted via iomgr->interrupt_fd_r.
+ */
static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
{
/* The scheme we use with poll is that we have a dense poll table, and a
@@ -323,6 +306,7 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
*/
debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)",
ncompletions);
+ ASSERT(ncompletions > 0);
bool interrupt = false;
#if defined(HAVE_PREEMPTION)
@@ -337,9 +321,8 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
#endif
struct pollfd *aiop_poll_table = iomgr->aiop_poll_table;
- int n = ncompletions;
int i = 0;
- while (n > 0) {
+ while (ncompletions > 0) {
ASSERT(i < sizeClosureTable(&iomgr->aiop_table));
/* Since each aiop_table entry is for a single (fd, rw) pair, we
@@ -349,6 +332,8 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
if (aiop_poll_table[i].revents) {
StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, i);
+ ASSERT(aiop->outcome == IOOpOutcomeInFlight);
+
/* We do need to handle POLLNVAL, but we do not need to do anything
* special for POLLERR or POLLHUP. (See man poll for details).
* The calling thread will typically try to do I/O after waiting
@@ -364,26 +349,14 @@ static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
aiop->result = 0;
}
- /* Remove from the completion table, preserving compactness, and
- * apply the same compacting to the aiop_poll_table.
- */
- int ix_from; int ix_to;
- removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, i,
- &ix_from, &ix_to);
- if (ix_to != ix_from) {
- StgAsyncIOOp *aiop_to;
- aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
- aiop_to->index = ix_to;
- aiop_poll_table[ix_to] = aiop_poll_table[ix_from];
- }
-
+ removeFromTables(iomgr, i);
notifyIOCompletion(iomgr, aiop);
- n--;
+ ncompletions--;
} else {
- /* You'd expect incrementing the poll table index to be
- * unconditional, but we don't increment the index if we did
- * process the entry, because using removeCompactClosureTable
- * means we'll move an entry from the end into the same index.
+ /* You'd expect incrementing the table index to be unconditional,
+ * but we don't increment the index if we did process the entry,
+ * because using removeFromTables means we'll move an entry from
+ * the end of the table into the index i.
*/
i++;
}
@@ -564,6 +537,7 @@ bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr)
return !interrupt;
}
+
static void reportPollError(int res, nfds_t nfds)
{
if (errno == EINVAL) {
@@ -619,4 +593,20 @@ static bool enlargeTables(CapIOManager *iomgr)
return true;
}
+
+/* Remove from the completion table, preserving compactness, and apply the same
+ * compacting to the aiop_poll_table.
+ */
+static void removeFromTables(CapIOManager *iomgr, int ix)
+{
+ int ix_from; int ix_to;
+ removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
+ &ix_from, &ix_to);
+ if (ix_to != ix_from) {
+ StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
+ aiop_to->index = ix_to;
+ iomgr->aiop_poll_table[ix_to] = iomgr->aiop_poll_table[ix_from];
+ }
+}
+
#endif /* IOMGR_ENABLED_POLL */
=====================================
rts/posix/Poll.h
=====================================
@@ -21,12 +21,12 @@ void freeCapabilityIOManagerPoll(CapIOManager *iomgr);
/* Synchronous I/O and timer operations */
IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
- IOReadOrWrite rw, HsInt fd);
+ enum IOReadOrWrite rw, HsInt fd);
void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso);
/* Asynchronous operations */
IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
- IOReadOrWrite rw, int fd);
+ enum IOReadOrWrite rw, int fd);
void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop);
/* Scheduler operations */
=====================================
rts/posix/SelectBis.c
=====================================
@@ -0,0 +1,654 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020-2026
+ *
+ * A second I/O manager based on the classic Unix select() system call.
+ *
+ * See SelectBis.h for the sad story of why this exists.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "rts/PosixSource.h"
+#include "Rts.h"
+#include "RtsFlags.h" // needed by SET_HDR macro
+
+#include "IOManager.h" // defines IOMGR_ENABLED_SELECTBIS
+
+#if defined(IOMGR_ENABLED_SELECTBIS)
+
+#include "Capability.h"
+#include "Threads.h"
+#include "Schedule.h"
+#include "Prelude.h"
+#include "RtsUtils.h"
+#include "rts/Time.h"
+#include "Trace.h"
+
+#include "SelectBis.h"
+#include "RtsSignals.h"
+
+#include <errno.h>
+#include <sys/select.h>
+
+#include "IOManagerInternals.h"
+#include "Timeout.h"
+#include "FdWakeup.h"
+
+/******************************************************************************
+
+This I/O manager is based on the classic Unix select() system call.
+
+ int select(int nfds, fd_set *readfds, fd_set *writefds,
+ fd_set *exceptfds, struct timeval *timeout);
+
+The select() call has various limits, quirks and slight differences between
+historical Unix variants.
+
+The basic idea is to collect a set of fds (represented as a bitset) that we are
+interested in: one for reads, one for writes. The call then queries for I/O
+readiness on all the fds in the read and write sets. The result is a set of fds
+that are ready to read from, and a set that are ready to write to. The same
+bitset representation is used for the output. Indeed a "fun" quirk of select()
+is that it mutates the fd sets it is passed, which means they either need to be
+built up each time, or copied. There is also an optional timeout if no fds are
+ready immediately. There is also an fd bitset for "exceptional conditions"
+which we do not use.
+
+There is of course no incremental behaviour here; this is a bulk one-off call
+with no persistent state. This has obvious scaling problems. The cost each time
+is O(n) in the maximum of the integer value of the fds of interest. There is
+also a maximum bitset size. On Linux this is 1024. This means select() cannot
+be used if the process uses more than that many open files, even if we're only
+interested in a few. On OSX the default limit is also 1024 but this can be
+raised or even managed dynamically, at the cost of more memory (and some
+non-standard code).
+
+That particular problem is solved by the later Unix poll() system call, which
+uses an array of the fds we are interested in, which means it is not limited by
+the absolute value of the fds numbers (but it is still O(n) in how many fds we
+are interested in).
+
+We have some choice in how we process results. We want to find the intersection
+between the requests for notification of I/O readiness (coming from the Haskell
+threads) and the read and write bit sets. There's not much clever we can do to
+compute this intersection efficiently: we can either iterate over the bit sets
+or over the readiness requests. There is no obvious answer here. Typically
+there will be few results compared to the number of requests and a bitset scan
+could be fast. In practice we cannot portably scan the bitset efficiently (e.g.
+word at a time). Portably, we can only probe each bit at a time using FD_ISSET.
+Portability is the main reason to use select() rather than a more modern
+interface, so we have to take it seriously here. Furthermore, if we iterated
+over the bit sets we would have to maintain a mapping from fd to requests.
+
+In principle we also have the choice to maintain the read and write fd bit sets
+incrementally, or create them afresh each time we call select(). There is no
+asymptotic bonus to maintaining them incrementally since the whole thing is
+O(n) anyway. There could plausibly be some constant factor benefit. To maintain
+the fd bit sets incrementally we would need to maintain a mapping between
+requests and fds. This would also be an extra cost that would have to be
+outweighed by any saving.
+
+In the end we take the simple approach to constructing the bitset inputs and to
+results processing. We create the bit sets afresh each time from the collection
+of requests. For processing results we iterate over the requests and look up
+each one to see if it is in the appropriate result bitset. Along with each
+operation, we store the fd and whether we were interested in reading or writing.
+We iterate over the operations and use the fd and r/w information to construct
+the read and write bit sets.
+
+A particularly frustrating feature of select() is that if any single fd in any
+fd bitset is invalid (e.g. because the file was already closed) then select()
+fails and tells us there is a bad fd somewhere, but it has no way to indicate
+which fd was bad. This is really quite annoying as we then have to do a search
+through the fds to find which one was bad.
+
+The primary data structure for this I/O manager is a aiop_table which is a
+ClosureTable of AsyncIOOps. This table tracks the active I/O operations, with
+one entry per operation (corresponding to threads calling waitRead#/waitWrite#).
+We also track the fd for each operation and whether the operation is waiting on
+read or write readiness. This additional information is stored in the fd_table.
+The fd_table is maintained as an auxiliary table to the aiop_table, with table
+indexes matching the ClosureTable. So there is an entry in the aiop_table for
+each operation, and a corresponding entry in the fd_table at the same table
+index. The aiop_table and the fd_table are maintained incrementally, and with
+dense indexes.
+
+We also use a StgTimeoutQueue to track timeouts, and use the delay to the next
+timeout (if any) as the poll() timeout parameter.
+
+The CapIOManager structure for this I/O manager contains:
+
+ ClosureTable aiop_table;
+ StgTimeoutQueue *timeout_queue;
+ int interrupt_fd_r, interrupt_fd_w;
+
+******************************************************************************/
+
+/* Forward declarations */
+static bool enlargeTables(CapIOManager *iomgr);
+static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+static void removeFromTables(CapIOManager *iomgr, int i);
+static bool fdInSelectRange(int fd);
+static int collectFdSets(CapIOManager *iomgr);
+static void processBadFds(CapIOManager *iomgr);
+static void reportSelectError(void) STG_NORETURN;
+
+
+void initCapabilityIOManagerSelectBis(CapIOManager *iomgr)
+{
+ initClosureTable(&iomgr->aiop_table, ClosureTableCompact);
+ iomgr->timeout_queue = emptyTimeoutQueue();
+
+#if defined(HAVE_PREEMPTION)
+ newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w);
+
+ /* Would never happen in a standalone process, but could plausibly happen
+ * if the RTS is used within another process that already has many open fds.
+ */
+ if (iomgr->interrupt_fd_r < 0 || iomgr->interrupt_fd_r >= (int)FD_SETSIZE ||
+ iomgr->interrupt_fd_w < 0 || iomgr->interrupt_fd_w >= (int)FD_SETSIZE) {
+ barf("initCapabilityIOManagerSelectBis: fds out of select range");
+ }
+#endif
+
+ iomgr->rfds = stgMallocBytes(sizeof (fd_set), "IOManagerSelectBis");
+ iomgr->wfds = stgMallocBytes(sizeof (fd_set), "IOManagerSelectBis");
+}
+
+
+void freeCapabilityIOManagerSelectBis(CapIOManager *iomgr)
+{
+ stgFree(iomgr->rfds);
+ stgFree(iomgr->wfds);
+#if defined(HAVE_PREEMPTION)
+ closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w);
+#endif
+}
+
+
+/* Used to implement syncIOWaitReady. */
+IOSubmitResult syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso,
+ enum IOReadOrWrite rw, HsInt fd)
+{
+ StgAsyncIOOp *aiop;
+ aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp));
+ if (RTS_UNLIKELY(aiop == NULL)) return IOSubmitResultHeapOverflow;
+ SET_HDR(aiop, &stg_ASYNCIOOP_info, iomgr->cap->r.rCCCS);
+ aiop->notify.tso = tso;
+ aiop->notify_type = NotifyTSO;
+ aiop->live = &stg_ASYNCIO_LIVE0_closure;
+ tso->block_info.aiop = aiop;
+ RELEASE_STORE(&tso->why_blocked, rw == IORead ? BlockedOnRead
+ : BlockedOnWrite);
+ return asyncIOWaitReadySelectBis(iomgr, aiop, rw, fd);
+}
+
+IOSubmitResult asyncIOWaitReadySelectBis(CapIOManager *iomgr,
+ StgAsyncIOOp *aiop,
+ enum IOReadOrWrite rw, int fd)
+{
+ if (RTS_UNLIKELY(isFullClosureTable(&iomgr->aiop_table))) {
+ bool ok = enlargeTables(iomgr);
+ if (RTS_UNLIKELY(!ok)) return IOSubmitResultHeapOverflow;
+ }
+
+ if (RTS_UNLIKELY(!fdInSelectRange(fd))) {
+ /* Synchronous error */
+ aiop->outcome = IOOpOutcomeFailed;
+ aiop->error = EBADF;
+ return -EBADF;
+ };
+
+ int ix = insertClosureTable(iomgr->cap, &iomgr->aiop_table, aiop);
+
+ /* We use the aiop_table densely. */
+ ASSERT(ix == sizeClosureTable(&iomgr->aiop_table) - 1);
+
+ /* The syncIO wrapper or CMM primop filled in the notify and live fields,
+ * we fill the rest.
+ */
+ aiop->capno = iomgr->cap->no;
+ aiop->index = ix;
+ aiop->outcome = IOOpOutcomeInFlight;
+ aiop->operation = convIOReadOrWriteToIOOpCode(rw);
+ aiop->fd = fd;
+
+ return IOSubmitResultAsyncContinue;
+}
+
+
+void syncIOCancelSelectBis(CapIOManager *iomgr, StgTSO *tso)
+{
+ StgAsyncIOOp *aiop = tso->block_info.aiop;
+ ASSERT(aiop->notify_type == NotifyTSO);
+ ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop);
+ asyncIOCancelSelectBis(iomgr, aiop);
+}
+
+
+void asyncIOCancelSelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop)
+{
+ /* We can reliably determine if the aiop is still in progress by checking
+ * if the aiop_table still points to this aiop object. This is reliable
+ * because each aiop is GC heap allocated, so cannot be recycled until it
+ * is no longer retained by the application.
+ */
+ if (indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop) {
+ removeFromTables(iomgr, aiop->index);
+ aiop->outcome = IOOpOutcomeCancelled;
+ notifyIOCompletion(iomgr, aiop);
+ }
+}
+
+
+bool anyPendingTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ return !isEmptyTimeoutQueue(iomgr->timeout_queue)
+ || !isEmptyClosureTable(&iomgr->aiop_table);
+}
+
+
+static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
+{
+ ASSERT(aiop->outcome != IOOpOutcomeInFlight);
+ switch (aiop->notify_type) {
+ case NotifyTSO:
+ {
+ /* We should be guaranteed that the tso is still on the same
+ * cap because the tso was not on the run queue of any cap and
+ * so is not subject to thread migration.
+ */
+ StgTSO *tso = aiop->notify.tso;
+ ASSERT(tso->cap == iomgr->cap);
+
+ /* Fill in the outcome and result/error on the TSO's stack frame */
+ setTsoIOOpOutcome(tso, aiop->outcome, aiop->result);
+ pushOnRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
+
+ /* For the TSO case, the aiop was only reachable from the TSO
+ * itself, and thus it is now no longer be reachable at all.
+ */
+ IF_NONMOVING_WRITE_BARRIER_ENABLED {
+ updateRemembSetPushClosure(iomgr->cap, (StgClosure *)aiop);
+ }
+ break;
+ }
+ case NotifyMVar:
+ barf("selectbis iomgr: MVar notification not yet supported");
+ break;
+
+ case NotifyTVar:
+ barf("selectbis iomgr: TVar notification not yet supported");
+ break;
+ }
+}
+
+
+/* Called from poll/awaitCompletedTimeoutsOrIOSelectBis after a successful
+ * select() call to process all the I/O completions.
+ *
+ * We match up the I/O completion notifications from the system call against
+ * the pending I/O operations from the aiop_table, and use notifyIOCompletion
+ * on each completed aiop.
+ *
+ * Returns true if the select() was interupted via iomgr->interrupt_fd_r.
+ */
+static bool processIOCompletions(CapIOManager *iomgr, int ncompletions)
+{
+ /* We want to find the intersection between the sets of ready fds returned
+ * by select() and the aiop_table. Given how select() represents
+ * things there's no particularly efficient way to do it.
+ *
+ * We just go through the whole aiop_table and look up each one in
+ * the read or write fd_set to see if they completed. Note that here is
+ * where we rely on the aiop_table being dense so we can iterate
+ * over the entries. We can short-cut if we hit the ncompletions before
+ * getting to the end of the table.
+ */
+ debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)",
+ ncompletions);
+ ASSERT(ncompletions > 0);
+
+ bool interrupt = false;
+#if defined(HAVE_PREEMPTION)
+ /* If the interrupt_fd_r is ready, collect it */
+ if (FD_ISSET(iomgr->interrupt_fd_r, iomgr->rfds)) {
+ collectFdWakeup(iomgr->interrupt_fd_r);
+ ncompletions--;
+ interrupt = true;
+ debugTrace(DEBUG_iomanager, "Received interrupt in poll I/O manager");
+ }
+#endif
+
+ int i = 0;
+ while (ncompletions > 0) {
+ ASSERT(i < sizeClosureTable(&iomgr->aiop_table));
+
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, i);
+ int fd = aiop->fd;
+ enum IOOpCode op = aiop->operation;
+
+ ASSERT(op == IOOpCodeWaitRead || op == IOOpCodeWaitWrite);
+ ASSERT(aiop->outcome == IOOpOutcomeInFlight);
+
+ if (op == IOOpCodeWaitRead ? FD_ISSET(fd, iomgr->rfds)
+ : FD_ISSET(fd, iomgr->wfds)) {
+ aiop->outcome = IOOpOutcomeSuccess;
+ aiop->result = 0;
+ removeFromTables(iomgr, i);
+ notifyIOCompletion(iomgr, aiop);
+ ncompletions--;
+ } else {
+ /* You'd expect incrementing the table index to be unconditional,
+ * but we don't increment the index if we did process the entry,
+ * because using removeFromTables means we'll move an entry from
+ * the end of the table into the index i.
+ */
+ i++;
+ }
+ }
+ return interrupt;
+}
+
+
+void pollCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
+ Time now = getProcessElapsedTime();
+ processTimeoutCompletions(iomgr, now);
+ }
+
+ if (!isEmptyClosureTable(&iomgr->aiop_table)) {
+ /* Prepare to poll for I/O readiness: collect all of the fd's that
+ * we're interested in.
+ */
+ int maxfd = collectFdSets(iomgr);
+
+ /* Poll for I/O readiness, without waiting. */
+ struct timeval tv = (struct timeval) { .tv_sec = 0, .tv_usec = 0 };
+ int res = select(maxfd+1, iomgr->rfds, iomgr->wfds, NULL, &tv);
+ if (res == 0) {
+ /* There is no I/O ready. We'll return to the scheduler. */
+
+ } else if (res > 0) {
+ int ncompletions = res;
+ ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table)+1);
+ processIOCompletions(iomgr, ncompletions);
+
+ } else if (errno == EBADF) {
+ processBadFds(iomgr);
+
+ } else if (errno == EINTR) {
+ /* We got interrupted by a signal. This is unlikely since we asked
+ * select() not to wait, but if so we'll return to the scheduler.
+ */
+
+ } else {
+ reportSelectError();
+ }
+ }
+}
+
+
+bool awaitCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr)
+{
+ bool interrupt = false; /* got woken up via interruptIOManager */
+
+ /* Loop until we've woken up some threads. This loop is needed because the
+ * select() timing isn't accurate, we sometimes sleep for a while but not
+ * long enough to wake up a thread in a threadDelay. Or we may need to
+ * sleep multiple times if we need to sleep longer than the maximum timeout
+ * that select() supports.
+ */
+ do {
+ /* There is either pending I/O or pending timers. */
+ ASSERT(!isEmptyTimeoutQueue(iomgr->timeout_queue) ||
+ !isEmptyClosureTable(&iomgr->aiop_table));
+
+ Time now = getProcessElapsedTime();
+ processTimeoutCompletions(iomgr, now);
+
+ /* If we didn't wake any threads due to expiring timeouts, then we need
+ * to wait on I/O. Or to put it another way, even if we did wake some
+ * threads, we'll still poll (but not wait) for I/O. This is to ensure
+ * we avoid starving threads blocked on I/O.
+ */
+ bool wait = emptyRunQueue(iomgr->cap);
+
+ /* Prepare to poll for I/O readiness: collect all of the fd's that
+ * we're interested in.
+ */
+ int maxfd = collectFdSets(iomgr);
+
+ /* Decide if we are going to wait if no I/O is ready, either:
+ * poll only, wait indefinitely, or wait until a timeout.
+ */
+ struct timeval tv, *timeout_us;
+ timeout_us = timeoutInMicroseconds(iomgr, wait, now, &tv);
+
+ /* Check for I/O readiness, possibly waiting. */
+ int res = select(maxfd+1, iomgr->rfds, iomgr->wfds, NULL, timeout_us);
+
+ if (res == 0) {
+ /* Success but there is no I/O ready. This can happen either if we
+ * were not blocking or were in a timed wait and the timeout
+ * occurred before any I/O became ready. Either way, the do-while
+ * loop condition will handle it.
+ */
+ ASSERT(timeout_us != NULL);
+
+ } else if (res > 0) {
+ int ncompletions = res;
+ ASSERT(ncompletions <= sizeClosureTable(&iomgr->aiop_table)+1);
+ interrupt = processIOCompletions(iomgr, ncompletions);
+ // FIXME: do we also need to check for timeout completions now?
+ // we have a non-empty queue, but if !wait then we have also moved
+ // on and so we sould check for timeouts.
+
+ } else if (errno == EINTR) {
+ /* We got interrupted by a signal. In the non-threaded RTS, if the
+ * signal is one of ours we need to return to the scheduler to let
+ * it handle it. Otherwise we would loop and keep waiting for I/O
+ * or timeouts, meaning we would block for a long time before the
+ * signal is serviced.
+ */
+#if defined(RTS_USER_SIGNALS)
+ if (startPendingSignalHandlers(iomgr->cap)) break;
+#endif
+
+ /* We can also be interrupted by the shutdown signal handler, which
+ * will set sched_state and so cause us to drop out of the loop.
+ *
+ * For any other interruption (e.g. timer) we will go round the
+ * do-while loop again.
+ */
+
+ } else if (errno == EBADF) {
+ processBadFds(iomgr);
+
+ } else {
+ reportSelectError();
+ }
+
+ } while (emptyRunQueue(iomgr->cap)
+ && !interrupt
+ && (getSchedState() == SCHED_RUNNING));
+ return !interrupt;
+}
+
+
+static void reportSelectError(void)
+{
+ sysErrorBelch("select() failed");
+ stg_exit(EXIT_FAILURE);
+}
+
+
+static void processBadFds(CapIOManager *iomgr)
+{
+ /* This is extremely tiresome. The select() call fails with EBADF if any
+ * fd is invalid (usually closed), but it does not tell us which one.
+ * So we have to loop through them to find the offending fd.
+ *
+ * This will only find the first bad fd, so the caller must cope with
+ * there still being bad fds after this.
+ */
+
+ fd_set rfds, wfds;
+ FD_ZERO(&rfds);
+ FD_ZERO(&wfds);
+
+ int nentries = sizeClosureTable(&iomgr->aiop_table);
+ for (int ix = 0; ix < nentries; ix++) {
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, ix);
+ int fd = aiop->fd;
+ enum IOOpCode op = aiop->operation;
+
+ ASSERT(op == IOOpCodeWaitRead || op == IOOpCodeWaitWrite);
+
+ struct timeval tv = { .tv_sec = 0, .tv_usec = 0 };
+ int res;
+ if (op == IOOpCodeWaitRead) {
+ FD_SET(fd, &rfds);
+ res = select(fd+1, &rfds, NULL, NULL, &tv);
+ FD_CLR(fd, &rfds);
+ } else {
+ FD_SET(fd, &wfds);
+ res = select(fd+1, NULL, &wfds, NULL, &tv);
+ FD_CLR(fd, &wfds);
+ }
+ if (res == 0) {
+ continue;
+
+ } else if (errno == EBADF) {
+ aiop->outcome = IOOpOutcomeFailed;
+ aiop->error = EBADF;
+ removeFromTables(iomgr, ix);
+ notifyIOCompletion(iomgr, aiop);
+ /* There is /probably/ only one bad fd at once, so we abort the
+ * search here. If we are unlucky and there are several bad fds
+ * then the caller will just loop round again.
+ */
+
+ return;
+
+ } else if (errno == EINTR) {
+ /* Unlikely, since we did a non-blocking select().
+ * Try again with the same ix. */
+ ix--;
+ continue;
+
+ } else {
+ reportSelectError();
+ }
+ }
+}
+
+
+void interruptIOManagerSelectBis(CapIOManager *iomgr)
+{
+#if defined(HAVE_PREEMPTION)
+ sendFdWakeup(iomgr->interrupt_fd_w);
+#endif
+}
+
+
+/* Helper function to double the size of the aiop_table.
+ */
+static bool enlargeTables(CapIOManager *iomgr)
+{
+ int oldcapacity = capacityClosureTable(&iomgr->aiop_table);
+ int newcapacity = (oldcapacity == 0) ? 1 : (oldcapacity * 2);
+
+ bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity);
+ if (RTS_UNLIKELY(!ok)) return false;
+
+ return true;
+}
+
+
+/* Remove from the completion table, preserving compactness.
+ */
+static void removeFromTables(CapIOManager *iomgr, int ix)
+{
+ int ix_from; int ix_to;
+ removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix,
+ &ix_from, &ix_to);
+ if (ix_to != ix_from) {
+ StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to);
+ aiop_to->index = ix_to;
+ }
+}
+
+/* In preparation for calling select(), set the iomgr->rfds and iomgr->wfds
+ * sets based on the pending I/O ops iomgr->aiop_table.
+ *
+ * Returns the maximum fd in the two sets (since select() needs this).
+ */
+static int collectFdSets(CapIOManager *iomgr)
+{
+ int maxfd = -1;
+ int nentries = sizeClosureTable(&iomgr->aiop_table);
+
+ /* In principle we could optimise this slightly by not resetting the
+ * whole of each fdset, by assuming that select() does not modify
+ * entries above maxfd. This is probably not worth doing however, since
+ * this I/O manager is supposed to be portable and is expected to be slow.
+ */
+ FD_ZERO(iomgr->rfds);
+ FD_ZERO(iomgr->wfds);
+
+#if defined(HAVE_PREEMPTION)
+ /* We're always interested in our interrupt fd */
+ {
+ int fd = iomgr->interrupt_fd_r;
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ FD_SET(fd, iomgr->rfds);
+ }
+#endif
+
+ for (int ix = 0; ix < nentries; ix++) {
+ StgAsyncIOOp *aiop = indexClosureTable(&iomgr->aiop_table, ix);
+ int fd = aiop->fd;
+ enum IOOpCode op = aiop->operation;
+
+ ASSERT(op == IOOpCodeWaitRead || op == IOOpCodeWaitWrite);
+ ASSERT(fdInSelectRange(fd)); // Checked in asyncIOWaitReadySelectBis
+
+ if (op == IOOpCodeWaitRead) {
+ FD_SET(fd, iomgr->rfds);
+ } else {
+ FD_SET(fd, iomgr->wfds);
+ }
+ maxfd = (fd > maxfd) ? fd : maxfd;
+ }
+ return maxfd;
+}
+
+
+/* Helper function to check if the fd is within range for select().
+ */
+static bool fdInSelectRange(int fd)
+{
+ /* On older FreeBSDs, FD_SETSIZE is unsigned. Cast it to signed int
+ * in order to switch off the 'comparison between signed and
+ * unsigned error message
+ * Newer versions of FreeBSD have switched to unsigned int:
+ * https://github.com/freebsd/freebsd/commit/12ae7f74a071f0439763986026525094a…
+ * http://fa.freebsd.cvs-all.narkive.com/bCWNHbaC/svn-commit-r265051-head-sys-…
+ * So the (int) cast should be removed across the code base once
+ * GHC requires a version of FreeBSD that has that change in it.
+ */
+ return ((fd >= 0) && (fd < (int)FD_SETSIZE));
+ /* TODO: on several platforms, it is possible to use a larger fd set size.
+ For example on OSX:
+ https://code.saghul.net/2016/05/libuv-internals-the-osx-select2-trick/
+ And probably similar on other platforms. It basically amounts to looking
+ through the representation abstraction of fd_set and to know that it is
+ indeed a bit set, and then we can simply allocate it and manipulte it
+ ourselves. We could do this, dynamically (re-)allocate the size.
+ */
+}
+
+#endif /* IOMGR_ENABLED_SELECTBIS */
=====================================
rts/posix/SelectBis.h
=====================================
@@ -0,0 +1,62 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020-2026
+ *
+ * A second I/O manager based on the classic Unix select() system call.
+ *
+ * This I/O manager is called "selectbis", because it is the second such I/O
+ * manager based on select(). The historic implementation is named "select"
+ * and lives in Select.{c,h}. This I/O manager exists for the benefit of users
+ * of Apple products.
+ *
+ * The poll I/O manger _should_ be the portable baseline posix I/O manager.
+ * Unfortunately Mac OSX has a buggy implementation of poll(). The OSX man
+ * page documents this as:
+ *
+ * > BUGS The poll() system call currently does not support devices.
+ *
+ * This is quite incredible, given that poll and select should be relatively
+ * thin interfaces to the the same underlying kernel infrastructure.
+ * Furthermore, OSX is supposedly certified as POSIX compliant! Due to this
+ * (incompetence) we need a new I/O manager implementation based on the
+ * antique select() API, with all of its known limitations.
+ *
+ * Please direct all complaints to:
+ * Apple Inc., One Apple Park Way, Cupertino, CA 95014, USA.
+ *
+ * Prototypes for functions in SelectBis.c
+ *
+ * -------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "IOManager.h"
+
+#include "BeginPrivate.h"
+
+#if defined(IOMGR_ENABLED_SELECTBIS)
+
+void initCapabilityIOManagerSelectBis(CapIOManager *iomgr);
+void freeCapabilityIOManagerSelectBis(CapIOManager *iomgr);
+
+/* Synchronous I/O and timer operations */
+IOSubmitResult syncIOWaitReadySelectBis(CapIOManager *iomgr, StgTSO *tso,
+ enum IOReadOrWrite rw, HsInt fd);
+void syncIOCancelSelectBis(CapIOManager *iomgr, StgTSO *tso);
+
+/* Asynchronous operations */
+IOSubmitResult asyncIOWaitReadySelectBis(CapIOManager *iomgr,
+ StgAsyncIOOp *aiop,
+ enum IOReadOrWrite rw, int fd);
+void asyncIOCancelSelectBis(CapIOManager *iomgr, StgAsyncIOOp *aiop);
+
+/* Scheduler operations */
+bool anyPendingTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+void pollCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+bool awaitCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr);
+void interruptIOManagerSelectBis(CapIOManager *iomgr);
+
+#endif /* IOMGR_ENABLED_SELECTBIS */
+
+#include "EndPrivate.h"
+
=====================================
rts/posix/Timeout.c
=====================================
@@ -14,8 +14,9 @@
#include "Schedule.h"
#include "Prelude.h"
-#include "Timeout.h"
+#include "IOManager.h"
#include "IOManagerInternals.h"
+#include "Timeout.h"
#include "TimeoutQueue.h"
#include <limits.h>
@@ -24,7 +25,8 @@
/* Currently only used by the poll I/O manager, but in future may be used by
several in-RTS I/O managers.
*/
-#if defined(IOMGR_ENABLED_POLL)
+#if defined(IOMGR_ENABLED_SELECTBIS) \
+ || defined(IOMGR_ENABLED_POLL)
bool syncDelayTimeout(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay)
{
@@ -68,14 +70,13 @@ void syncDelayCancelTimeout(CapIOManager *iomgr, StgTSO *tso)
deleteTimeoutQueue(&iomgr->timeout_queue, timeout);
+ appendToRunQueue(iomgr->cap, tso);
+ RELEASE_STORE(&tso->why_blocked, NotBlocked);
+
/* the timeout is no longer accessible from anywhere (except here) */
IF_NONMOVING_WRITE_BARRIER_ENABLED {
updateRemembSetPushClosure(iomgr->cap, (StgClosure *)timeout);
}
-
- /* We don't put the TSO back on the run queue or change the why_blocked
- status, as that is done by removeFromQueues (in the throwTo* functions).
- */
}
static void notifyTimeoutCompletion(CapIOManager *iomgr, StgTimeout *timeout);
@@ -222,5 +223,58 @@ struct timespec *timeoutInNanoseconds(CapIOManager *iomgr, bool wait,
}
#endif
-#endif // defined(IOMGR_ENABLED_POLL)
+/* select() expect a timeout in microseconds, using struct timeval * with
+ * special values of NULL for indefinite wait, and 0 for no waiting.
+ */
+#if defined(IOMGR_ENABLED_SELECTBIS)
+struct timeval *timeoutInMicroseconds(CapIOManager *iomgr, bool wait,
+ Time now, struct timeval *tv)
+{
+ if (!wait) {
+ /* Don't wait, just poll. */
+ *tv = (struct timeval) { .tv_sec = 0, .tv_usec = 0 };
+ return tv;
+
+ } else if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) {
+ /* SUSv2 allows implementations to have an implementation defined
+ * maximum timeout for select(2). The standard requires
+ * implementations to silently truncate values exceeding this maximum
+ * to the maximum. Unfortunately, OSX and the BSD don't comply with
+ * SUSv2, instead opting to return EINVAL for values exceeding a
+ * timeout of 1e8.
+ *
+ * Select returning an error crashes the runtime in a bad way. To
+ * play it safe we truncate any timeout to 31 days, as SUSv2 requires
+ * any implementations maximum timeout to be larger than this.
+ *
+ * Truncating the timeout is not an issue, because if nothing
+ * interesting happens when the timeout expires, we'll see that the
+ * thread still wants to be blocked longer and simply block on a new
+ * iteration of select(2).
+ */
+ const time_t max_seconds = 2678400; // 31 * 24 * 60 * 60
+
+ Time waketime = findMinWaketimeTimeoutQueue(iomgr->timeout_queue);
+ Time waittime = waketime - now;
+
+ /* Any expired timeouts should have been cleared, so we must be waiting
+ * for a timeout in the future. */
+ ASSERT(waittime > 0);
+
+ tv->tv_sec = TimeToSeconds(waittime);
+ if (tv->tv_sec < max_seconds) {
+ tv->tv_usec = TimeToUS(waittime) % 1000000;
+ } else {
+ tv->tv_sec = max_seconds;
+ tv->tv_usec = 0;
+ }
+ return tv;
+
+ } else {
+ return NULL;
+ }
+}
+#endif
+
+#endif // defined(IOMGR_ENABLED_POLL) || ... etc
=====================================
rts/posix/Timeout.h
=====================================
@@ -46,5 +46,15 @@ struct timespec *timeoutInNanoseconds(CapIOManager *iomgr, bool wait,
Time now, struct timespec *tv);
#endif
+/* As above, but a timeout in microseconds. This is intended to be used with
+ * select() which expect struct timespec *, with special values of NULL for
+ * indefinite wait, and 0 for no waiting.
+ */
+#if defined(IOMGR_ENABLED_SELECTBIS)
+struct timeval *timeoutInMicroseconds(CapIOManager *iomgr, bool wait,
+ Time now, struct timeval *tv);
+
+#endif
+
#include "EndPrivate.h"
=====================================
rts/rts.cabal
=====================================
@@ -568,6 +568,7 @@ library
wasm/JSFFI.c
wasm/JSFFIGlobals.c
posix/Select.c
+ posix/SelectBis.c
posix/Poll.c
posix/Timeout.c
cmm-sources: wasm/jsval.cmm
@@ -583,6 +584,7 @@ library
posix/MIO.c
posix/Poll.c
posix/Select.c
+ posix/SelectBis.c
posix/Signals.c
posix/Timeout.c
posix/TTY.c
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -7861,7 +7861,7 @@ module GHC.RTS.Flags.Experimental where
type HpcFlags :: *
data HpcFlags = HpcFlags {readTixFile :: GHC.Internal.Types.Bool, writeTixFile :: GHC.Internal.Types.Bool}
type IoManagerFlag :: *
- data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
+ data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagSelectBis | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -7864,7 +7864,7 @@ module GHC.RTS.Flags.Experimental where
type HpcFlags :: *
data HpcFlags = HpcFlags {readTixFile :: GHC.Internal.Types.Bool, writeTixFile :: GHC.Internal.Types.Bool}
type IoManagerFlag :: *
- data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
+ data IoManagerFlag = IoManagerFlagAuto | IoManagerFlagSelect | IoManagerFlagSelectBis | IoManagerFlagPoll | IoManagerFlagMIO | IoManagerFlagWinIO | IoManagerFlagWin32Legacy
type IoSubSystem :: *
data IoSubSystem = IoPOSIX | IoNative
type MiscFlags :: *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/471450f42ed49fabd3d80beedb3677…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/471450f42ed49fabd3d80beedb3677…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 15 Sep '26
by Andreas Klebinger (＠AndreasK) 15 Sep '26
15 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
7f0ac23c by Andreas Klebinger at 2026-09-14T20:03:20+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`.
- - - - -
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
=====================================
@@ -0,0 +1,8 @@
+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
14 -> 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
0 -> 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
=====================================
@@ -0,0 +1,280 @@
+{-# 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
=====================================
@@ -0,0 +1,11 @@
+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
=====================================
@@ -1 +1,6 @@
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f0ac23c89b040e2d178619a74d327c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f0ac23c89b040e2d178619a74d327c…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/apk/iface-encoding] .hi files: Various encoding improvements
by Andreas Klebinger (＠AndreasK) 15 Sep '26
by Andreas Klebinger (＠AndreasK) 15 Sep '26
15 Sep '26
Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
Commits:
eb587819 by Andreas Klebinger at 2026-09-14T19:47:11+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`.
- - - - -
13 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
Changes:
=====================================
changelog.d/T27808-iface-encoding-improvements
=====================================
@@ -0,0 +1,8 @@
+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
14 -> 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
0 -> 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
=====================================
@@ -0,0 +1,280 @@
+{-# 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
=====================================
@@ -0,0 +1,11 @@
+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
=====================================
@@ -1 +1,6 @@
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb587819051dd407d3023ed7c4b7dcf…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb587819051dd407d3023ed7c4b7dcf…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/jeltsch/portable-bco-byte-array-serialization
by Wolfgang Jeltsch (＠jeltsch) 15 Sep '26
by Wolfgang Jeltsch (＠jeltsch) 15 Sep '26
15 Sep '26
Wolfgang Jeltsch pushed new branch wip/jeltsch/portable-bco-byte-array-serialization at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/portable-bco-byte-arr…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc][wip/io-manager-deadlock-detection] 56 commits: Never make an absent filler for a constraint type
by Duncan Coutts (＠dcoutts) 14 Sep '26
by Duncan Coutts (＠dcoutts) 14 Sep '26
14 Sep '26
Duncan Coutts pushed to branch wip/io-manager-deadlock-detection at Glasgow Haskell Compiler / GHC
Commits:
7bf546fc by Simon Peyton Jones at 2026-08-31T23:48:53-04:00
Never make an absent filler for a constraint type
mkAbsentFiller used isTerminatingType to decide, but that is not enough.
Consider
class Eq a => UC a where {}
let u :: UC Int -- UC Int is a "non-terminating type"
u = error "Absent"
let e :: Eq Int -- Eq Int is a "terminating type"
e = $p1UC u
We clearly must not make a filler for `e`, because we speculatively
evaluate it. But speculatively evaluating `e` forces `u`, so we must not
make one for `u` either.
Asking isDictTy instead is not enough either, because it does not catch a
constraint hidden behind an unreduced type family application:
type family F a :: Constraint
type instance F W = TC W
a :: F W => Int -> Int -- (F W) argument is absent
Oops! Entered absent arg Arg: irred
Type: F W
So play safe and use isPredTy: never make an absent filler for any
constraint-kinded type.
Fixes #27627
- - - - -
5f474953 by Zubin Duggal at 2026-08-31T23:48:53-04:00
Add tests for absent fillers at dictionary types
T27627 a unary class whose superclass is a non-unary class
T27627a ...whose superclass is a Constraint-kinded type family
T27627b ...whose superclass is a quantified constraint
T27627c a unary class applied to itself, (UC (UC (TC a)))
T27627e a (forall b. P b) dictionary that loops
- - - - -
cd5c6bcc by Zubin Duggal at 2026-08-31T23:48:53-04:00
An abstract TyCon may hide a unary class
A class declared in an hs-boot file is an AbstractTyCon inside the
module loop, and compiling the real declaration may reveal it to be a
UnaryClassTyCon.
- isTerminatingType returned True for such AbstractTyCons
- IfaceToCore set the unary flag to False in the DFunId
So we could end up speculating bottom dictionaries because inside a module
loop we see an UnaryClassTyCon as an AbstractTyCon
Use isTerminatingTyCon, which returns False for an abstract TyCon.
The Bool in DFunId is now a cache for isTerminatingTyCon, set in
mkDFunIdDetails.
Fixes #27704
- - - - -
abfc224a by Zubin Duggal at 2026-08-31T23:48:53-04:00
Specialise: don't replace dead args with absent fillers
specHeader decides an argument is dead by calling isDeadBinder on a binder of
the /optimised RHS/, then applies the filler to the /stable unfolding/
template instead. The two may differ, so the argument can be dead in
the RHS and not in the template.
The specialised function's unfolding then has an absent filler, and any call
site that inlines it evaluates the error thunk.
Dropping dead args in the specialiser is rarely worth it, to quote Simon,
"The later worker/wrapper pass will pick up the dead arg later if it is really dead. Keeps the specialiser simpler."
So instead of trying to check if the arg really is dead in the stable unfolding,
just drop the logic for dropping dead args in the specialiser altogeher.
Fixes #27703
- - - - -
1557fd1c by Zubin Duggal at 2026-08-31T23:48:53-04:00
CorePrep: don't speculate a call across an hs-boot edge
We take care not to evaluate things that might be bottom, like a
looping dictionary group, but our analysis is defeated by boot files.
We only track recursion within a module, so two dictionaries that
depend on each other across a module loop each look non-recursive, and
we might speculate them.
Any recursion we cannot see must cross an hs-boot edge, so refuse to
speculate calls that cross one.
Fixes #27717
- - - - -
4117e5ae by Wolfgang Jeltsch at 2026-08-31T23:49:35-04:00
Incorporate the `rethrowSTM` reexport into the `stm` submodule
- - - - -
4bfbf5c8 by ARATA Mizuki at 2026-09-01T18:55:08-04:00
testsuite: Fix out-of-bounds access in T3586
unsafeRead and unsafeWrite use 0-based index.
Looking at #3586, the expected output seems to be 2.8e8.
Addresses #27596
- - - - -
3f9db6d4 by ARATA Mizuki at 2026-09-01T18:55:08-04:00
testsuite: Fix out-of-bounds access in T21305
writeInt64Array# takes an index measured in units of Int64 elements.
Fixes #27596
- - - - -
44d7788f by Simon Peyton Jones at 2026-09-01T18:55:53-04:00
Fix buglet in INLINE-arity calculation for pattern synonyms
This fixes #27744.
The buglet was accidentally introduced by
commit 3a0f9a51c1dacc474c7fd128082edd8bf4081256
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Sat Aug 1 00:13:02 2026 +0100
Fix three bugs related to required type args and INLINE pragmas
I failed to find all the calls to `addInlinePragArity`!
- - - - -
df058f1d by Simon Jakobi at 2026-09-02T07:18:06-04:00
testsuite: Migrate perf tests off collect_compiler_stats('all')
The 'all' metric argument applies a single tolerance to bytes
allocated, max_bytes_used and peak_megabytes_allocated, although their
noise profiles are incompatible (#27653): allocations are nearly
deterministic, residency needs 10-20%, and peak is quantized to 1 MB.
Any single tolerance is too tight for one metric or too slack for
another. This migrates the remaining users of 'all' (and of the 'all'
default) to explicit per-metric collection, ahead of removing 'all'
from the driver.
peak_megabytes_allocated is dropped everywhere: its 1 MB granularity
makes tight relative windows meaningless (#27613), and it is sensitive
to GC timing. In #27489 it drifted by -5.3% while max_bytes_used moved
by less than 0.1%. Where a test guards a memory property,
max_bytes_used covers it at byte granularity.
Where the motivating ticket was about compile-time memory
(T11545, T15304, T26425), residency remains gated via max_bytes_used,
now with a residency-appropriate tolerance.
max_bytes_used is dropped where residency was only ever an accident of
'all':
* T15630, T15630a, T20261: the underlying tickets (#15630, #20261)
contain no memory data at all. One is a simplifier-ticks blowup and
the other is stated entirely in allocation numbers, so the 20%
window never had teeth.
* T21839c: #21839's measurements show residency essentially flat
(+0.16%) while allocations moved +7%, so allocations are the
discriminating metric. They are already gated at 1% via
collect_compiler_runtime. The ghc/max gate had previously broken CI
spuriously (9fd11585eb widened it from 1% to 10% for that reason).
Allocation tolerances are tightened to the testsuite's conventional 2%
where 'all' previously left them at 10-20%.
Assisted-by: Claude Fable 5
- - - - -
72dd2432 by Simon Jakobi at 2026-09-02T07:18:06-04:00
testsuite: Remove the 'all' metric argument of collect_stats
'all' gated bytes allocated, max_bytes_used and peak_megabytes_allocated
at a single tolerance, although their noise profiles are incompatible,
making such tests either flaky or toothless (#27653).
Closes #27653.
Assisted-by: Claude Fable 5
- - - - -
2228cb30 by Simon Jakobi at 2026-09-02T07:18:06-04:00
testsuite: Make the deviation argument of collect_stats mandatory
Almost every caller passes an explicit tolerance matched to the
metric's noise profile, and the silent 20% default is far slacker than
'bytes allocated' merits. Only two tests relied on it. They now state
their tolerance explicitly:
large-project gets 10%, in line with other large compile-time tests.
T9848 gets 2%: its metric is byte-for-byte deterministic across CI
jobs and platforms of a given test_env, has drifted only about 2.5%
since 2015, and the fusion failure it guards against would show up as
a roughly +30000% jump.
Assisted-by: Claude Fable 5
- - - - -
56291fc5 by Cheng Shao at 2026-09-02T07:18:45-04:00
autoconf/ghc-toolchain: bump llvm upper bound to support llvm 23
This commit bumps llvm upper bound to support llvm 23.
- - - - -
20eb3f41 by Cheng Shao at 2026-09-02T07:18:45-04:00
rts: fix compilation issues with clang 23
clang 23 has broadened `-Wall`/`-Wextra` ranges, exposing some minor
issues in the rts when building with validate flavours:
- Unused locals
- `#pragma GCC diagnostic pop` mismatch
This commit fixes those.
- - - - -
9e7739ab by Simon Jakobi at 2026-09-03T13:45:43-04:00
Add -Wimplicit-field-strictness (#16836)
This opt-in warning fires when a data constructor field lacks an
explicit strictness annotation (`!` or `~`). It complements the
LazyFieldAnnotations extension (4762a8bf30f) from GHC proposal 752,
which makes `~` annotations available for this purpose.
Deciding which fields to report requires their levity, so the check
runs after typechecking. To keep the noise down, the diagnostic is
emitted once per data declaration, grouped by constructor.
Closes #16836.
Assisted-by: Claude Fable 5
- - - - -
6a44d591 by mangoiv at 2026-09-03T13:46:22-04:00
simplifier: remove a bogus `assert` in `rebuild_app'` in `GHC.CoreToStg.Prep.cpeApp`.
Prior to this commit
commit 08bc245be70d95801bc1138804ed1de9474fbdc0
Author: sheaf <sam.derbyshire(a)gmail.com>
Date: Sat Feb 28 16:30:43 2026 +0100
Clean up join points, casts & ticks
This commit shores up the logic dealing with casts and ticks occurring
in between a join point binding and a jump
any `PlaceRuntime` ticks we observed were profiling ticks, even though that
isn't necessary.
The more liberal rules in the above commit allow e.g. breakpoint ticks
(which are valid PlaceRuntime ticks) to legitimately appear in an argument
position.
Fixes #27556
- - - - -
eaa95a6f by Andrei Borzenkov at 2026-09-04T08:08:40-04:00
Parentheses in prefix GADT constructors (#27423)
Updated `splitLHsGadtTy` to allow looking
through the parentheses for inner binders. General example
of a code pattern that's allowed now:
data S a where
MkS :: (forall a. S a)
That should work now with any combination of nested
foralls and parentheses.
We don't perform parenthesis unwrapping for record
GADT constructors in accordance with GHC Proposal #402.
To this end `con_inner_bndrs` no longer stores plain forall
telescopes: `[HsForAllTelescope pass]` is replaced with
`[LHsGadtTelescope pass]`, a new `HsArg`-style type whose
`HsGadtForAll` holds an inner telescope and whose `HsGadtPar`
holds a pair of parentheses. The parentheses carry no meaning
for renaming or type checking; the only reason to record them
is exact-printing.
Updated `pprConDecl` to improve the `parse == parse . ppr . parse`
property of GADT pretty-printing.
The pretty printer can now output code that's similar to this:
data T a where
MkT1 :: (forall a. T a)
MkT2 :: forall . forall a. T a
These are special cases of inner forall binders
for prefix GADT constructors, when we have either
implicit or zero explicit outer binders.
- - - - -
639456a8 by Evgeny Malyshev at 2026-09-04T08:09:25-04:00
HsPat: Add spacing to unary tuple patterns
Use hsep when printing unary boxed TuplePat applications so that the
MkSolo constructor is separated from its argument. The old hcat rendered
wildcard and parenthesized arguments as MkSolo_ and MkSolo().
Add T27034 to exercise the HsPat splice-dump path with wildcard and
variable arguments, and update existing affected golden output.
Fixes #27034
Assisted-By: OpenAI Codex
- - - - -
2908ab36 by Simon Jakobi at 2026-09-05T07:22:17-04:00
X86 NCG: use btr/bts/btc for single-bit operations
Previously the Cmm patterns
x & ~(1 << i)
x | (1 << i)
x ^ (1 << i)
compiled to mov/shl/not/and-style sequences of 3-4 instructions. Now
they compile to a single btr, bts or btc, matching what C compilers
produce.
When the bit index is a literal, constant folding has already collapsed
these patterns into ones with a literal mask, such as
x & 0xfffffeffffffffff for x & ~(1 << 40). Such masks are now also
compiled to a bit-test instruction when they don't fit in an imm32 and
would otherwise have to be loaded into a register first.
For a variable bit index, this applies only when the shift is unchecked
(uncheckedShiftL#, Data.Bits.unsafeShiftL): the bounds-checked shiftL
used by e.g. the default clearBit/setBit/complementBit implementations
wraps the shift in a bounds mask that this optimisation does not see
through. With a literal index, the bounds mask is constant-folded away,
so the checked operations benefit too.
See Note [Bit-test instructions] in GHC.CmmToAsm.X86.CodeGen.
Fixes #25233.
Assisted-by: Claude Fable 5
- - - - -
c673ecf0 by Simon Peyton Jones at 2026-09-05T07:22:59-04:00
Move HsStatic free-var test to typechecker
A `static` form should have no free *term* variables, but it
can have free *type* variables. Alas, the renamer does not really know what
is a term variable and what is a type variable, because of required type
arguments. This patch moves the test to the typechecker, which does know.
Addresses #27664
- - - - -
5939ceaf by sheaf at 2026-09-05T22:06:18-04:00
Windows: enforce path convention in ./configure
As detailed in Note [MSYS paths] in Hadrian.Utilities, the standing
convention (using Windows-style paths with forward slashes) is now
enforced in ./configure instead of within Hadrian, removing the need for
'cygpath' calls within Hadrian.
Fixes #26683
- - - - -
a6061455 by sheaf at 2026-09-05T22:06:18-04:00
Hadrian: introduce ExeSpawnPath
Specific details about the filepath used to specify the executable to
spawn with CreateProcess matters on Windows: whether we use forward or
backward slashes, a leading ./, or an absolute path changes how the
executable is found.
This commit introduces 'ExeSpawnPath' which is a path that is guaranteed
to be found when spawning a process. All command invocations now go
through this type to ensure the path has been properly sanitised.
See Note [NeedCurrentDirectoryForExePath] in Hadrian.Utilities.
The same treatment is applied to hsc2hs. Updates hsc2hs submodule.
- - - - -
e28313e3 by sheaf at 2026-09-05T22:07:06-04:00
Preserve tick ordering in 'tickTickedExpr'
'GHC.Core.Utils.tickTickedExpr' tries to combine a tick 't1' into an
existing stack of ticks 't2s'. There are two situations:
1. 't1' is subsumed by a tick in 't2s': drop it.
2. A tick in 't2s' is subsumed by 't1', say 't2'.
This commit ensures that in case (2) we keep 't1' on the outside instead
of replacing 't2' at its position in the stack. This avoids re-ordering
source notes (which was the cause of #27749).
This fixes a regression introduced in 2dadf3b0d05.
Fixes #27749
- - - - -
3172f557 by sheaf at 2026-09-05T22:07:06-04:00
Consistently prefer local source note ticks
GHC.Cmm.DebugBlock.cmmDebugGen (DWARF annotations) and
GHC.Stg.Debug.quickSourcePos (-finfo-table-map) both contained logic to
prioritise source note ticks from the current module.
This commit commons up this logic and propagates it to a third consumer:
IPE stack frames, in GHC.Driver.GenerateCgIPEStub.
See the new function GHC.Types.Tickish.bestSourceNote.
- - - - -
192be0b6 by Luite Stegeman at 2026-09-07T19:43:36-04:00
rts: fix ctoi_tuple_spill_words getting out of sync
Fix a few places that were not updating ctoi_tuple_spill_words
correctly, leading to corruption/crashes when dealing with large
unboxed tuples in bytecode:
- captureContinuationAndAbort
- findRetryFrameHelper/findAtomicallyFrameHelper
- interpretBCO bci_BRK_FUN
fixes #27633
- - - - -
604eb43c by Simon Jakobi at 2026-09-07T19:44:15-04:00
Hadrian: don't capture the testsuite driver's output (#27780)
a6061455d54 switched the Testsuite RunTest case from Shake's cmd to the
cmd' wrapper. cmd' always captures stdout and stderr, and since the
caller asks for Exit, it returns without dumping what it captured. As a
result the testsuite output no longer appears in CI job logs: failures,
performance metrics and the summary were lost with the job.
Use cmdExe, the uncaptured cmd, as the other plain-cmd sites in that
commit do.
Fixes #27780.
Assisted-by: Claude Fable 5.1
- - - - -
06eee015 by Luite Stegeman at 2026-09-08T06:03:06+02:00
rts: Fix missing memory barrier in eval_thunk_selector (#27477)
unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the
indirectee, leading to segfaults and corruption during GC on
weakly-ordered architectures.
Fixes #27477
- - - - -
f8b2bd8f by Alan Zimmerman at 2026-09-08T09:39:12-04:00
EPA Fix HsCmdDo exact print with comments
Exact printing of HsCmdDo was ignoring the location for the do
statements, and this is an annotation that can have comments in it.
Update it so we print the statements as a unit, including any
comments.
Also add the result of auditing that we capture comments in all needed
places, noting that the remaining Anno SrcSpan instances are benign.
- - - - -
430967ab by Duncan Coutts at 2026-09-09T11:07:01+01:00
Reorder cmm decls in HeapStackCheck for a better logical grouping
And put more section headers in to deliniate the groups.
We're about to add more here, so better to organise it first.
- - - - -
344080fd by Duncan Coutts at 2026-09-09T11:07:01+01:00
Add raisePrimIOException and add it to RTS<->ghc-internal API
The raisePrimIOException is a new helper function that I/O primops will
use to help them report I/O errors. This is implemented in Haskell
(since that's a lot easier), but has a calling convention that is
easy(ish) to use from Cmm in the I/O primops.
So we add it to the RTS API struct, and since we'll use it from Cmm we
also need a field accessor macro for cmm (in deriveConstants).
See the Note about how we cannot have nice things due to async
exceptions and thunks preventing us from using catch.
- - - - -
cfdb3399 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Add new blocking functions for I/O primops
See the Note [Thread blocking for new I/O primops],
and the Note [Calling convention for raisePrimIOException].
The point is, it will allow us to report synchronous exceptions from I/O
primops, and do so much more flexibly.
Previously the I/O managers could only report async exceptions and only
nullary exceptions. This was OK historically, but no good as we add
more I/O managers and expand the range of I/O operations we support.
- - - - -
f09c09d8 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Change the encoding of results from the I/O manager to I/O primops
Previously we just had async continue or heap overflow.
We now extend what we can report with synchronous success, and
synchronous failure with an errno.
See Note [Encoding of result of I/O manager operations]
We don't use these two new cases yet, but we will. In particular an
epoll I/O manager needs to be able to report synchronous success or
failure for waitRead#/waitWrite#.
- - - - -
30f074d9 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Switch waitRead/Write# to use new blocking return frames
and update the I/O managers to set the result before resuming the
blocked threads.
This makes it possible for I/O managers to report synchronous exceptions
from the I/O primops, but that will be done in a subsequent commit.
- - - - -
a8786ced by Duncan Coutts at 2026-09-09T11:07:01+01:00
Switch Poll and Select I/O managers to report sync exceptions
rather than using raiseAsync with blockedOnBadFD_closure.
This uses the new mechanism in the blocking frame return code to report
synchronous exceptions.
- - - - -
7a9df79a by Duncan Coutts at 2026-09-09T11:07:01+01:00
Remove now-unused blockedOnBadFD
It was previously thrown by the select and poll I/O managers, but now
they use raisePrimIOException (with an EBADF errno).
- - - - -
6b0424e3 by Duncan Coutts at 2026-09-09T11:07:01+01:00
Improve the docs for delay# waitRead# and waitWrite#
Document that the waitRead/Write# can throw exceptions (this was true
before too), and that all of them are async exception cancellation
points.
- - - - -
afeb2c30 by Duncan Coutts at 2026-09-09T20:08:58-04:00
Enable printf warnings for trace functions and fix resulting warnings
Most of the existing printf-style functions are annotated with
attributes to enable gcc/clang warnings for the printf format string,
but several trace functions in Trace.h were missing this annotation.
Enable them, and fix the resulting warnings.
- - - - -
9a442c93 by Alan Zimmerman at 2026-09-09T20:09:36-04:00
EPA: Exact print ConDeclGADT without custom enterAnn
!16321 brought in explicit capture of parens in a ConDeclGADT.
The ExactPrint update introduced a modification of the fundamental
function in exact printing, `enterAnn`, by splitting it into a version
allowing injection of functionality normally handled by the
ExactPrint class methods.
This commit refactors that code, to restore the prior `enterAnn`
version, by following the convention in ExactPrint of introducing a
helper data structure with its own `ExactPrint` instance to achieve
the same effect.
- - - - -
a01d8943 by Duncan Coutts at 2026-09-13T22:55:59+01:00
Make signal handling be a responsibility of the I/O manager(s)
Previously it was scattered between I/O managers and the scheduler, and
especially the scheduler's deadlock detection.
Previously the scheduler would poll for pending signals each iteration
of the scheduler loop. The scheduler also had some hairy signal
functionality in the deadlock detection: in the non-threaded RTS (only)
if there were still no threads running after deadlock detection then it
would block waiting for signals.
But signals can and (in my opinion) should be thought of as just a funny
kind of I/O, and thus should be a responsibility of the I/O manager.
So now we have the I/O managers poll for signals when they are polling
for I/O completion (and removing the separate poll in the scheduler).
And when I/O managers block waiting for I/O then they now also start
signal handlers if they get interrupted by a signal. Crucially, if there
is no pending I/O or timers, the awaitCompletedTimeoutsOrIO will still
block waiting for signals.
This patch puts us into an intermediate state: it temporarily breaks
deadlock detection in the non-threaded RTS. The waiting on I/O currently
happens before deadlock detection. This means we'll now wait forever on
signals before doing deadlock detection. We need to move waiting after
deadlock detection. We'll do that in a later patch.
- - - - -
42b765b0 by Duncan Coutts at 2026-09-13T22:55:59+01:00
Clean up the RTS internal signal handling API
Now that the I/O manager is responsible for signals, we can simplify the
API we present for signal handling.
We now just need startPendingSignalHandlers, which is called from the
I/O managers. We can get rid of awaitUserSignals. We also don't need
RtsSignals.h to re-export the platform-specific posix/Signals.h or
win32/ConsoleHandler.h
We can also hide more of the implementation of signals. Less has to be
exposed in posix/Signals.h or win32/ConsoleHandler.h. Indeed,
posix/Signals.h becomes empty and we remove it. Partly this is because
we don't need inline functions (or macros) in the interface.
Also remove signal_handlers from RTS ABI exported symbols list. It does
not appear to have any users in the core libs, and its really an
internal implementation detail. It should not be exposed unless it's
really necessary.
- - - - -
c39b3472 by Duncan Coutts at 2026-09-13T22:56:00+01:00
In the scheduler, move I/O blocking after deadlock detection
To make deadlock detection effective in the non-threaded RTS when there
are deadlocked threads and other unrelated threads waiting on I/O, we
need to arrange to do deadlock detection before we block in scheduler
to wait on I/O.
The solution is to:
1. adjust scheduleFindWork, which runs before deadlock detection, to
only poll for I/O and not block; and
2. add a step after deadlock detection to wait on I/O if there are
still no threads to run (and there's any I/O or timeouts outstanding)
The scheduleCheckBlockedThreads is now so simple that it made more sense
to inline it into scheduleFindWork.
- - - - -
08ab9618 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Remove bogus anyPendingTimeoutsOrIO guard from scheduleDetectDeadlock
The deadlock detection was only invoked if both of these conditions
hold:
1. the run queue is empty
2. there is no pending I/O or timeouts
The second condition is unnecessary. The deadlock detection mechanism
can find deadlocks even if there are other threads waiting on I/O or
timers. Having this extra condition means that we fail to detect
blocked threads if there are any threads waiting on I/O or timers.
Part of fixing issue #26408
- - - - -
c53825b0 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Don't consider pending I/O for early context switch optimisation
Context switches are normally initiated by the timer signal. If however
the user specifies "context switch as often as possible", with +RTS -C0
then the scheduler arranges for an early context switch (when it's just
about to run a Haskell thread).
Context switching very often is expensive, so as an optimisation there
cases where we do not arrange an early context switch:
1. if there's no other threads to run
2. if there is no pending I/O or timers
This patch eliminates case 2, leaving only case 1.
The rationale is as follows. The use of this was inconsistent across
platforms and threaded/non-threaded RTS ways. It only worked on the
non-threaded RTS and on Windows only worked for the win32-legacy I/O
manager. On all other combinations anyPendingTimeoutsOrIO would always
return false. The fact that nobody noticed and complained about this
inconsistency suggests that the feature is not relied upon.
If however it turns out that applications do rely on this, then the
proper thing to do is not to restore this check, but to add a new I/O
manager hint function that returns if there is any pending events that
are likely to happen *soon*: for example timeouts expiring within one
timeslice, or I/O waits on things likely to complete soon like disk I/O,
but not for example socket/pipe I/O.
The motivation to avoid this use of anyPendingTimeoutsOrIO is to
allow us to eliminate anyPendingTimeoutsOrIO entirely. All other uses
of this are just guards on {await,poll}CompletedTimeoutsOrIO and
the guards can safely be folded into those functions. This will better
cope with some I/O managers having no proper implementation of
anyPendingTimeoutsOrIO.
Ultimately this will let us simplify the scheduler which currently has
to have special #ifdef mingw32_HOST_OS cases to cope with the lack of a
working anyPendingTimeoutsOrIO for some Windows I/O managers
- - - - -
c194dbdc by Duncan Coutts at 2026-09-13T22:56:00+01:00
Remove anyPendingTimeoutsOrIO guarding {poll,await}CompletedTimeoutsOrIO
Previously the API of the I/O manager used a two step process: check
anyPendingTimeoutsOrIO and then call {poll,await}CompletedTimeoutsOrIO.
This was primarily there as a performance thing, to cheaply check if we
need to do anything.
And then because anyPendingTimeoutsOrIO existed, it was used for other
things too. We have now eliminated the other uses, and are just left
with the performance pattern.
But this was problematic because not all I/O managers correctly
implement anyPendingTimeoutsOrIO (specifically the win32 ones), and now
that we also make I/O managers responsible for signals then we need to
poll/await even if there is no pending I/O or timeouts. If there is no
pending I/O or timeouts then await needs to degenerate to just waiting
forever for any signals.
- - - - -
8a2963c0 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Remove anyPendingTimeoutsOrIO, it is no longer used
And this avoids the problems arising from the win32 I/O managers having
had a bogus implementation.
- - - - -
d3b6a429 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Remove second scheduler call to awaitCompletedTimeoutsOrIO
Previously awaitCompletedTimeoutsOrIO was called both before and after
deadlock detection in the scheduler. The reason for that was that the
win32 I/O managers had a bogus implementation of anyPendingTimeoutsOrIO
and this was used to guard the call of awaitCompletedTimeoutsOrIO prior
to deadlock detection. This meant the first call site was never actually
called when using the win32 I/O managers. This was the reason for the
second call: the first one was never used. What a mess.
So now we have a simple design in the scheduler:
1. poll for completed I/O, timers or signals
2. if no runnable threads: do deadlock detection
3. if still no runnable threads: block waiting for I/O, timers or
signals.
- - - - -
c3afe473 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Lift emptyRunQueue guard out of scheduleDetectDeadlock
this improved the clarity of the logic when reading the scheduler code.
- - - - -
498ada58 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Make non-threaded deadlock detection also rely on idle GC
Only do deadlock detection GC when idle GC kicks in. This also relies on
using wakeUpRts, so now do this unconditionally. Previously wakeUpRts
was for the threaded rts only.
- - - - -
df7b9ead by Duncan Coutts at 2026-09-13T22:56:00+01:00
Enable idle GC by default on non-threaded RTS
The behaviour is now uniform between the threaded and non-threaded RTS
ways. The deadlock detection now relies on idle GC for both threaded
and non-threaded ways. Previously deadlock detection did not rely on
idle GC for the non-threaded way.
Also tweak test T7275 to account for idle GC. This test's output is
sensitive to the number of major GCs run. Since this commit enables idle
GC for the non-threaded RTS, for this test that increases the number of
major GCs, since the test program is frequently idle for more than 300ms.
- - - - -
d41dd174 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Fix state of idle GC control vars with +RTS -V0
Currently when the user uses +RTS -I0, then doIdleGC is set to false.
But if the master tick interval -V is set to 0 then the idleGCDelayTime
was being set to 0 but doIdleGC was not being set to false, which is
inconsistent, and almost certainly buggy.
- - - - -
596ddecb by Duncan Coutts at 2026-09-13T22:56:00+01:00
Add a long Note [Deadlock detection]
It describes the historical and modern designs and their trade-offs.
The point is we've now unified the code for deadlock detection between
the threaded and non-threaded ways, by changing the non-threaded to
follow the same design as the threaded.
- - - - -
21699497 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Add a test for deadlock detection, issue #26408
- - - - -
4423cc6e by Duncan Coutts at 2026-09-13T22:56:00+01:00
Update the user guide with the revised idle GC behaviour
i.e. it's now not just for the threaded RTS, but general.
Also document the fact that disabling idle GC also disables deadlock
detection.
And add a changelog entry.
- - - - -
47bf6704 by Duncan Coutts at 2026-09-13T22:56:00+01:00
Move idle GC tracking to its own file, step 1 of 2
Add a new IdleGC.{c,h} module. Move the RecentActivity type,
recent_activity variable and {get,set}RecentActivity wrappers.
- - - - -
c7ae301d by Duncan Coutts at 2026-09-13T22:56:00+01:00
Move idle GC functionality to its own file, step 2 of 2
We can now fully encapsulate the recent_activity state, exposing just
three hooks, and one query used in the scheduler and timer tick.
This is a prelude to making changes to the implementation of tracking
when to perform an idle gc.
- - - - -
74c8aefc by Duncan Coutts at 2026-09-14T16:18:17+01:00
Add idle GC mode for !HAVE_PREEMPTION
We have to do idle GC (and thus deadlock detection) differently when we
do not have the ticker and the ability to interrupt the I/O manager
when it's blocking.
- - - - -
277 changed files:
- + changelog.d/27556
- + changelog.d/27627
- + changelog.d/27703
- + changelog.d/27704
- + changelog.d/27717
- + changelog.d/T27744
- + changelog.d/T27749
- + changelog.d/T27764
- + changelog.d/allow-gadt-prefix-con-parens
- + changelog.d/fix-parallel-gc-selector-race-27477
- + changelog.d/idle-gc-and-deadlock-detection
- + changelog.d/implicit-field-strictness-warning
- changelog.d/lazy-field-annotations
- + changelog.d/llvm-23
- + changelog.d/ncg-x86-bit-test-instructions
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Main/Compile.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Doc.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension/Pass.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/Tickish.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Type.hs
- configure.ac
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/exts/strict.rst
- docs/users_guide/runtime_control.rst
- docs/users_guide/using-warnings.rst
- hadrian/src/Base.hs
- hadrian/src/Builder.hs
- hadrian/src/Hadrian/Builder.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Oracles/Path.hs
- hadrian/src/Hadrian/Utilities.hs
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/Changelog.hs
- hadrian/src/Rules/Codes.hs
- hadrian/src/Rules/Lint.hs
- hadrian/src/Rules/Nofib.hs
- hadrian/src/Rules/Test.hs
- libraries/base/tests/all.T
- libraries/ghc-internal/include/RtsIfaceSymbols.h
- libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs
- libraries/stm
- m4/find_python.m4
- + m4/fp_canonicalise_win_path.m4
- m4/fp_find_nm.m4
- m4/fp_find_root.m4
- m4/fp_prog_ar.m4
- m4/fp_prog_ar_args.m4
- m4/fp_prog_sh.m4
- m4/fptools_alex.m4
- m4/fptools_happy.m4
- rts/Capability.c
- rts/Continuation.c
- rts/HeapStackCheck.cmm
- rts/IOManager.c
- rts/IOManager.h
- rts/IOManagerInternals.h
- + rts/IdleGC.c
- + rts/IdleGC.h
- rts/Interpreter.c
- rts/Linker.c
- rts/Messages.c
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/Printer.c
- rts/ProfHeap.c
- rts/RtsFlags.c
- rts/RtsSignals.h
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/STM.c
- rts/Schedule.c
- rts/Schedule.h
- rts/Sparks.c
- rts/StableName.c
- rts/ThreadPaused.c
- rts/Threads.c
- rts/Timer.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/include/rts/RtsToHsIface.h
- rts/include/stg/MiscClosures.h
- rts/posix/Poll.c
- rts/posix/Poll.h
- rts/posix/Select.c
- rts/posix/Signals.c
- − rts/posix/Signals.h
- rts/posix/Timeout.c
- rts/posix/Timeout.h
- rts/prim/atomic.c
- rts/rts.cabal
- rts/sm/Compact.c
- rts/sm/Evac.c
- rts/sm/GC.c
- rts/sm/GCUtils.c
- rts/sm/MBlock.c
- rts/sm/NonMoving.c
- rts/sm/NonMovingMark.c
- rts/sm/Storage.c
- rts/sm/Sweep.c
- rts/win32/AwaitEvent.c
- rts/win32/ConsoleHandler.c
- rts/win32/ConsoleHandler.h
- testsuite/driver/README.md
- testsuite/driver/testlib.py
- + testsuite/tests/bytecode/T27633/Obj.hs
- + testsuite/tests/bytecode/T27633/T27633a.hs
- + testsuite/tests/bytecode/T27633/T27633a.stdout
- + testsuite/tests/bytecode/T27633/T27633b.hs
- + testsuite/tests/bytecode/T27633/T27633b.stdout
- + testsuite/tests/bytecode/T27633/all.T
- + testsuite/tests/codeGen/should_gen_asm/T25233.asm
- + testsuite/tests/codeGen/should_gen_asm/T25233.hs
- + testsuite/tests/codeGen/should_gen_asm/T25233b.asm
- + testsuite/tests/codeGen/should_gen_asm/T25233b.cmm
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/core-to-stg/T27627/Callee.hs
- + testsuite/tests/core-to-stg/T27627/Caller.hs
- + testsuite/tests/core-to-stg/T27627/Main.hs
- + testsuite/tests/core-to-stg/T27627/T27627.stdout
- + testsuite/tests/core-to-stg/T27627/all.T
- + testsuite/tests/core-to-stg/T27627a/Callee.hs
- + testsuite/tests/core-to-stg/T27627a/Caller.hs
- + testsuite/tests/core-to-stg/T27627a/Main.hs
- + testsuite/tests/core-to-stg/T27627a/T27627a.stdout
- + testsuite/tests/core-to-stg/T27627a/all.T
- + testsuite/tests/core-to-stg/T27627b/Callee.hs
- + testsuite/tests/core-to-stg/T27627b/Caller.hs
- + testsuite/tests/core-to-stg/T27627b/Main.hs
- + testsuite/tests/core-to-stg/T27627b/T27627b.stdout
- + testsuite/tests/core-to-stg/T27627b/all.T
- + testsuite/tests/core-to-stg/T27627c/Callee.hs
- + testsuite/tests/core-to-stg/T27627c/Caller.hs
- + testsuite/tests/core-to-stg/T27627c/Main.hs
- + testsuite/tests/core-to-stg/T27627c/T27627c.stdout
- + testsuite/tests/core-to-stg/T27627c/all.T
- + testsuite/tests/core-to-stg/T27627e.hs
- + testsuite/tests/core-to-stg/T27627e.stdout
- + testsuite/tests/core-to-stg/T27627f/Callee.hs
- + testsuite/tests/core-to-stg/T27627f/Caller.hs
- + testsuite/tests/core-to-stg/T27627f/Inst.hs
- + testsuite/tests/core-to-stg/T27627f/Main.hs
- + testsuite/tests/core-to-stg/T27627f/T27627f.stdout
- + testsuite/tests/core-to-stg/T27627f/all.T
- + testsuite/tests/core-to-stg/T27704/Callee.hs
- + testsuite/tests/core-to-stg/T27704/Callee.hs-boot
- + testsuite/tests/core-to-stg/T27704/Main.hs
- + testsuite/tests/core-to-stg/T27704/Mid.hs
- + testsuite/tests/core-to-stg/T27704/T27704.stdout
- + testsuite/tests/core-to-stg/T27704/all.T
- + testsuite/tests/core-to-stg/T27704a/Callee.hs
- + testsuite/tests/core-to-stg/T27704a/Callee.hs-boot
- + testsuite/tests/core-to-stg/T27704a/Main.hs
- + testsuite/tests/core-to-stg/T27704a/Mid.hs
- + testsuite/tests/core-to-stg/T27704a/T27704a.stdout
- + testsuite/tests/core-to-stg/T27704a/all.T
- + testsuite/tests/core-to-stg/T27717/Callee.hs
- + testsuite/tests/core-to-stg/T27717/Callee.hs-boot
- + testsuite/tests/core-to-stg/T27717/Main.hs
- + testsuite/tests/core-to-stg/T27717/Mid.hs
- + testsuite/tests/core-to-stg/T27717/T27717.stdout
- + testsuite/tests/core-to-stg/T27717/Ty.hs
- + testsuite/tests/core-to-stg/T27717/all.T
- testsuite/tests/core-to-stg/all.T
- testsuite/tests/ffi/should_run/T21305.hs
- − testsuite/tests/gadt/T14320.stderr
- testsuite/tests/gadt/T18191.hs
- testsuite/tests/gadt/T18191.stderr
- + testsuite/tests/gadt/T27423a.hs
- + testsuite/tests/gadt/T27423b.hs
- + testsuite/tests/gadt/T27423b.stderr
- testsuite/tests/gadt/all.T
- + testsuite/tests/ghci.debugger/scripts/T27633c.hs
- + testsuite/tests/ghci.debugger/scripts/T27633c.script
- + testsuite/tests/ghci.debugger/scripts/T27633c.stdout
- + testsuite/tests/ghci.debugger/scripts/T27633c_obj.hs
- testsuite/tests/ghci.debugger/scripts/all.T
- + testsuite/tests/patsyn/should_compile/T27744.hs
- testsuite/tests/patsyn/should_compile/all.T
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/perf/compiler/large-project/all.T
- testsuite/tests/perf/should_run/T3586.hs
- testsuite/tests/perf/should_run/T3586.stdout
- testsuite/tests/perf/space_leaks/all.T
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/T27423c.hs
- testsuite/tests/printer/all.T
- testsuite/tests/profiling/should_run/Makefile
- testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr
- testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr
- testsuite/tests/rename/should_fail/T26545.stderr
- + testsuite/tests/rts/T26408.hs
- + testsuite/tests/rts/T26408.stderr
- + testsuite/tests/rts/T27477.hs
- + testsuite/tests/rts/T27477.stdout
- testsuite/tests/rts/all.T
- testsuite/tests/simplCore/should_compile/T17966.stderr
- + testsuite/tests/simplCore/should_compile/T27556.hs
- + testsuite/tests/simplCore/should_compile/T27556.script
- + testsuite/tests/simplCore/should_compile/T27749.hs
- + testsuite/tests/simplCore/should_compile/T27749.stderr
- testsuite/tests/simplCore/should_compile/T7785.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_compile/spec004.hs
- testsuite/tests/simplCore/should_compile/spec004.stderr
- + testsuite/tests/simplCore/should_run/T27703/Lib.hs
- + testsuite/tests/simplCore/should_run/T27703/Main.hs
- + testsuite/tests/simplCore/should_run/T27703/T27703.stdout
- + testsuite/tests/simplCore/should_run/T27703/all.T
- testsuite/tests/th/T17380.stderr
- testsuite/tests/th/T18612.stderr
- + testsuite/tests/th/T27034.hs
- + testsuite/tests/th/T27034.stderr
- testsuite/tests/th/T8761.stderr
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_compile/T27664.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/warnings/should_compile/T16836a.hs
- + testsuite/tests/warnings/should_compile/T16836a.stderr
- + testsuite/tests/warnings/should_compile/T16836b.hs
- + testsuite/tests/warnings/should_compile/T16836c.hs
- + testsuite/tests/warnings/should_compile/T16836c.stderr
- + testsuite/tests/warnings/should_compile/T16836d.hs
- + testsuite/tests/warnings/should_compile/T16836d.stderr
- testsuite/tests/warnings/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/deriveConstants/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3f31b3679ae1cc600189f1c99bea5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e3f31b3679ae1cc600189f1c99bea5…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
[Git][ghc/ghc] Pushed new branch wip/io-manager-deadlock-detection_wasm-hacking
by David Eichmann (＠DavidEichmann) 14 Sep '26
by David Eichmann (＠DavidEichmann) 14 Sep '26
14 Sep '26
David Eichmann pushed new branch wip/io-manager-deadlock-detection_wasm-hacking at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/io-manager-deadlock-detection…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0
Apoorv Ingle pushed to branch wip/ani/hackage-test at Glasgow Haskell Compiler / GHC
Commits:
7fa4a3d8 by Apoorv Ingle at 2026-09-14T08:44:49-06:00
Edit 27156.md
- - - - -
1 changed file:
- changelog.d/27156.md
Changes:
=====================================
changelog.d/27156.md
=====================================
@@ -1,5 +1,5 @@
section: compiler
issues: #27156
-mrs: !15868
+mrs: !16685
synopsis: Test MR, not to be merged
description: check which hackage packages fail with HEAD
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fa4a3d81213df71f5ba290393a93a2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fa4a3d81213df71f5ba290393a93a2…
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help
1
0