17 Aug
2025
17 Aug
'25
5:06 p.m.
Zubin pushed to branch wip/9.10.3-backports at Glasgow Haskell Compiler / GHC
Commits:
dea3e5d6 by Teo Camarasu at 2025-08-17T22:31:50+05:30
rts: ensure MessageBlackHole.link is always a valid closure
We turn a MessageBlackHole into an StgInd in wakeBlockingQueue().
Therefore it's important that the link field, which becomes the
indirection field, always points to a valid closure.
It's unclear whether it's currently possible for the previous behaviour
to lead to a crash, but it's good to be consistent about this invariant nonetheless.
Co-authored-by: Andreas Klebinger
naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3) 0
In contrast, `naturalAndNot` does not truncate when both arguments are larger than a `Word`, so this appears to be a bug.
Luckily, the fix is pretty easy: we just need to call `bigNatAndNotWord#` instead of truncating.
Fixes #26230
(cherry picked from commit a766286fe759251eceb304c54ba52841c2a51f86)
- - - - -
1ea64785 by sheaf at 2025-08-17T22:36:18+05:30
RecordCon lookup: don't allow a TyCon
This commit adds extra logic when looking up a record constructor.
If GHC.Rename.Env.lookupOccRnConstr returns a TyCon (as it may, due to
the logic explained in Note [Pattern to type (P2T) conversion]),
we emit an error saying that the data constructor is not in scope.
This avoids the compiler falling over shortly thereafter, in the call to
'lookupConstructorInfo' inside 'GHC.Rename.Env.lookupRecFieldOcc',
because the record constructor would not have been a ConLike.
Fixes #25056
(cherry picked from commit da306610b9e58cfb7cf2530ebeec7ee8ad17183a)
- - - - -
23 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Env.hs
- libraries/base/changelog.md
- libraries/ghc-bignum/changelog.md
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- rts/Messages.c
- rts/StgMiscClosures.cmm
- rts/Updates.h
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/rename/should_fail/T25056.hs
- + testsuite/tests/rename/should_fail/T25056.stderr
- + testsuite/tests/rename/should_fail/T25056a.hs
- + testsuite/tests/rename/should_fail/T25056b.hs
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/typecheck/should_fail/T23739b.hs
- testsuite/tests/typecheck/should_fail/T23739b.stderr
- + testsuite/tests/typecheck/should_fail/T23739c.hs
- + testsuite/tests/typecheck/should_fail/T23739c.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -436,6 +436,7 @@ lookupConstructorInfo con_name
; case info of
IAmConLike con_info -> return con_info
UnboundGRE -> return ConHasPositionalArgs
+ IAmTyCon {} -> failIllegalTyCon WL_Constructor con_name
_ -> pprPanic "lookupConstructorInfo: not a ConLike" $
vcat [ text "name:" <+> ppr con_name ]
}
@@ -1029,24 +1030,12 @@ lookupOccRn' which_suggest rdr_name
lookupOccRn :: RdrName -> RnM Name
lookupOccRn = lookupOccRn' WL_Anything
--- lookupOccRnConstr looks up an occurrence of a RdrName and displays
--- constructors and pattern synonyms as suggestions if it is not in scope
+-- | Look up an occurrence of a 'RdrName'.
--
--- There is a fallback to the type level, when the first lookup fails.
--- This is required to implement a pat-to-type transformation
--- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
--- Consider this example:
+-- Displays constructors and pattern synonyms as suggestions if
+-- it is not in scope.
--
--- data VisProxy a where VP :: forall a -> VisProxy a
---
--- f :: VisProxy Int -> ()
--- f (VP Int) = ()
---
--- Here `Int` is actually a type, but it stays on position where
--- we expect a data constructor.
---
--- In all other cases we just use this additional lookup for better
--- error messaging (See Note [Promotion]).
+-- See Note [lookupOccRnConstr]
lookupOccRnConstr :: RdrName -> RnM Name
lookupOccRnConstr rdr_name
= do { mb_gre <- lookupOccRn_maybe rdr_name
@@ -1058,6 +1047,28 @@ lookupOccRnConstr rdr_name
Just gre -> return $ greName gre
Nothing -> reportUnboundName' WL_Constructor rdr_name} }
+{- Note [lookupOccRnConstr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+lookupOccRnConstr looks up a data constructor or pattern synonym. Simple.
+
+However, there is a fallback to the type level when the lookup fails.
+This is required to implement a pat-to-type transformation
+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
+
+Consider this example:
+
+ data VisProxy a where VP :: forall a -> VisProxy a
+
+ f :: VisProxy Int -> ()
+ f (VP Int) = ()
+
+Here `Int` is actually a type, but it occurs in a position in which we expect
+a data constructor.
+
+In all other cases we just use this additional lookup for better
+error messaging (See Note [Promotion]).
+-}
+
-- lookupOccRnRecField looks up an occurrence of a RdrName and displays
-- record fields as suggestions if it is not in scope
lookupOccRnRecField :: RdrName -> RnM Name
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -532,9 +532,9 @@ rnExpr (ExplicitSum _ alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
; return (ExplicitSum noExtField alt arity expr', fvs) }
-rnExpr (RecordCon { rcon_con = con_id
+rnExpr (RecordCon { rcon_con = con_rdr
, rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
- = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
+ = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr
; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -1161,7 +1161,7 @@ tc_infer_id id_name
AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
- (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon
+ (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)
ATyVar name _ -> failIllegalTyVal name
_ -> failWithTc $ TcRnExpectedValueId thing }
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -280,7 +280,7 @@ tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
- ATyCon tc -> failIllegalTyCon WL_Constructor tc
+ ATyCon {} -> failIllegalTyCon WL_Constructor name
_ -> wrongThingErr WrongThingConLike (AGlobal thing) name
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
@@ -353,19 +353,20 @@ instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
-- Illegal term-level use of type things
-failIllegalTyCon :: WhatLooking -> TyCon -> TcM a
+failIllegalTyCon :: WhatLooking -> Name -> TcM a
failIllegalTyVal :: Name -> TcM a
(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)
where
- fail_tycon what_looking tc = do
+ fail_tycon what_looking tc_nm = do
gre <- getGlobalRdrEnv
- let nm = tyConName tc
- pprov = case lookupGRE_Name gre nm of
+ let mb_gre = lookupGRE_Name gre tc_nm
+ pprov = case mb_gre of
Just gre -> nest 2 (pprNameProvenance gre)
Nothing -> empty
- err | isClassTyCon tc = ClassTE
- | otherwise = TyConTE
- fail_with_msg what_looking dataName nm pprov err
+ err = case greInfo <$> mb_gre of
+ Just (IAmTyCon ClassFlavour) -> ClassTE
+ _ -> TyConTE
+ fail_with_msg what_looking dataName tc_nm pprov err
fail_tyvar nm =
let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
=====================================
libraries/base/changelog.md
=====================================
@@ -2,6 +2,7 @@
## 4.20.2 *July 2025*
* Fix incorrect results of `integerPowMod` when the base is 0 and the exponent is negative, and `integerRecipMod` when the modulus is zero ([#26017](https://gitlab.haskell.org/ghc/ghc/-/issues/26017)).
+ * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350))
## 4.20.1 *Jan 2025*
* Shipped with GHC 9.10.2
=====================================
libraries/ghc-bignum/changelog.md
=====================================
@@ -4,6 +4,7 @@
- Expose backendName
- Add `naturalSetBit[#]` (#21173), `naturalClearBit[#]` (#21175), `naturalComplementBit[#]` (#21181)
+- Fix bug where `naturalAndNot` was incorrectly truncating results (#26230)
## 1.2
=====================================
libraries/ghc-bignum/src/GHC/Num/Natural.hs
=====================================
@@ -488,7 +488,7 @@ naturalAndNot :: Natural -> Natural -> Natural
{-# NOINLINE naturalAndNot #-}
naturalAndNot (NS n) (NS m) = NS (n `and#` not# m)
naturalAndNot (NS n) (NB m) = NS (n `and#` not# (bigNatToWord# m))
-naturalAndNot (NB n) (NS m) = NS (bigNatToWord# n `and#` not# m)
+naturalAndNot (NB n) (NS m) = NB (bigNatAndNotWord# n m)
naturalAndNot (NB n) (NB m) = naturalFromBigNat# (bigNatAndNot n m)
naturalOr :: Natural -> Natural -> Natural
=====================================
rts/Messages.c
=====================================
@@ -180,13 +180,22 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg)
bh_info != &stg_CAF_BLACKHOLE_info &&
bh_info != &__stg_EAGER_BLACKHOLE_info &&
bh_info != &stg_WHITEHOLE_info) {
- // if it is a WHITEHOLE, then a thread is in the process of
- // trying to BLACKHOLE it. But we know that it was once a
- // BLACKHOLE, so there is at least a valid pointer in the
- // payload, so we can carry on.
return 0;
}
+ // If we see a WHITEHOLE then we should wait for it to turn into a BLACKHOLE.
+ // Otherwise we might look at the indirectee and segfault.
+ // See "Exception handling" in Note [Thunks, blackholes, and indirections]
+ // We might be looking at a *fresh* THUNK being WHITEHOLE-d so we can't
+ // guarantee that the indirectee is a valid pointer.
+#if defined(THREADED_RTS)
+ if (bh_info == &stg_WHITEHOLE_info) {
+ while(ACQUIRE_LOAD(&bh->header.info) == &stg_WHITEHOLE_info) {
+ busy_wait_nop();
+ }
+ }
+#endif
+
// The blackhole must indirect to a TSO, a BLOCKING_QUEUE, an IND,
// or a value.
StgClosure *p;
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -31,6 +31,7 @@ import CLOSURE ENT_VIA_NODE_ctr;
import CLOSURE RtsFlags;
import CLOSURE stg_BLOCKING_QUEUE_CLEAN_info;
import CLOSURE stg_BLOCKING_QUEUE_DIRTY_info;
+import CLOSURE stg_END_TSO_QUEUE_closure;
import CLOSURE stg_IND_info;
import CLOSURE stg_MSG_BLACKHOLE_info;
import CLOSURE stg_TSO_info;
@@ -597,6 +598,9 @@ retry:
MessageBlackHole_tso(msg) = CurrentTSO;
MessageBlackHole_bh(msg) = node;
+ // Ensure that the link field is a valid closure,
+ // since we might turn this into an indirection in wakeBlockingQueue()
+ MessageBlackHole_link(msg) = stg_END_TSO_QUEUE_closure;
SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM);
// messageBlackHole has appropriate memory barriers when this object is exposed.
// See Note [Heap memory barriers].
=====================================
rts/Updates.h
=====================================
@@ -333,6 +333,10 @@
* `AP_STACK` closure recording the aborted execution state.
* See `RaiseAsync.c:raiseAsync` for details.
*
+ * This can combine with indirection shortcutting during GC to replace a BLACKHOLE
+ * with a fresh THUNK. We should be very careful here since the THUNK will have an
+ * undefined value in the indirectee field. Looking at the indirectee field can then
+ * lead to a segfault such as #26205.
*
* CAFs
* ----
=====================================
testsuite/tests/numeric/should_run/T26230.hs
=====================================
@@ -0,0 +1,8 @@
+import Data.Bits
+import GHC.Num.Natural
+
+main = do
+ print $ naturalAndNot ((2 ^ 4) .|. (2 ^ 3)) (2 ^ 3)
+ print $ naturalAndNot ((2 ^ 129) .|. (2 ^ 65)) (2 ^ 65)
+ print $ naturalAndNot ((2 ^ 4) .|. (2 ^ 3)) ((2 ^ 65) .|. (2 ^ 3))
+ print $ naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)
=====================================
testsuite/tests/numeric/should_run/T26230.stdout
=====================================
@@ -0,0 +1,4 @@
+16
+680564733841876926926749214863536422912
+16
+36893488147419103232
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -83,3 +83,4 @@ test('T22282', normal, compile_and_run, [''])
test('T22671', js_fragile(24259), compile_and_run, [''])
test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers'])
test('T24066', normal, compile_and_run, [''])
+test('T26230', normal, compile_and_run, [''])
=====================================
testsuite/tests/rename/should_fail/T25056.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE RecordWildCards #-}
+module T25056 where
+
+import T25056b
+
+foo :: T -> ()
+foo (T { unT = x }) = x
=====================================
testsuite/tests/rename/should_fail/T25056.stderr
=====================================
@@ -0,0 +1,5 @@
+T25056.hs:7:10: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘T’
+ • imported from ‘T25056b’ at T25056.hs:4:1-14
+ (and originally defined in ‘T25056a’ at T25056a.hs:8:1-14)
+
=====================================
testsuite/tests/rename/should_fail/T25056a.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T25056a
+ ( T
+ , T_(unT)
+ , pattern T
+ ) where
+
+type T = T_ ()
+
+data T_ a = PrivateT { unT_ :: a }
+
+pattern T :: a -> T_ a
+pattern T { unT } <- PrivateT { unT_ = unT }
=====================================
testsuite/tests/rename/should_fail/T25056b.hs
=====================================
@@ -0,0 +1,3 @@
+module T25056b (T, T_(..)) where
+
+import T25056a (T, T_(..))
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -222,6 +222,7 @@ test('T23740g', normal, compile_fail, [''])
test('T23740h', normal, compile_fail, [''])
test('T23740i', req_th, compile_fail, [''])
test('T23740j', normal, compile_fail, [''])
+test('T25056', [extra_files(['T25056a.hs', 'T25056b.hs'])], multimod_compile_fail, ['T25056', '-v0'])
test('T23570', [extra_files(['T23570_aux.hs'])], multimod_compile_fail, ['T23570', '-v0'])
test('T23570b', [extra_files(['T23570_aux.hs'])], multimod_compile, ['T23570b', '-v0'])
test('T17594b', req_th, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_fail/T23739b.hs
=====================================
@@ -8,7 +8,4 @@ g1 :: Int -> Unit
g1 Int = ()
g2 :: Int
-g2 = Int{}
-
-g3 :: Int
-g3 = Int
+g2 = Int
=====================================
testsuite/tests/typecheck/should_fail/T23739b.stderr
=====================================
@@ -6,16 +6,9 @@ T23739b.hs:8:4: error: [GHC-01928]
In an equation for ‘g1’: g1 Int = ()
T23739b.hs:11:6: error: [GHC-01928]
- • Illegal term-level use of the type constructor ‘Int’
- • imported from ‘Prelude’ at T23739b.hs:2:8-14
- (and originally defined in ‘GHC.Types’)
- • In the expression: Int {}
- In an equation for ‘g2’: g2 = Int {}
-
-T23739b.hs:14:6: error: [GHC-01928]
• Illegal term-level use of the type constructor ‘Int’
• imported from ‘Prelude’ at T23739b.hs:2:8-14
(and originally defined in ‘GHC.Types’)
• In the expression: Int
- In an equation for ‘g3’: g3 = Int
+ In an equation for ‘g2’: g2 = Int
=====================================
testsuite/tests/typecheck/should_fail/T23739c.hs
=====================================
@@ -0,0 +1,8 @@
+
+module T23739c where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+g :: Int
+g = Int{}
=====================================
testsuite/tests/typecheck/should_fail/T23739c.stderr
=====================================
@@ -0,0 +1,7 @@
+T23739c.hs:8:5: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739c.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the expression: Int {}
+ In an equation for ‘g’: g = Int {}
+
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -730,3 +730,4 @@ test('T23739b', normal, compile_fail, [''])
test('T25325', normal, compile_fail, [''])
test('T25004', normal, compile_fail, [''])
test('T25004k', normal, compile_fail, [''])
+test('T23739c', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7d323b0fb0805f3ebc10c91a9d858d1af82c458...1ea64785f14487f7b999c4a9014bc6da20c0115d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7d323b0fb0805f3ebc10c91a9d858d1af82c458...1ea64785f14487f7b999c4a9014bc6da20c0115d
You're receiving this email because of your account on gitlab.haskell.org.