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
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
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
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
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
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
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
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
14 Sep '26
Andreas Klebinger pushed new branch wip/apk/iface-encoding at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/apk/iface-encoding
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/marge_bot_batch_merge_job] 4 commits: FastString: Drop mkFastStringWith's constructor callback
by Marge Bot (＠marge-bot) 14 Sep '26
by Marge Bot (＠marge-bot) 14 Sep '26
14 Sep '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
7a108e43 by Simon Jakobi at 2026-09-12T18:35:59-04:00
FastString: Drop mkFastStringWith's constructor callback
All three callers passed the same callback, a partial application of
mkNewFastStringShortByteString to the string being interned. That
partial application is allocated as a closure before the table lookup,
on the common hit path too, although the callback is needed only after
a miss.
Drop the parameter and call mkNewFastStringShortByteString directly
after a miss. Since nothing is passed "with" anymore, rename the
function to internSB.
Suggested by Simon PJ in #27528:
https://gitlab.haskell.org/ghc/ghc/-/work_items/27528#note_687031
Assisted-by: Claude Fable 5
- - - - -
82c73b22 by Alan Zimmerman at 2026-09-12T18:36:38-04:00
EPA: More targeted HsDo exact print annotation
HsDo is multi-purpose, as encoded in its HsDoFlavour field. Some of
these are in a layout context (DoExpr, MDoExpr), others are not
(ListComp, MonadComp).
We are moving towards using AnnList only in layout contexts, so we
switch the HsDo TTG annotation from holding an AnnList for this, to
holding
Either (EpToken "[", EpToken "]") AnnList
This also allows us to trim down AnnListBrackets to only have braces
or None, thereby opening the door for unification with the existing
layout context data type EpLayout.
- - - - -
de75a9e9 by Luite Stegeman at 2026-09-14T10:12:51+02:00
rts: make stg_threadLabelzh return a valid pointer for unlabeled threads.
This fixes a segfault in the GC caused by stg_threadLabelzh returning
a 0 pointer in a GC pointer field.
stg_threadLabelzh returns a tuple of type (# Int#, ByteArray# #). If a
thread has no label, the second field is unused. We must still return
a valid heap object pointer.
Instead of returning 0, we now return stg_DEAD_SLOT_closure.
fixes #27618
- - - - -
3b1f7b57 by Luite Stegeman at 2026-09-14T08:19:42-04:00
rts: initialise the stack frame header for mask_frame and apply_mask_frame
We must leave the stack in consistent state before jumping to
mask_frame or apply_mask_frame because they may result. Failing
to do so could lead to a crash if there were waiting exceptions.
Fixes #27651
- - - - -
23 changed files:
- + changelog.d/fix-control0-mask-trampoline
- + changelog.d/fix-threadlabel-segfault-27618
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- rts/ContinuationOps.cmm
- rts/PrimOps.cmm
- rts/StgMiscClosures.cmm
- rts/include/stg/MiscClosures.h
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test20297.stdout
- + testsuite/tests/rts/T27618.hs
- + testsuite/tests/rts/T27618.stdout
- testsuite/tests/rts/all.T
- + testsuite/tests/rts/continuations/T27651.hs
- + testsuite/tests/rts/continuations/T27651.stdout
- testsuite/tests/rts/continuations/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
changelog.d/fix-control0-mask-trampoline
=====================================
@@ -0,0 +1,13 @@
+section: rts
+synopsis: Fix a crash when capturing or resuming a delimited continuation that adjusts the async exception masking state
+issues: #27651
+mrs: !16484
+
+description: {
+Capturing a continuation with ``control0#`` from inside ``mask`` or
+``uninterruptibleMask`` left an uninitialised word on the stack while
+restoring the masking state. When the thread had a pending asynchronous
+exception (e.g. from ``throwTo``), raising it walked over that word and
+crashed with a segmentation fault. Resuming such a continuation had the
+same defect.
+}
=====================================
changelog.d/fix-threadlabel-segfault-27618
=====================================
@@ -0,0 +1,10 @@
+section: rts
+synopsis: Fix a segfault that could occur when querying the label of an
+ unlabeled thread.
+issues: #27618
+mrs: !16468
+description: {
+ The ``threadLabel#`` primop returned a null pointer in the ``ByteArray#``
+ field of its result for threads that have no label. This could lead to a
+ crash during garbage collection.
+}
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -320,7 +320,7 @@ data FastStringTable = FastStringTable
-- ^ Number of computed z-encodings for all buckets.
--
-- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk
- -- in 'mkFastStringWith' and needs to be boxed any way.
+ -- in 'internSB' and needs to be boxed any way.
-- If this is unpacked, then we box this single 'FastMutInt' once for each
-- allocated FastString.
(Array# (IORef FastStringTableSegment)) -- ^ concurrent segments
@@ -474,9 +474,10 @@ The procedure goes like this:
* Otherwise, insert and return the string we created.
-}
-mkFastStringWith
- :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString
-mkFastStringWith mk_fs sbs = do
+-- | Return the interned 'FastString' for the given bytes, creating and
+-- inserting one on a table miss.
+internSB :: ShortByteString -> IO FastString
+internSB sbs = do
FastStringTableSegment lock _ buckets# <- readIORef segmentRef
let idx# = hashToIndex# buckets# hash#
bucket <- IO $ readArray# buckets# idx#
@@ -487,7 +488,7 @@ mkFastStringWith mk_fs sbs = do
-- only run partially and putMVar is not called after takeMVar.
noDuplicate
n <- get_uid
- new_fs <- mk_fs n n_zencs
+ new_fs <- mkNewFastStringShortByteString sbs n n_zencs
withMVar lock $ \_ -> insert new_fs
where
!(FastStringTable uid n_zencs segments#) = stringTable
@@ -523,11 +524,11 @@ bucket_match fs sbs = go fs
mkFastStringBytes :: Ptr Word8 -> Int -> FastString
mkFastStringBytes !ptr !len =
- -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is
+ -- NB: Might as well use unsafeDupablePerformIO, since internSB is
-- idempotent.
unsafeDupablePerformIO $ do
sbs <- newSBSFromPtr ptr len
- mkFastStringWith (mkNewFastStringShortByteString sbs) sbs
+ internSB sbs
newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString
newSBSFromPtr (Ptr src#) (I# len#) =
@@ -541,14 +542,13 @@ newSBSFromPtr (Ptr src#) (I# len#) =
mkFastStringByteString :: ByteString -> FastString
mkFastStringByteString bs =
let sbs = SBS.toShort bs in
- inlinePerformIO $
- mkFastStringWith (mkNewFastStringShortByteString sbs) sbs
+ inlinePerformIO $ internSB sbs
-- | Create a 'FastString' from an existing 'ShortByteString' without
-- copying.
mkFastStringShortByteString :: ShortByteString -> FastString
mkFastStringShortByteString sbs =
- inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs
+ inlinePerformIO $ internSB sbs
-- | Create a 'FastString' from an 'HText'
mkFastStringShortText :: ShortText -> FastString
@@ -560,7 +560,7 @@ mkFastString :: String -> FastString
mkFastString str =
inlinePerformIO $ do
let !sbs = utf8EncodeShortByteString str
- mkFastStringWith (mkNewFastStringShortByteString sbs) sbs
+ internSB sbs
-- The following rule is used to avoid polluting the non-reclaimable FastString
-- table with transient strings when we only want their encoding.
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -290,10 +290,12 @@ type instance XLet GhcPs = (EpToken "let", EpToken "in")
type instance XLet GhcRn = NoExtField
type instance XLet GhcTc = NoExtField
-type instance XDo GhcPs = (AnnList, EpaLocation)
+type instance XDo GhcPs = DoAnn
type instance XDo GhcRn = NoExtField
type instance XDo GhcTc = Type
+type DoAnn = (Either (EpToken "[", EpToken "]") AnnList, EpaLocation)
+
type instance XExplicitList GhcPs = (EpToken "[", EpToken "]")
type instance XExplicitList GhcRn = NoExtField
type instance XExplicitList GhcTc = Type
@@ -1467,7 +1469,7 @@ type instance XCmdLet GhcPs = (EpToken "let", EpToken "in")
type instance XCmdLet GhcRn = NoExtField
type instance XCmdLet GhcTc = NoExtField
-type instance XCmdDo GhcPs = (AnnList, EpaLocation)
+type instance XCmdDo GhcPs = DoAnn
type instance XCmdDo GhcRn = NoExtField
type instance XCmdDo GhcTc = Type
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -335,11 +335,10 @@ mkHsIntegral :: IntegralLit GhcPs -> HsOverLit GhcPs
mkHsFractional :: FractionalLit GhcPs -> HsOverLit GhcPs
mkHsIsString :: SourceText -> HText -> HsOverLit GhcPs
mkHsDo :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> (AnnList, EpaLocation) -> HsExpr GhcPs
+mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> DoAnn -> HsExpr GhcPs
mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
-mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
- -> (AnnList, EpaLocation)
+mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> DoAnn
-> HsExpr GhcPs
mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-"
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3152,19 +3152,15 @@ aexp :: { ECP }
return $ ECP $
$2 >>= \ $2 ->
mkHsDoPV (comb2 $1 $2)
- (stmtlistAnns $2)
+ (Right $ stmtlistAnns $2, glR $1)
(fmap mkModuleNameFS (getDO $1))
- (stmtlistStmts $2)
- (glR $1)
- (glR $2) }
+ (stmtlistStmts $2) }
| MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->
fmap ecpFromExp $
amsA' (L (comb2 $1 $2)
- (mkMDo (stmtlistAnns $2)
- (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
- (stmtlistStmts $2)
- (glR $1)
- (glR $2))) }
+ (mkHsDoAnns (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
+ (stmtlistStmts $2)
+ (Right $ stmtlistAnns $2, glR $1))) }
| 'proc' aexp '->' exp
{% (checkPattern <=< runPV) (unECP $2) >>= \ p ->
runPV (unECP $4) >>= \ $4@cmd ->
@@ -3440,7 +3436,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (
{ \loc (ao,ac) ->
checkMonadComp >>= \ ctxt ->
unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (epTok $2)
- ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [], noAnn))
+ ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (Left $ (EpTok ao, EpTok ac), noAnn))
>>= ecpFromExp' } }
lexps :: { forall b. DisambECP b => PV [LocatedA b] }
@@ -3658,11 +3654,13 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) }
-----------------------------------------------------------------------------
-- Statement sequences
-stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), Located [LocatedA (Stmt GhcPs (LocatedA b))])) }
+stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) }
: '{' stmts '}' { $2 >>= \ $2 ->
- amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), sL1 $2 $ reverse $ snd $ unLoc $2))}
+ amsA' (sLL $1 $> (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2)
+ , sL1 $2 $ reverse $ snd $ unLoc $2))}
| vocurly stmts close { $2 >>= \ $2 ->
- amsA' (L (stmtsLoc $2) ((noEpTok, fromOL $ fst $ unLoc $2, noEpTok), sL1 $2 $ reverse $ snd $ unLoc $2))}
+ amsA' (L (stmtsLoc $2) (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2)
+ , sL1 $2 $ reverse $ snd $ unLoc $2))}
-- do { ;; s ; s ; ; s ;; }
-- The last Stmt should be an expression, but that's hard to enforce
@@ -3704,7 +3702,7 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: qual { $1 }
| 'rec' stmtlist { $2 >>= \ $2 ->
- amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2)
+ amsA' (sLL $1 $> $ mkRecStmt (stmtlistAnns $2, epTok $1)
(stmtlistStmts $2)) }
qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
@@ -4724,10 +4722,6 @@ commentsPA la@(L l a) = do
!cs <- getPriorCommentsFor (getLocA la)
return (L (addCommentsToEpAnn l cs) a)
-hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> (AnnList, EpToken "rec")
-hsDoAnn rec (ob, semis, cb) (L ll _)
- = (AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis, rec)
-
listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation
listAsAnchorM [] = Nothing
listAsAnchorM (L l _:_) =
@@ -4757,8 +4751,7 @@ stmtlistStmts :: LocatedA (a, Located [LocatedA (Stmt GhcPs (LocatedA b))])
stmtlistStmts (L la (_,L l stmts))
= L ((noAnnSrcSpan l) {comments = comments la}) stmts
-stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a)
- -> (EpToken "{", [EpToken ";"], EpToken "}")
+stmtlistAnns :: LocatedA (AnnList, a) -> AnnList
stmtlistAnns (L _ (an,_)) = an
-- -------------------------------------
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -519,8 +519,7 @@ data AnnList
} deriving (Data,Eq)
data AnnListBrackets
- = ListBraces (EpToken "{") (EpToken "}")
- | ListSquare (EpToken "[") (EpToken "]")
+ = ListBraces (EpToken "{") (EpToken "}")
| ListNone
deriving (Data,Eq)
@@ -1093,7 +1092,6 @@ instance Outputable AnnList where
instance Outputable AnnListBrackets where
ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c
- ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c
ppr ListNone = text "ListNone"
instance Outputable AnnCType where
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Parser.PostProcess (
mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
- mkHsDo, mkMDo, mkSpliceDecl,
+ mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkDataFamInst,
@@ -435,10 +435,6 @@ mkRoleAnnotDecl loc tycon roles anns
addFatalError $ mkPlainErrorMsgEnvelope loc_role $
(PsErrIllegalRoleName role nearby)
-mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
-mkMDo (ob, semis, cb) ctxt stmts tok loc
- = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis, tok)
-
-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
-- binders without annotations. Only accepts specified variables, and errors if
-- any of the provided binders has an 'InferredSpec' annotation.
@@ -1804,12 +1800,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-> PV (LocatedA b)
-- | Disambiguate "do { ... }" (do notation)
mkHsDoPV ::
- SrcSpan ->
- (EpToken "{", [EpToken ";"], EpToken "}") ->
- Maybe ModuleName ->
- LocatedA [LStmt GhcPs (LocatedA b)] ->
- EpaLocation -> -- Token
- EpaLocation -> -- Anchor
+ SrcSpan -> DoAnn -> Maybe ModuleName -> LocatedA [LStmt GhcPs (LocatedA b)] ->
PV (LocatedA b)
-- | Disambiguate "( ... )" (parentheses)
mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b)
@@ -1959,10 +1950,10 @@ instance DisambECP (HsCmd GhcPs) where
checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)
- mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do
+ mkHsDoPV l ann Nothing stmts = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis, tok_loc) stmts)
- mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo ann stmts)
+ mkHsDoPV l _ (Just m) _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
mkHsParPV l lpar c rpar = do
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)
@@ -2058,9 +2049,9 @@ instance DisambECP (HsExpr GhcPs) where
checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)
- mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do
+ mkHsDoPV l ann mod stmts = do
!cs <- getCommentsFor l
- return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis, loc_tok) (DoExpr mod) stmts)
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo ann (DoExpr mod) stmts)
mkHsParPV l lpar e rpar = do
!cs <- getCommentsFor l
return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)
@@ -2156,7 +2147,7 @@ instance DisambECP (PatBuilder GhcPs) where
!cs <- getCommentsFor (locA l)
return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
- mkHsDoPV l _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
+ mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
=====================================
rts/ContinuationOps.cmm
=====================================
@@ -148,6 +148,7 @@ stg_control0zh_ll // explicit stack
// and jump to the frame’s entry code.
Sp_adj(-3); // Note -3, not -2, because `mask_frame` will
// try to pop itself off the stack when it returns!
+ Sp(0) = mask_frame; // Can't be omitted, see #27651
Sp(1) = stg_ap_pv_info;
Sp(2) = cont;
R1 = f;
@@ -230,6 +231,7 @@ stg_CONTINUATION_apply // explicit stack
// Now we just set up the stack so that `apply_mask_frame` will apply `io`
// when it returns and jump to it.
Sp_adj(-2);
+ Sp(0) = apply_mask_frame; // Can't be omitted, see #27651
Sp(1) = stg_ap_v_info;
R1 = io;
jump %ENTRY_CODE(apply_mask_frame) [R1];
=====================================
rts/PrimOps.cmm
=====================================
@@ -1160,7 +1160,7 @@ stg_threadLabelzh ( gcptr tso )
W_ r;
r = StgTSO_label(tso);
if (r == 0) {
- return (0, 0);
+ return (0, stg_DEAD_SLOT_closure);
} else {
return (1, r);
}
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -726,6 +726,18 @@ INFO_TABLE_CONSTR(stg_NO_FINALIZER,0,0,0,CONSTR_NOCAF,"NO_FINALIZER","NO_FINALIZ
CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER);
+/* ----------------------------------------------------------------------------
+ DEAD_SLOT
+
+ A static nullary constructor for dead pointer-typed result slots
+ that must still hold a valid closure for the GC (see #27618).
+ ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_DEAD_SLOT,0,0,0,CONSTR_NOCAF,"DEAD_SLOT","DEAD_SLOT")
+{ ccall pbarf("DEAD_SLOT object (%p) entered!", R1 "ptr") never returns; }
+
+CLOSURE(stg_DEAD_SLOT_closure,stg_DEAD_SLOT);
+
/* ----------------------------------------------------------------------------
Stable Names are unlifted too.
------------------------------------------------------------------------- */
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -200,6 +200,7 @@ RTS_ENTRY(stg_SRT_16);
RTS_CLOSURE(stg_END_TSO_QUEUE_closure);
RTS_CLOSURE(stg_NO_FINALIZER_closure);
+RTS_CLOSURE(stg_DEAD_SLOT_closure);
RTS_CLOSURE(stg_dummy_ret_closure);
RTS_CLOSURE(stg_forceIO_closure);
RTS_CLOSURE(stg_CLOSURE_TABLE_NULL_closure);
@@ -211,6 +212,7 @@ RTS_CLOSURE(stg_END_STM_CHUNK_LIST_closure);
RTS_CLOSURE(stg_NO_TREC_closure);
RTS_ENTRY(stg_NO_FINALIZER);
+RTS_ENTRY(stg_DEAD_SLOT);
#if IN_STG_CODE
extern StgWordArray stg_CHARLIKE_closure;
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -289,13 +289,12 @@
{ DumpParsedAstComments.hs:14:7-8 }))]))
(HsDo
((,)
- (AnnList
- (Just
- (EpaSpan { DumpParsedAstComments.hs:16:3 }))
- (ListBraces
- (EpTok (EpaSpan { <no location info> }))
- (EpTok (EpaSpan { <no location info> })))
- [])
+ (Right
+ (AnnList
+ (Just
+ (EpaSpan { DumpParsedAstComments.hs:16:3 }))
+ (ListNone)
+ []))
(EpaSpan { DumpParsedAstComments.hs:14:7-8 }))
(DoExpr
(Nothing))
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -331,13 +331,12 @@
[]))
(HsDo
((,)
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
- (ListBraces
- (EpTok (EpaSpan { <no location info> }))
- (EpTok (EpaSpan { <no location info> })))
- [])
+ (Right
+ (AnnList
+ (Just
+ (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
+ (ListNone)
+ []))
(EpaSpan { DumpSemis.hs:10:7-8 }))
(DoExpr
(Nothing))
@@ -363,20 +362,21 @@
[]))
(HsDo
((,)
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:11:6-15 }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
- (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:11:8 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:9 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:10 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:11:11 }))])
+ (Right
+ (AnnList
+ (Just
+ (EpaSpan { DumpSemis.hs:11:8-13 }))
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
+ (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:11:8 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:9 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:10 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:11:11 }))]))
(EpaSpan { DumpSemis.hs:11:3-4 }))
(DoExpr
(Nothing))
@@ -625,16 +625,17 @@
[]))
(HsDo
((,)
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:(16,3)-(19,3) }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
- (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:16:5 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:16:8 }))])
+ (Right
+ (AnnList
+ (Just
+ (EpaSpan { DumpSemis.hs:(16,5)-(18,5) }))
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
+ (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:16:5 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:16:8 }))]))
(EpaSpan { DumpSemis.hs:15:7-8 }))
(DoExpr
(Nothing))
@@ -877,16 +878,17 @@
[]))
(HsDo
((,)
- (AnnList
- (Just
- (EpaSpan { DumpSemis.hs:22:10-30 }))
- (ListBraces
- (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
- (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
- [(EpTok
- (EpaSpan { DumpSemis.hs:22:12 }))
- ,(EpTok
- (EpaSpan { DumpSemis.hs:22:13 }))])
+ (Right
+ (AnnList
+ (Just
+ (EpaSpan { DumpSemis.hs:22:12-28 }))
+ (ListBraces
+ (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
+ (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
+ [(EpTok
+ (EpaSpan { DumpSemis.hs:22:12 }))
+ ,(EpTok
+ (EpaSpan { DumpSemis.hs:22:13 }))]))
(EpaSpan { DumpSemis.hs:22:7-8 }))
(DoExpr
(Nothing))
=====================================
testsuite/tests/printer/Test20297.stdout
=====================================
@@ -394,13 +394,12 @@
[]))
(HsDo
((,)
- (AnnList
- (Just
- (EpaSpan { Test20297.hs:11:22-26 }))
- (ListBraces
- (EpTok (EpaSpan { <no location info> }))
- (EpTok (EpaSpan { <no location info> })))
- [])
+ (Right
+ (AnnList
+ (Just
+ (EpaSpan { Test20297.hs:11:22-26 }))
+ (ListNone)
+ []))
(EpaSpan { Test20297.hs:11:19-20 }))
(DoExpr
(Nothing))
@@ -820,13 +819,12 @@
[]))
(HsDo
((,)
- (AnnList
- (Just
- (EpaSpan { Test20297.ppr.hs:9:20-24 }))
- (ListBraces
- (EpTok (EpaSpan { <no location info> }))
- (EpTok (EpaSpan { <no location info> })))
- [])
+ (Right
+ (AnnList
+ (Just
+ (EpaSpan { Test20297.ppr.hs:9:20-24 }))
+ (ListNone)
+ []))
(EpaSpan { Test20297.ppr.hs:9:17-18 }))
(DoExpr
(Nothing))
=====================================
testsuite/tests/rts/T27618.hs
=====================================
@@ -0,0 +1,39 @@
+{-# LANGUAGE NumericUnderscores #-}
+
+-- Test for a major GC segfault triggered by threadLabel# returning NULL in
+-- a GC pointer field on unlabeled threads. Run with -N4 -A32k.
+
+module Main (main) where
+
+import Control.Concurrent
+import Control.Monad
+import Data.IORef
+import GHC.Conc.Sync (threadLabel)
+import System.Mem (performMajorGC)
+
+{-# NOINLINE queryLabel #-}
+queryLabel :: ThreadId -> IO (Maybe String)
+queryLabel = threadLabel
+
+main :: IO ()
+main = do
+ stop <- newIORef False
+ _ <- forkIO $ forever performMajorGC
+ targets <- replicateM 8 $ forkIO $ forever (threadDelay 1_000_000)
+ dones <- forM [1 :: Int .. 8] $ \_ -> do
+ done <- newEmptyMVar
+ _ <- forkIO $ do
+ let loop = do
+ s <- readIORef stop
+ unless s $ do
+ forM_ targets $ \t -> do
+ r <- queryLabel t
+ r `seq` pure ()
+ loop
+ loop
+ putMVar done ()
+ pure done
+ threadDelay 2_000_000
+ writeIORef stop True
+ mapM_ takeMVar dones
+ putStrLn "done"
=====================================
testsuite/tests/rts/T27618.stdout
=====================================
@@ -0,0 +1 @@
+done
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -729,3 +729,7 @@ test('T27477',
],
compile_and_run, ['-O2'])
+test('T27618',
+ [req_target_smp, omit_ghci],
+ compile_and_run, ['-O2 -threaded -with-rtsopts "-N4 -A32k"'])
+
=====================================
testsuite/tests/rts/continuations/T27651.hs
=====================================
@@ -0,0 +1,91 @@
+-- When capturing or resuming a continuation adjusts the async exception
+-- masking state, the RTS trampolines through a mask/unmask frame, and the
+-- stack must be well-formed at that point: with a blocked exception
+-- pending, the eager raise in stg_unmaskAsyncExceptionszh_ret walks the
+-- whole stack.
+--
+-- Phase 1 exercises the capture side (stg_control0zh_ll): control0# runs
+-- inside uninterruptibleMask_ while another thread has queued an
+-- exception via throwTo, so the capture unmasks with the exception
+-- pending. The frame evaluated between the unmask frame and the prompt
+-- keeps raw Int# payload live so that a stale word on the stack cannot
+-- masquerade as a valid frame by accident.
+--
+-- Phase 2 exercises the resume side (stg_CONTINUATION_apply): the
+-- continuation is captured while unmasked (inside mask/restore), so
+-- resuming it unmasks, and it is applied from a thread that is masked
+-- with an exception pending.
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+
+import ContIO
+
+data Boom = Boom deriving Show
+instance Exception Boom
+
+{-# NOINLINE useInts #-}
+useInts :: Int -> Int -> Int -> Int -> Int -> Int
+useInts a b c d e = a + b * c + d * e
+
+rounds :: Int
+rounds = 150
+
+phase1 :: Int -> IO ()
+phase1 i = do
+ mv <- newEmptyMVar
+ done <- newEmptyMVar
+ let !p = i * 7919 + 3 -- raw ints to live in the continuation frame
+ !q = i * 104729 + 7
+ !u = i * 1299709 + 11
+ !v = i * 15485863 + 13
+ a <- forkIO $
+ handle (\Boom -> void (tryPutMVar done (Left Boom))) $ do
+ tag <- newPromptTag
+ r <- prompt tag $ do
+ x <- uninterruptibleMask_ $ do
+ putMVar mv ()
+ threadDelay 2000 -- let the thrower queue its exception
+ control0 tag (\_k -> pure (42 :: Int))
+ -- continuation frame between the unmask frame and the
+ -- prompt frame, carrying raw Int# payload:
+ pure (useInts x p q u v)
+ void (tryPutMVar done (Right r))
+ takeMVar mv
+ _ <- forkIO $ throwTo a Boom
+ void (takeMVar done)
+
+phase2 :: Int -> IO ()
+phase2 i = do
+ mv <- newEmptyMVar
+ done <- newEmptyMVar
+ kvar <- newEmptyMVar
+ let !p = i * 7919 + 3
+ !q = i * 104729 + 7
+ !u = i * 1299709 + 11
+ !v = i * 15485863 + 13
+ -- Capture a continuation whose resumption unmasks: the capture happens
+ -- inside restore, so its apply_mask_frame is the unmask frame.
+ _ <- forkIO $ do
+ tag <- newPromptTag
+ _ <- prompt tag $ mask $ \restore -> do
+ x <- restore (control0 tag (\k -> putMVar kvar k >> pure 0))
+ pure (useInts x p q u v)
+ pure ()
+ k <- takeMVar kvar
+ a <- forkIO $
+ handle (\Boom -> void (tryPutMVar done (Left Boom))) $ do
+ r <- uninterruptibleMask_ $ do
+ putMVar mv ()
+ threadDelay 2000 -- let the thrower queue its exception
+ k (pure 42) -- resuming unmasks with the exception pending
+ void (tryPutMVar done (Right r))
+ takeMVar mv
+ _ <- forkIO $ throwTo a Boom
+ void (takeMVar done)
+
+main :: IO ()
+main = do
+ forM_ [1 .. rounds] phase1
+ forM_ [1 .. rounds] phase2
+ putStrLn "ok"
=====================================
testsuite/tests/rts/continuations/T27651.stdout
=====================================
@@ -0,0 +1 @@
+ok
=====================================
testsuite/tests/rts/continuations/all.T
=====================================
@@ -9,3 +9,4 @@ test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_r
test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"'])
test('T23513', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T23513', ''])
+test('T27651', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T27651', ''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -980,9 +980,6 @@ markLensBracketsO' a l =
ListBraces o c -> do
o' <- markEpToken o
return (set l (ListBraces o' c) a)
- ListSquare o c -> do
- o' <- markEpToken o
- return (set l (ListSquare o' c) a)
ListNone -> return (set l ListNone a)
markLensBracketsC :: (Monad m, Monoid w)
@@ -996,9 +993,6 @@ markLensBracketsC' a l =
ListBraces o c -> do
c' <- markEpToken c
return (set l (ListBraces o c') a)
- ListSquare o c -> do
- c' <- markEpToken c
- return (set l (ListSquare o c') a)
ListNone -> return (set l ListNone a)
-- -------------------------------------
@@ -1468,6 +1462,19 @@ markKwT (AddDarrowAnn tok) = AddDarrowAnn <$> markEpUniToken tok
-- ---------------------------------------------------------------------
+markAnnListD :: (Monad m, Monoid w)
+ => Either (EpToken "[", EpToken "]") AnnList
+ -> EP w m a
+ -> EP w m (Either (EpToken "[", EpToken "]") AnnList, a)
+markAnnListD (Left (o,c)) action = do
+ o' <- markEpToken o
+ r <- action
+ c' <- markEpToken c
+ return (Left (o',c'), r)
+markAnnListD (Right ann) action = do
+ (ann',r) <- markAnnList' ann action
+ return (Right ann',r)
+
markAnnList :: (Monad m, Monoid w)
=> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a)
markAnnList ann action = do
@@ -3115,10 +3122,10 @@ instance ExactPrint (HsExpr GhcPs) where
e' <- markAnnotated e
return (HsLet (tkLet',tkIn') binds' e')
- exact (HsDo (an,l) do_or_list_comp stmts) = do
+ exact (HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
- (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts
- return (HsDo (an',l') do_or_list_comp stmts')
+ (an',stmts') <- exactDo an do_or_list_comp stmts
+ return (HsDo an' do_or_list_comp stmts')
exact (ExplicitList (o,c) es) = do
debugM $ "ExplicitList start"
@@ -3290,8 +3297,8 @@ instance ExactPrint (HsExpr GhcPs) where
-- ---------------------------------------------------------------------
exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
- => (AnnList, EpaLocation) -> HsDoFlavour -> LocatedAn an a
- -> EP w m (AnnList, EpaLocation, LocatedAn an a)
+ => DoAnn -> HsDoFlavour -> LocatedAn an a
+ -> EP w m (DoAnn, LocatedAn an a)
exactDo (an,l) (DoExpr m) stmts = exactMdo l m "do" >>=
\l0 -> markMaybeDodgyStmts (an,l0) stmts
exactDo (an,l) GhciStmtCtxt stmts = printStringAtAA l "do" >>=
@@ -3310,15 +3317,23 @@ exactMdo l (Just module_name) kw = printStringAtAA l n
n = (moduleNameString module_name) ++ "." ++ kw
markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
- => (AnnList, EpaLocation) -> LocatedAn an a -> EP w m (AnnList, EpaLocation, LocatedAn an a)
+ => DoAnn -> LocatedAn an a -> EP w m (DoAnn, LocatedAn an a)
markMaybeDodgyStmts (an,l) stmts =
if notDodgy stmts
then do
- (an0,stmts') <- markAnnListA' an $ \a -> do
- r <- markAnnotatedWithLayout stmts
- return (a, r)
- return (an0, l, stmts')
- else return (an, l, stmts)
+ (an0,stmts') <- case an of
+ Left (o,c) -> do
+ o' <- markEpToken o
+ r <- markAnnotated stmts
+ c' <- markEpToken c
+ return (Left (o',c'), r)
+ Right an' -> do
+ (an'',r') <- markAnnListA' an' $ \a -> do
+ r <- markAnnotatedWithLayout stmts
+ return (a, r)
+ return (Right an'',r')
+ return ((an0, l), stmts')
+ else return ((an, l), stmts)
notDodgy :: GenLocated (EpAnn ann) a -> Bool
notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc
@@ -3601,9 +3616,7 @@ instance ExactPrint (HsCmd GhcPs) where
exact (HsCmdDo (an0,loc) es) = do
debugM $ "HsCmdDo"
loc' <- printStringAtAA loc "do"
- (an1,es') <- markAnnList' an0 $ do
- ee <- markAnnotated es
- return ee
+ (an1,es') <- markAnnListD an0 $ do markAnnotated es
return (HsCmdDo (an1,loc') es')
-- ---------------------------------------------------------------------
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -343,7 +343,6 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation)
annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c)
-annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c)
annListBracketsLocs ListNone = (noAnn, noAnn)
data SplitWhere = Before | After
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95d56c3329adb65eb345e3f22cf8d0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95d56c3329adb65eb345e3f22cf8d0…
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