[Git][ghc/ghc][wip/9.12.3-backports] 9 commits: CprAnal: Detect recursive newtypes (#25944)
2 Sep
2025
2 Sep
'25
11:50 a.m.
Zubin pushed to branch wip/9.12.3-backports at Glasgow Haskell Compiler / GHC
Commits:
24710c4c by Sebastian Graf at 2025-09-02T17:19:41+05:30
CprAnal: Detect recursive newtypes (#25944)
While `cprTransformDataConWork` handles recursive data con workers, it
did not detect the case when a newtype is responsible for the recursion.
This is now detected in the `Cast` case of `cprAnal`.
The same reproducer made it clear that `isRecDataCon` lacked congruent
handling for `AppTy` and `CastTy`, now fixed.
Furthermore, the new repro case T25944 triggered this bug via an
infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`.
While it should be much less likely to trigger such an infinite loop now
that `isRecDataCon` has been fixed, I made sure to abort the loop after
10 iterations and emitting a warning instead.
Fixes #25944.
(cherry picked from commit 4bc78496406f7469640faaa46e2f311c05760124)
- - - - -
aa52a199 by Zubin Duggal at 2025-09-02T17:19:41+05:30
fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory
Fixes #24093
(cherry picked from commit 9fa590a6e27545995cdcf419ed7a6504e6668b18)
- - - - -
ac9ab53d by Ben Gamari at 2025-09-02T17:19:41+05:30
configure: Allow override of CrossCompiling
As noted in #26236, the current inference logic is a bit simplistic. In
particular, there are many cases (e.g. building for a new libc) where
the target and host triples may differ yet we are still able to run the
produced artifacts as native code.
Closes #26236.
(cherry picked from commit 81577fe7c1913c53608bf03e48f84507be904620)
- - - - -
d2b40901 by Simon Peyton Jones at 2025-09-02T17:19:41+05:30
Take more care in zonkEqTypes on AppTy/AppTy
This patch fixes #26256.
See Note [zonkEqTypes and the PKTI] in GHC.Tc.Solver.Equality
(cherry picked from commit 18036d5205ac648bb245217519fed2fd931a9982)
- - - - -
2b0f2f43 by Andreas Klebinger at 2025-09-02T17:19:41+05:30
Make unexpected LLVM versions a warning rather than an error.
Typically a newer LLVM version *will* work so erroring out if
a user uses a newer LLVM version is too aggressive.
Fixes #25915
(cherry picked from commit 50842f83f467ff54dd22470559a7af79d2025c03)
- - - - -
68a1a88f by Teo Camarasu at 2025-09-02T17:19:41+05:30
rts: spin if we see a WHITEHOLE in messageBlackHole
When a BLACKHOLE gets cancelled in raiseAsync, we indirect to a THUNK.
GC can then shortcut this, replacing our BLACKHOLE with a fresh THUNK.
This THUNK is not guaranteed to have a valid indirectee field.
If at the same time, a message intended for the previous BLACKHOLE is
processed and concurrently we BLACKHOLE the THUNK, thus temporarily
turning it into a WHITEHOLE, we can get a segfault, since we look at the
undefined indirectee field of the THUNK
The fix is simple: spin if we see a WHITEHOLE, and it will soon be
replaced with a valid BLACKHOLE.
Resolves #26205
(cherry picked from commit 4021181ee0860aca2054883a531f3312361cc701)
- - - - -
670cbe9d by Teo Camarasu at 2025-09-02T17:19:41+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)
- - - - -
9edb71d5 by Ben Gamari at 2025-09-02T17:19:41+05:30
llvmGen: Fix built-in variable predicate
Previously the predicate to identify LLVM builtin global variables was
checking for `$llvm` rather than `@llvm` as it should.
(cherry picked from commit 6e67fa083a50684e1cfae546e07cab4d4250e871)
- - - - -
24 changed files:
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Tc/Solver/Equality.hs
- configure.ac
- 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/cpranal/sigs/T25944.hs
- + testsuite/tests/cpranal/sigs/T25944.stderr
- testsuite/tests/cpranal/sigs/all.T
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/partial-sigs/should_compile/T26256.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T26256a.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
.gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
=====================================
@@ -134,6 +134,9 @@ def fetch_artifacts(release: str, pipeline_id: int,
logging.info(f'extracted docs {f} to {dest}')
index_path = destdir / 'docs' / 'index.html'
index_path.replace(dest / 'index.html')
+ pdfs = list(destdir.glob('*.pdf'))
+ for f in pdfs:
+ f.replace(dest / f.name)
elif job.name == 'hackage-doc-tarball':
dest = dest_dir / 'hackage_docs'
logging.info(f'moved hackage_docs to {dest}')
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -526,10 +526,10 @@ generateExternDecls = do
modifyEnv $ \env -> env { envAliases = emptyUniqSet }
return (concat defss, [])
--- | Is a variable one of the special @$llvm@ globals?
+-- | Is a variable one of the special @\@llvm@ globals?
isBuiltinLlvmVar :: LlvmVar -> Bool
isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =
- "$llvm" `isPrefixOf` unpackFS lbl
+ "llvm." `isPrefixOf` unpackFS lbl
isBuiltinLlvmVar _ = False
-- | Here we take a global variable definition, rename it with a
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiWayIf #-}
-- | Constructed Product Result analysis. Identifies functions that surely
-- return heap-allocated records on every code path, so that we can eliminate
@@ -22,12 +23,15 @@ import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Unique.MemoFun
+import GHC.Core
import GHC.Core.FamInstEnv
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Utils
-import GHC.Core
+import GHC.Core.Coercion
+import GHC.Core.Reduction
import GHC.Core.Seq
+import GHC.Core.TyCon
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Data.Graph.UnVar -- for UnVarSet
@@ -216,9 +220,13 @@ cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact
cprAnal' _ (Coercion co) = (topCprType, Coercion co)
cprAnal' env (Cast e co)
- = (cpr_ty, Cast e' co)
+ = (cpr_ty', Cast e' co)
where
(cpr_ty, e') = cprAnal env e
+ cpr_ty'
+ | cpr_ty == topCprType = topCprType -- cheap case first
+ | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors]
+ | otherwise = cpr_ty
cprAnal' env (Tick t e)
= (cpr_ty, Tick t e')
@@ -384,6 +392,19 @@ cprTransformDataConWork env con args
mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE = 10
+isRecNewTyConApp :: AnalEnv -> Type -> Bool
+-- See Note [CPR for recursive newtype constructors]
+isRecNewTyConApp env ty
+ --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined
+ | Just (tc, tc_args) <- splitTyConApp_maybe ty =
+ if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args
+ -> isRecNewTyConApp env rhs
+ | Just dc <- newTyConDataCon_maybe tc
+ -> ae_rec_dc env dc == DefinitelyRecursive
+ | otherwise
+ -> False
+ | otherwise = False
+
--
-- * Bindings
--
@@ -407,12 +428,18 @@ cprFix orig_env orig_pairs
| otherwise = orig_pairs
init_env = extendSigEnvFromIds orig_env (map fst init_pairs)
+ -- If fixed-point iteration does not yield a result we use this instead
+ -- See Note [Safe abortion in the fixed-point iteration]
+ abort :: (AnalEnv, [(Id,CoreExpr)])
+ abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ]
+
-- The fixed-point varies the idCprSig field of the binders and and their
-- entries in the AnalEnv, and terminates if that annotation does not change
-- any more.
loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
loop n env pairs
| found_fixpoint = (reset_env', pairs')
+ | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort
| otherwise = loop (n+1) env' pairs'
where
-- In all but the first iteration, delete the virgin flag
@@ -511,8 +538,9 @@ cprAnalBind env id rhs
-- possibly trim thunk CPR info
rhs_ty'
-- See Note [CPR for thunks]
- | stays_thunk = trimCprTy rhs_ty
- | otherwise = rhs_ty
+ | rhs_ty == topCprType = topCprType -- cheap case first
+ | stays_thunk = trimCprTy rhs_ty
+ | otherwise = rhs_ty
-- See Note [Arity trimming for CPR signatures]
sig = mkCprSigForArity (idArity id) rhs_ty'
-- See Note [OPAQUE pragma]
@@ -631,7 +659,7 @@ data AnalEnv
, ae_fam_envs :: FamInstEnvs
-- ^ Needed when expanding type families and synonyms of product types.
, ae_rec_dc :: DataCon -> IsRecDataConResult
- -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
+ -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType
}
instance Outputable AnalEnv where
@@ -1034,10 +1062,11 @@ Eliminating the shared 'c' binding in the process. And then
What can we do about it?
- A. Don't CPR functions that return a *recursive data type* (the list in this
- case). This is the solution we adopt. Rationale: the benefit of CPR on
- recursive data structures is slight, because it only affects the outer layer
- of a potentially massive data structure.
+ A. Don't give recursive data constructors or casts representing recursive newtype constructors
+ the CPR property (the list in this case). This is the solution we adopt.
+ Rationale: the benefit of CPR on recursive data structures is slight,
+ because it only affects the outer layer of a potentially massive data
+ structure.
B. Don't CPR any *recursive function*. That would be quite conservative, as it
would also affect e.g. the factorial function.
C. Flat CPR only for recursive functions. This prevents the asymptotic
@@ -1047,10 +1076,15 @@ What can we do about it?
`c` in the second eqn of `replicateC`). But we'd need to know which paths
were hot. We want such static branch frequency estimates in #20378.
-We adopt solution (A) It is ad-hoc, but appears to work reasonably well.
-Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:
-See Note [Detecting recursive data constructors]. We don't have to be perfect
-and can simply keep on unboxing if unsure.
+We adopt solution (A). It is ad-hoc, but appears to work reasonably well.
+Specifically:
+
+* For data constructors, in `cprTransformDataConWork` we check for a recursive
+ data constructor by calling `ae_rec_dc env`, which is just a memoised version
+ of `isRecDataCon`. See Note [Detecting recursive data constructors]
+* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype
+ by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`.
+ See Note [CPR for recursive newtype constructors]
Note [Detecting recursive data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1067,12 +1101,15 @@ looks inside the following class of types, represented by `ty` (and responds
types of its data constructors and check `tc_args` for recursion.
C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to
`rhs`, look into the `rhs` type.
+ D. If `ty = f a`, then look into `f` and `a`
+ E. If `ty = ty' |> co`, then look into `ty'`
A few perhaps surprising points:
1. It deems any function type as non-recursive, because it's unlikely that
a recursion through a function type builds up a recursive data structure.
- 2. It doesn't look into kinds or coercion types because there's nothing to unbox.
+ 2. It doesn't look into kinds, literals or coercion types because we are
+ ultimately looking for value-level recursion.
Same for promoted data constructors.
3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not;
we simply look at its definition/DataCons and its field tys and look for
@@ -1145,6 +1182,22 @@ I've played with the idea to make points (1) through (3) of 'isRecDataCon'
configurable like (4) to enable more re-use throughout the compiler, but haven't
found a killer app for that yet, so ultimately didn't do that.
+Note [CPR for recursive newtype constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A newtype constructor is considered recursive iff the data constructor of the
+equivalent datatype definition is recursive.
+See Note [CPR for recursive data constructors].
+Detection is a bit complicated by the fact that newtype constructor applications
+reflect as Casts in Core:
+
+ newtype List a = C (Maybe (a, List a))
+ xs = C (Just (0, C Nothing))
+ ==> {desugar to Core}
+ xs = Just (0, Nothing |> sym N:List) |> sym N:List
+
+So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than
+in `cprTransformDataConWork` as for data constructors.
+
Note [CPR examples]
~~~~~~~~~~~~~~~~~~~
Here are some examples (stranal/should_compile/T10482a) of the
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -63,6 +63,7 @@ import Data.List ( unzip4 )
import GHC.Types.RepType
import GHC.Unit.Types
+import GHC.Core.TyCo.Rep
{-
************************************************************************
@@ -1426,23 +1427,29 @@ isRecDataCon fam_envs fuel orig_dc
| arg_ty <- map scaledThing (dataConRepArgTys dc) ]
go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult
- go_arg_ty fuel visited_tcs ty
- --- | pprTrace "arg_ty" (ppr ty) False = undefined
+ go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $
+ case coreFullView ty of
+ TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args
+ -- See Note [Detecting recursive data constructors], points (B) and (C)
- | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty
- = go_arg_ty fuel visited_tcs ty'
+ ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty'
-- See Note [Detecting recursive data constructors], point (A)
- | Just (tc, tc_args) <- splitTyConApp_maybe ty
- = go_tc_app fuel visited_tcs tc tc_args
+ CastTy ty' _ -> go_arg_ty fuel visited_tcs ty'
- | otherwise
- = NonRecursiveOrUnsure
+ AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a
+ -- See Note [Detecting recursive data constructors], point (D)
+
+ FunTy{} -> NonRecursiveOrUnsure
+ -- See Note [Detecting recursive data constructors], point (1)
+
+ -- (TyVarTy{} | LitTy{} | CastTy{})
+ _ -> NonRecursiveOrUnsure
go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult
go_tc_app fuel visited_tcs tc tc_args =
case tyConDataCons_maybe tc of
- --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined
+ ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined
_ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args
-- This is the only place where we look at tc_args, which might have
-- See Note [Detecting recursive data constructors], point (C) and (5)
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -276,7 +276,7 @@ instance Diagnostic DriverMessage where
++ llvmVersionStr supportedLlvmVersionLowerBound
++ " and "
++ llvmVersionStr supportedLlvmVersionUpperBound
- ++ ") and reinstall GHC to make -fllvm work")
+ ++ ") and reinstall GHC to ensure -fllvm works")
diagnosticReason = \case
DriverUnknownMessage m
@@ -347,7 +347,7 @@ instance Diagnostic DriverMessage where
DriverInstantiationNodeInDependencyGeneration {}
-> ErrorWithoutFlag
DriverNoConfiguredLLVMToolchain
- -> ErrorWithoutFlag
+ -> WarningWithoutFlag
diagnosticHints = \case
DriverUnknownMessage m
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -193,12 +193,8 @@ zonkEqTypes ev eq_rel ty1 ty2
then tycon tc1 tys1 tys2
else bale_out ty1 ty2
- go ty1 ty2
- | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
- , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
- = do { res_a <- go ty1a ty2a
- ; res_b <- go ty1b ty2b
- ; return $ combine_rev mkAppTy res_b res_a }
+ -- If you are temppted to add a case for AppTy/AppTy, be careful
+ -- See Note [zonkEqTypes and the PKTI]
go ty1@(LitTy lit1) (LitTy lit2)
| lit1 == lit2
@@ -274,6 +270,32 @@ zonkEqTypes ev eq_rel ty1 ty2
combine_rev f (Right tys) (Right ty) = Right (f ty tys)
+{- Note [zonkEqTypes and the PKTI]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because `zonkEqTypes` does /partial/ zonking, we need to be very careful
+to maintain the Purely Kinded Type Invariant: see GHC.Tc.Gen/HsType
+HsNote [The Purely Kinded Type Invariant (PKTI)].
+
+In #26256 we try to solve this equality constraint:
+ Int :-> Maybe Char ~# k0 Int (m0 Char)
+where m0 and k0 are unification variables, and
+ m0 :: Type -> Type
+It happens that m0 was already unified
+ m0 := (w0 :: kappa)
+where kappa is another unification variable that is also already unified:
+ kappa := Type->Type.
+So the original type satisifed the PKTI, but a partially-zonked form
+ k0 Int (w0 Char)
+does not!! (This a bit reminiscent of Note [mkAppTyM].)
+
+The solution I have adopted is simply to make `zonkEqTypes` bale out on `AppTy`.
+After all, it's only supposed to be a quick hack to see if two types are already
+equal; if we bale out we'll just get into the "proper" canonicaliser.
+
+The only tricky thing about this approach is that it relies on /omitting/
+code -- for the AppTy/AppTy case! Hence this Note
+-}
+
{- *********************************************************************
* *
* canonicaliseEquality
=====================================
configure.ac
=====================================
@@ -351,15 +351,23 @@ fi
dnl ** Building a cross compiler?
dnl --------------------------------------------------------------
-CrossCompiling=NO
-# If 'host' and 'target' differ, then this means we are building a cross-compiler.
-if test "$target" != "$host" ; then
- CrossCompiling=YES
- cross_compiling=yes # This tells configure that it can accept just 'target',
- # otherwise you get
- # configure: error: cannot run C compiled programs.
- # If you meant to cross compile, use `--host'.
+dnl We allow the user to override this since the target/host check
+dnl can get this wrong in some particular cases. See #26236.
+if test -z "$CrossCompiling" ; then
+ CrossCompiling=NO
+ # If 'host' and 'target' differ, then this means we are building a cross-compiler.
+ if test "$target" != "$host" ; then
+ CrossCompiling=YES
+ fi
+fi
+if test "$CrossCompiling" = "YES"; then
+ # This tells configure that it can accept just 'target',
+ # otherwise you get
+ # configure: error: cannot run C compiled programs.
+ # If you meant to cross compile, use `--host'.
+ cross_compiling=yes
fi
+
if test "$BuildPlatform" != "$HostPlatform" ; then
AC_MSG_ERROR([
You've selected:
=====================================
libraries/base/changelog.md
=====================================
@@ -1,5 +1,8 @@
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
+## 4.21.2.0 *Sept 2024*
+ * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350))
+
## 4.21.1.0 *Sept 2024*
* 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)).
=====================================
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;
@@ -574,6 +575,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/cpranal/sigs/T25944.hs
=====================================
@@ -0,0 +1,114 @@
+{-# LANGUAGE UndecidableInstances, LambdaCase #-}
+
+-- | This file starts with a small reproducer for #25944 that is easy to debug
+-- and then continues with a much larger MWE that is faithful to the original
+-- issue.
+module T25944 (foo, bar, popMinOneT, popMinOne) where
+
+import Data.Functor.Identity ( Identity(..) )
+import Data.Coerce
+
+data ListCons a b = Nil | a :- !b
+newtype Fix f = Fix (f (Fix f)) -- Rec
+
+foo :: Fix (ListCons a) -> Fix (ListCons a) -> Fix (ListCons a)
+foo a b = go a
+ where
+ -- The outer loop arranges it so that the base case `go as` of `go2` is
+ -- bottom on the first iteration of the loop.
+ go (Fix Nil) = Fix Nil
+ go (Fix (a :- as)) = Fix (a :- go2 b)
+ where
+ go2 (Fix Nil) = go as
+ go2 (Fix (b :- bs)) = Fix (b :- go2 bs)
+
+bar :: Int -> (Fix (ListCons Int), Int)
+bar n = (foo (Fix Nil) (Fix Nil), n) -- should still have CPR property
+
+-- Now the actual reproducer from #25944:
+
+newtype ListT m a = ListT { runListT :: m (ListCons a (ListT m a)) }
+
+cons :: Applicative m => a -> ListT m a -> ListT m a
+cons x xs = ListT (pure (x :- xs))
+
+nil :: Applicative m => ListT m a
+nil = ListT (pure Nil)
+
+instance Functor m => Functor (ListT m) where
+ fmap f (ListT m) = ListT (go <$> m)
+ where
+ go Nil = Nil
+ go (a :- m) = f a :- (f <$> m)
+
+foldListT :: ((ListCons a (ListT m a) -> c) -> m (ListCons a (ListT m a)) -> b)
+ -> (a -> b -> c)
+ -> c
+ -> ListT m a -> b
+foldListT r c n = r h . runListT
+ where
+ h Nil = n
+ h (x :- ListT xs) = c x (r h xs)
+{-# INLINE foldListT #-}
+
+mapListT :: forall a m b. Monad m => (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b
+mapListT =
+ foldListT
+ ((coerce ::
+ ((ListCons a (ListT m a) -> m (ListCons b (ListT m b))) -> m (ListCons a (ListT m a)) -> m (ListCons b (ListT m b))) ->
+ ((ListCons a (ListT m a) -> ListT m b) -> m (ListCons a (ListT m a)) -> ListT m b))
+ (=<<))
+{-# INLINE mapListT #-}
+
+instance Monad m => Applicative (ListT m) where
+ pure x = cons x nil
+ {-# INLINE pure #-}
+ liftA2 f xs ys = mapListT (\x zs -> mapListT (cons . f x) zs ys) nil xs
+ {-# INLINE liftA2 #-}
+
+instance Monad m => Monad (ListT m) where
+ xs >>= f = mapListT (flip (mapListT cons) . f) nil xs
+ {-# INLINE (>>=) #-}
+
+infixr 5 :<
+data Node w a b = Leaf a | !w :< b
+ deriving (Functor)
+
+bimapNode f g (Leaf x) = Leaf (f x)
+bimapNode f g (x :< xs) = x :< g xs
+
+newtype HeapT w m a = HeapT { runHeapT :: ListT m (Node w a (HeapT w m a)) }
+
+-- | The 'Heap' type, specialised to the 'Identity' monad.
+type Heap w = HeapT w Identity
+
+instance Functor m => Functor (HeapT w m) where
+ fmap f = HeapT . fmap (bimapNode f (fmap f)) . runHeapT
+
+instance Monad m => Applicative (HeapT w m) where
+ pure = HeapT . pure . Leaf
+ (<*>) = liftA2 id
+
+instance Monad m => Monad (HeapT w m) where
+ HeapT m >>= f = HeapT (m >>= g)
+ where
+ g (Leaf x) = runHeapT (f x)
+ g (w :< xs) = pure (w :< (xs >>= f))
+
+popMinOneT :: forall w m a. (Monoid w, Monad m) => HeapT w m a -> m (Maybe ((a, w), HeapT w m a))
+popMinOneT = go mempty [] . runHeapT
+ where
+ go' :: w -> Maybe (w, HeapT w m a) -> m (Maybe ((a, w), HeapT w m a))
+ go' a Nothing = pure Nothing
+ go' a (Just (w, HeapT xs)) = go (a <> w) [] xs
+
+ go :: w -> [(w, HeapT w m a)] -> ListT m (Node w a (HeapT w m a)) -> m (Maybe ((a, w), HeapT w m a))
+ go w a (ListT xs) = xs >>= \case
+ Nil -> go' w (undefined)
+ Leaf x :- xs -> pure (Just ((x, w), undefined >> HeapT (foldl (\ys (yw,y) -> ListT (pure ((yw :< y) :- ys))) xs a)))
+ (u :< x) :- xs -> go w ((u,x) : a) xs
+{-# INLINE popMinOneT #-}
+
+popMinOne :: Monoid w => Heap w a -> Maybe ((a, w), Heap w a)
+popMinOne = runIdentity . popMinOneT
+{-# INLINE popMinOne #-}
=====================================
testsuite/tests/cpranal/sigs/T25944.stderr
=====================================
@@ -0,0 +1,17 @@
+
+==================== Cpr signatures ====================
+T25944.$fApplicativeHeapT:
+T25944.$fApplicativeListT:
+T25944.$fFunctorHeapT:
+T25944.$fFunctorListT:
+T25944.$fFunctorNode:
+T25944.$fMonadHeapT:
+T25944.$fMonadListT:
+T25944.bar: 1
+T25944.foo:
+T25944.popMinOne: 2(1(1,))
+T25944.popMinOneT:
+T25944.runHeapT:
+T25944.runListT:
+
+
=====================================
testsuite/tests/cpranal/sigs/all.T
=====================================
@@ -12,3 +12,4 @@ test('T16040', normal, compile, [''])
test('T19232', normal, compile, [''])
test('T19398', normal, compile, [''])
test('T19822', normal, compile, [''])
+test('T25944', normal, compile, [''])
=====================================
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
=====================================
@@ -87,3 +87,4 @@ test('T24066', normal, compile_and_run, [''])
test('div01', normal, compile_and_run, [''])
test('T24245', normal, compile_and_run, [''])
test('T25653', normal, compile_and_run, [''])
+test('T26230', normal, compile_and_run, [''])
=====================================
testsuite/tests/partial-sigs/should_compile/T26256.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+
+module M (go) where
+
+import Data.Kind
+
+type Apply :: (Type -> Type) -> Type
+data Apply m
+
+type (:->) :: Type -> Type -> Type
+type family (:->) where (:->) = (->)
+
+f :: forall (k :: Type -> Type -> Type) (m :: Type -> Type).
+ k Int (m Char) -> k Bool (Apply m)
+f = f
+
+x :: Int :-> Maybe Char
+x = x
+
+go :: Bool -> _ _
+go = f x
=====================================
testsuite/tests/partial-sigs/should_compile/T26256.stderr
=====================================
@@ -0,0 +1,8 @@
+T26256.hs:22:15: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘Apply :: (* -> *) -> *’
+ • In the type signature: go :: Bool -> _ _
+
+T26256.hs:22:17: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)]
+ • Found type wildcard ‘_’ standing for ‘Maybe :: * -> *’
+ • In the first argument of ‘_’, namely ‘_’
+ In the type signature: go :: Bool -> _ _
=====================================
testsuite/tests/partial-sigs/should_compile/all.T
=====================================
@@ -108,3 +108,4 @@ test('T21667', normal, compile, [''])
test('T22065', normal, compile, [''])
test('T16152', normal, compile, [''])
test('T20076', expect_broken(20076), compile, [''])
+test('T26256', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_compile/T26256a.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T26256 (go) where
+
+import Data.Kind
+
+class Cat k where (<<<) :: k a b -> k x a -> k x b
+instance Cat (->) where (<<<) = (.)
+class Pro k p where pro :: k a b s t -> p a b -> p s t
+data Hiding o a b s t = forall e. Hiding (s -> o e a)
+newtype Apply e a = Apply (e a)
+
+type (:->) :: Type -> Type -> Type
+type family (:->) where
+ (:->) = (->)
+
+go :: (Pro (Hiding Apply) p) => (s :-> e a) -> p a b -> p s t
+go sea = pro (Hiding (Apply <<< sea))
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -935,3 +935,4 @@ test('T24845a', normal, compile, [''])
test('T23501a', normal, compile, [''])
test('T23501b', normal, compile, [''])
test('T25597', normal, compile, [''])
+test('T26256a', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75d546fe58d4532b4f39814c453928e206a1018a...9edb71d5f782b8860e674240b6de715ed69c025c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75d546fe58d4532b4f39814c453928e206a1018a...9edb71d5f782b8860e674240b6de715ed69c025c
You're receiving this email because of your account on gitlab.haskell.org.
150
Age (days ago)
150
Last active (days ago)
0 comments
1 participants
participants (1)
-
Zubin (＠wz1000)