- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/io-manager-deadlock-detection_wasm-hacking
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

[Git][ghc/ghc][wip/ani/hackage-test] Edit 27156.md
by Apoorv Ingle (＠ani) 14 Sep '26

14 Sep '26

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

[Git][ghc/ghc][wip/ani/hackage-test] Add new change.d file
by Apoorv Ingle (＠ani) 14 Sep '26

14 Sep '26

Apoorv Ingle pushed to branch wip/ani/hackage-test at Glasgow Haskell Compiler / GHC Commits: 3480646b by Apoorv Ingle at 2026-09-14T08:38:11-06:00 Add new change.d file - - - - - 1 changed file: - + changelog.d/27156.md Changes: ===================================== changelog.d/27156.md ===================================== @@ -0,0 +1,5 @@ +section: compiler +issues: #27156 +mrs: !15868 +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/3480646b817478ca81a2634d9099331… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3480646b817478ca81a2634d9099331… 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/ani/hackage-test
by Apoorv Ingle (＠ani) 14 Sep '26

14 Sep '26

Apoorv Ingle pushed new branch wip/ani/hackage-test at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ani/hackage-test 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/jeltsch/improve-closure-property-check] Change the implementation of `collect` so that it uses `concatMapM`
by Wolfgang Jeltsch (＠jeltsch) 14 Sep '26

14 Sep '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC Commits: 002c2052 by Wolfgang Jeltsch at 2026-09-14T17:01:35+03:00 Change the implementation of `collect` so that it uses `concatMapM` - - - - - 1 changed file: - compiler/GHC/Driver/Downsweep.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs import GHC.Utils.Constants +import GHC.Utils.Monad (concatMapM) import GHC.Utils.Monad.State.Strict import GHC.Types.Error @@ -983,13 +984,10 @@ checkHomeUnitsClosed unit_env -- that have not yet been found, using its state to keep track -- of which units have already been considered as sources of -- offending dependencies. - collect [] - = pure [] - collect (current_unit_state : remaining_unit_states) - = (++) <$> collect_for_home_unit - (unitInfoMap current_unit_state) - (map (toUnitId . fst) $ explicitUnits $ current_unit_state) - <*> collect remaining_unit_states + collect = concatMapM $ \ unit_state -> + collect_for_home_unit + (unitInfoMap unit_state) + (map (toUnitId . fst) $ explicitUnits $ unit_state) where -- | Collects offending dependencies that are reachable from a particular View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/002c20528a7b1994927f8e13c074cc4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/002c20528a7b1994927f8e13c074cc4… 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/ani/T27156] wibbles
by Apoorv Ingle (＠ani) 14 Sep '26

14 Sep '26

Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: bb7d52fd by Apoorv Ingle at 2026-09-14T08:57:11-05:00 wibbles - - - - - 1 changed file: - compiler/GHC/Tc/Gen/Expr.hs Changes: ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -595,7 +595,7 @@ tcExprNoExpand (HsProc x pat cmd) res_ty -- and wrap (static e) in a call to -- fromStaticPtr :: IsStatic p => StaticPtr a -> p a -tcExprNoExpand (HsStatic _ expr) res_ty +tcExprNoExpand (HsStatic free_names expr) res_ty = do { res_ty <- expTypeToType res_ty ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty ; (expr', lie) <- captureConstraints $ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb7d52fd6397872f27a99b8dd7414d2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb7d52fd6397872f27a99b8dd7414d2… 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) 14 Sep '26

14 Sep '26

Andreas Klebinger pushed to branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC Commits: 0df4842a by Andreas Klebinger at 2026-09-14T13:47:32+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 market but 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, lengthAtLeast, 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 then write `LitNumType` into it's own tag byte we encode it in the +surplace space of the `Literal` tag space. + +This means for `Literal` tage 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,279 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- 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/0df4842a4a4b64a20e0be97b2c5c8ac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0df4842a4a4b64a20e0be97b2c5c8ac… 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/apk/expose-overloaded-unfoldings
by Andreas Klebinger (＠AndreasK) 14 Sep '26

14 Sep '26

Andreas Klebinger pushed new branch wip/apk/expose-overloaded-unfoldings at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/apk/expose-overloaded-unfoldi… 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/jeltsch/improve-closure-property-check] Change the style of the `offenders` definition
by Wolfgang Jeltsch (＠jeltsch) 14 Sep '26

14 Sep '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC Commits: a82f16fe by Wolfgang Jeltsch at 2026-09-14T16:08:58+03:00 Change the style of the `offenders` definition - - - - - 1 changed file: - compiler/GHC/Driver/Downsweep.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -970,8 +970,8 @@ checkHomeUnitsClosed unit_env -- by the pair of the 'UnitId' of /u/ and the 'UnitId' of /v/. offenders :: [(UnitId, UnitId)] offenders - = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data)) $ - Set.empty + = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data)) + Set.empty where -- | Collects offending dependencies. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a82f16fe564fe8e5c1ce8629a003419… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a82f16fe564fe8e5c1ce8629a003419… 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/jeltsch/improve-closure-property-check] Improved and correct the doc comment of `checkHomeUnitsClosed`
by Wolfgang Jeltsch (＠jeltsch) 14 Sep '26

14 Sep '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC Commits: 53be1a6d by Wolfgang Jeltsch at 2026-09-14T16:03:38+03:00 Improved and correct the doc comment of `checkHomeUnitsClosed` - - - - - 1 changed file: - compiler/GHC/Driver/Downsweep.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -942,9 +942,10 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do -- | Checks whether the given 'UnitEnv' has the closure property. -- -- See the section “Closure Property” in @Note [Multiple Home Units]@ for the --- definition of the closure property an @Note [Home unit closure property --- check]@ below for a discussion of the algorithm used for this check, its --- justification, and a potential alternative. +-- definition of the closure property and +-- @Note [Home unit closure property check]@ below for a discussion of the +-- algorithm used for this check, its justification, and a potential +-- alternative. checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] checkHomeUnitsClosed unit_env | null offenders = [] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53be1a6d2d8ffc541ef6b019f6cac8e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53be1a6d2d8ffc541ef6b019f6cac8e… 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