[Git][ghc/ghc][wip/T27737] 5 commits: X86 NCG: use 32-bit POPCNT for sub-word popcounts
by Simon Peyton Jones (＠simonpj) 30 Oct '26
by Simon Peyton Jones (＠simonpj) 30 Oct '26
30 Oct '26
Simon Peyton Jones pushed to branch wip/T27737 at Glasgow Haskell Compiler / GHC
Commits:
ac870ad5 by Simon Jakobi at 2026-10-28T04:40:42-04:00
X86 NCG: use 32-bit POPCNT for sub-word popcounts
A 32-bit write zero-extends the result to the full register, so we
don't need to emit additional code for this.
We also skip emitting zero-extension instructions for the argument
when it is already visibly zero-extended.
For the byte-wise popcount loop from #24813, this shrinks the popcount
sequence from 5 instructions to 3.
Assisted-by: Claude Fable 5.1
- - - - -
53087373 by Facundo Domínguez at 2026-10-28T04:41:32-04:00
Use a ShortByteString in Serialized instead of [Word8]
This makes the in-memory representation 40x more compact for all values
stored in annotations.
A test is added to measure the representation size of annotations
specified in the compiler input.
The GHC API is modified. All functions that previously handled annotations
in [Word8] form now use ShortByteString. The following definitions have
modified types:
* GHC.findGlobalAnns
* GHC.Tc.Gen.Splice.getAnnotationsByTypeRep
* GHC.Core.Opt.Monad.getAnnotations
* GHC.Core.Opt.Monad.getFirstAnnotations
* GHC.Types.Annotations.deserializeAnns
* GHC.Types.Annotations.findAnns
* GHC.Types.Annotations.findAnnsByTypeRep
* GHC.Serialized.Serialized
* GHC.Serialized.toSerialized
* GHC.Serialized.fromSerialized
* GHC.Serialized.serializeWithData
* GHC.Serialized.deserializeWithData
* GHCi.Message.ReifyAnnotations
Fixes #28002.
- - - - -
3378d5aa by Simon Peyton Jones at 2026-10-30T15:40:36+00:00
Core utilities in preparation for a Simplifier refactoring
This is the first of three commits for #27737. It contains small,
self-contained changes to Core utilities that the Simplifier refactoring
in the next commit relies on.
* `doCaseToLet` moves from GHC.Core.Opt.Simplify.Iteration to
GHC.Core.Utils, with new `mkFloatCase` and `okFloatCase`.
* A new, global, invariant on `GHC.Core.FloatCase`: a DEFAULT case-float
never has a scrutinee for which `doCaseToLet` holds; we use a let-float
instead (`mkFloatCase`). Nice-to-have rather than essential, but it
stops a needless case-float blocking the floating of a whole group.
See Note [The FloatCase invariant] in GHC.Core.
* `exprIsConApp_maybe`: fix a perf hole in `subst_bndr`, which built a
`Subst` unnecessarily; use `mkFloatCase` when looking through a
single-alternative case; `mkFieldSeqFloats` does not seq a strict field
whose argument is unlifted and ok-for-speculation.
* `mkSingleAltCase` skips `occCheckExpand` when no binder is a TyCoVar.
* New `GHC.Data.OrdList.allOL`.
Co-Authored-By: Claude Fable 5.1 <noreply(a)anthropic.com>
- - - - -
73a2f04a by Simon Peyton Jones at 2026-10-30T15:40:37+00:00
Don't push `case` inside `let` in Gentle simplification
This MR refactors the Simplifier again. It was triggered by #27737,
in which a join point was lost, but that led me into a larger-scale
refactoring. This is the second of three commits: the first added
some Core utilities, and the third improves `simplOutExpr`.
I did this in dialogue with Claude but I have audited every line of
the new code, revising almost all of them.
Here are the highlights.
* The core of #27737 is that when `sm_case_case` is off (that is, in
the first "gentle" simplification), we should not do this transformation:
K[ let binds in e ] --> let binds in K[ e ]
See point (2) in Note [sm_case_case: switching off case continuations]
and discussion on #27737.
This is achieved by using `splitContForNoCaseCase` in the `Let`
case of `simplExprF1`. That in turn uses `splitContArgs` to split
the continuation into: a part to push inwards, and a part to keep
at the outside. The same split is used for `Case`, and for `runRW#`.
The invariant (COC-INV) is that when `sm_case_case` is off, the
SimplCont never contains Select, StrictBind or StrictArg.
* I refactored the Simplifier's `LetFloats` to use the GHC-wide data
type `GHC.Core.FloatBinds`. Much nicer! And it eliminates a nasty
impedance mismatch because `exprIsConApp_maybe` returns `FloatBinds`.
See Note [Using FloatBinds in SimplFloats] in GHC.Core.Opt.Simplify.Env.
A consequence is that the Simplifier can return a single-alternative
case as a `FloatCase`, rather than as an expression, so that the lets
in its alternative are not trapped inside it. That matters when
case-of-case is off: `rebuildWithFloats` can do case-of-known-constructor
on the result directly, instead of `exprIsConApp_maybe` walking down
through the case and all the lets every time, which was quadratic
(T18223). See Note [Floating single-alternative cases] in
GHC.Core.Opt.Simplify.Iteration.
The FloatCase is wrapped around its body only when the floats are
finally emitted, by `simplWrapFloats`, which uses `mkCase`, so we lose
none of the usual case tidying (case merging, identity case, etc).
See Note [Wrapping case-floats with mkCase] in GHC.Core.Opt.Simplify.Utils.
* `prepareBinding`/`doFloatFromRhs` is simpler: a group of floats
leaves the RHS of a let-binding only if every one is a let-binding
that we are prepared to float (lazy, or ok-for-speculation, etc);
case-floats and tick-floats never do. The per-group `FloatFlag`
machinery is gone. See Note [doFloatFromRhs] in GHC.Core.Opt.Simplify.Env.
* Casts. When case-of-case is off, `splitContArgs` pushes a cast
inwards only if it is followed by an application. Pushing a cast
into every alternative of a multi-way case duplicates the coercion
(quadratically, for a derived Generic `from`: T5642, T16577) and
defeats cast worker/wrapper.
See Note [Do not push a cast inwards unnecessarily] in GHC.Core.Opt.Simplify.Utils.
Smaller changes
* `contIsDupable` treats a `Select` with "unpacking alternatives"
(case x of K a b -> b, possibly nested) as dupable, so that CPR
unboxing cancels with the boxing instead of making a join point.
See Note [Duplicating unpacking continuations] in GHC.Core.Opt.Simplify.Utils.
* `reallyRebuildCase` does `prepareAlts` first, then splits into
`rebuildSingleAltCase` (no mkDupableCont needed) and `rebuildMultiAltCase`.
`simplAlt` returns the simplified alternative in pieces (con, bndrs,
floats, rhs) rather than floats that mention the alternative's binders.
* `makeTrivial` returns only let-bindings (type `OrdList CoreBind`), and
declines to bind an unlifted expression that is not ok-for-speculation.
See Note [Cannot trivialise] in GHC.Core.Opt.Simplify.Iteration.
* `abstractFloats` takes and returns `SimplFloats`; it is only ever given
let-bindings (a postcondition of `prepareBinding`), so the former panic
on a case-float (T27737a) cannot happen.
* A `Case`'s type is forced exactly when the `Case` is built, by
`returnCase`; see Note [Avoiding space leaks in OutType].
* Note [Floating a prefix of the floats] records an opportunity we
tried and did not keep.
Testsuite: new test T27737a; accept changed output for T20510
and show-bytecode-hpc.
Metric Decrease:
CoOpt_Read
T18730
T26425
T26989
Co-Authored-By: Claude Fable 5.1 <noreply(a)anthropic.com>
- - - - -
17df08ba by Simon Peyton Jones at 2026-10-30T15:40:37+00:00
Improve simplOutExpr, and never push a continuation into simplified alternatives
This is the third of three commits for #27737.
* I improved `simplOutExpr` so that it is less ad-hoc, and occasionally
reduces Simplifier iterations. See new Note [Re-simplifying an OutExpr].
This was a bit more subtle than I had expected, as you'll see from
the Note, but the result is nice.
* Recognise and document a potential variable capture described in
Note [Rebuilding a case with simplified alternatives]. It doesn't actually
happen today, but it /could/ so the Note describes how it is avoided.
That in turn leads to some nice refactoring of `reallyRebuildCase`, allowing
me to get rid of `simplAltBinders`, `simplAltIdBinder` and `simplAltExprF`,
and some SimplAltFlag plumbing. Nice.
* `mkDupableCont` now duplicates a lazy, `exprIsDupable` argument instead of
let-binding it as `karg`, saving an iteration (T13056).
See Note [Duplicating small arguments].
Co-Authored-By: Claude Fable 5.1 <noreply(a)anthropic.com>
- - - - -
35 changed files:
- + changelog.d/T28002
- + changelog.d/T28002-api
- + changelog.d/ncg-x86-subword-popcnt
- compiler/GHC.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Data/OrdList.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Types/Annotations.hs
- compiler/GHC/Utils/Outputable.hs
- libraries/ghc-boot/GHC/Serialized.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/GHCi/TH/Binary.hs
- testsuite/tests/annotations/should_run/Makefile
- + testsuite/tests/annotations/should_run/T16841.hs
- + testsuite/tests/annotations/should_run/T16841.stdout
- testsuite/tests/annotations/should_run/all.T
- + testsuite/tests/codeGen/should_gen_asm/T24813.asm
- + testsuite/tests/codeGen/should_gen_asm/T24813.cmm
- testsuite/tests/codeGen/should_gen_asm/all.T
- testsuite/tests/dmdanal/should_compile/T20510.stderr
- testsuite/tests/plugins/T26761Plugin.hs
- testsuite/tests/plugins/all.T
- testsuite/tests/show-bytecode/show-bytecode-hpc.stdout
- + testsuite/tests/simplCore/should_compile/T27737a.hs
- testsuite/tests/simplCore/should_compile/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e2d74292f46f9e67ed61bc9babaa12…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e2d74292f46f9e67ed61bc9babaa12…
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/T27994] 2 commits: Make niFixSubst idempotent
by Simon Peyton Jones (＠simonpj) 30 Oct '26
by Simon Peyton Jones (＠simonpj) 30 Oct '26
30 Oct '26
Simon Peyton Jones pushed to branch wip/T27994 at Glasgow Haskell Compiler / GHC
Commits:
d2c3c7d7 by Simon Peyton Jones at 2026-10-30T16:24:52+00:00
Make niFixSubst idempotent
I discovered (when fixing #27994) that `niFixSubst` didn't actually
generate an idempotent subsitution despite its claims. It could
return a substitution that mentions domain variables on in its range,
when those variables are hidden inside the kind of a type variable
occurrence. As a result it can generate ill-kinded types. Boo!
The fix is simple, and uses deep substitution.
See Note [Finding the substitution fixpoint]
I don't think it actually /caused/ any bugs, so there is no
regression test.
- - - - -
a5018b9a by Simon Peyton Jones at 2026-10-30T16:25:09+00:00
Fix a nasty bug in fundeps
This MR fixes #27994, which turned out to be very tricky.
See Note [Exploiting closed type famililes], especially (CF7). I was
ending up with TyVars (not TcTyVars) in the solver, because the
substitution computed in `getRelevantBranches` mixed the two.
The code was just too clever. I ended up simplifying it quite a bit.
For /closed/ families we no longer call `trimQtvs` (was `trim_qtvs`).
Open families still do use `trimQtvs`. See Note [trimQTvs]
This patch also fixes one other buglet in the same code.
* Over-saturated type families were being mis-handled.
See the new use of `saturatedFamApp_maybe`.
- - - - -
13 changed files:
- + changelog.d/T27994
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver/FunDeps.hs
- + testsuite/tests/typecheck/should_compile/T27994.hs
- + testsuite/tests/typecheck/should_compile/T27994a.hs
- + testsuite/tests/typecheck/should_compile/T27994b.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
changelog.d/T27994
=====================================
@@ -0,0 +1,7 @@
+section: compiler
+issues: #27994
+mrs: !16842
+synopsis:
+ Fix a compiler Lint error in a heavily kind-polymorphic program
+description:
+ There was a subtle bug deep in the code for computing functional dependencies for type families.
=====================================
compiler/GHC/Core/Coercion/Axiom.hs
=====================================
@@ -277,8 +277,8 @@ data CoAxBranch
-- See Note [CoAxBranch type variables]
, cab_eta_tvs :: [TyVar]
-- ^ Eta-reduced tyvars
- -- cab_tvs and cab_lhs may be eta-reduced; see
- -- Note [Eta reduction for data families]
+ -- For a data family (only) cab_tvs and cab_lhs may be eta-reduced
+ -- See Note [Eta reduction for data families]
, cab_cvs :: [CoVar]
-- ^ Bound coercion variables
-- Always empty, for now.
@@ -286,8 +286,14 @@ data CoAxBranch
-- in GHC.Tc.TyCl
, cab_roles :: [Role]
-- ^ See Note [CoAxBranch roles]
+
, cab_lhs :: [Type]
-- ^ Type patterns to match against
+ -- For a data family `cab_lhs` may be shorter than the arity
+ -- of the data type
+ -- For a type family `cab_lhs` is exactly the family arity
+ -- See Note [Eta reduction for data families]
+
, cab_rhs :: Type
-- ^ Right-hand side of the equality
-- See Note [CoAxioms are homogeneous]
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -36,7 +36,7 @@ module GHC.Core.Predicate (
-- Equality left-hand sides
CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe,
- canEqLHSKind, canEqLHSType, eqCanEqLHS
+ canEqLHSKind, canEqLHSType, eqCanEqLHS, saturatedFamApp_maybe
) where
@@ -61,6 +61,8 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.FastString
+import GHC.Exts( inline )
+
{- *********************************************************************
* *
@@ -700,7 +702,9 @@ types/kinds are fully settled and zonked.
-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"
scopedSort :: [Var] -> [Var]
-scopedSort = go [] []
+scopedSort xs
+ | null xs = []
+ | otherwise = go [] [] xs
where
go :: [Var] -- already sorted, in reverse order
-> [TyCoVarSet] -- each set contains all the variables which must be placed
@@ -781,13 +785,19 @@ canEqLHS_maybe xi
| otherwise
= canTyFamEqLHS_maybe xi
-canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS
-canTyFamEqLHS_maybe xi
+saturatedFamApp_maybe :: Type -> Maybe (TyCon,[Type])
+saturatedFamApp_maybe xi
| Just (tc, args) <- tcSplitTyConApp_maybe xi
, isTypeFamilyTyCon tc
, args `lengthIs` tyConArity tc
- = Just $ TyFamLHS tc args
+ = Just (tc,args)
+ | otherwise
+ = Nothing
+canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS
+canTyFamEqLHS_maybe xi
+ | Just (tc, args) <- inline saturatedFamApp_maybe xi
+ = Just $ TyFamLHS tc args
| otherwise
= Nothing
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -1159,10 +1159,12 @@ nice tight loops.
{-# INLINE afvFolder #-} -- See Note [Any-free-var folder]
afvFolder :: TyCoFolder (FV (BoundVars, TyCoVar -> Bool) DM.Any)
-- 'afvFolder' is short for "any-free-var folder", good for checking
--- if any /deep/ free var of a type satisfies a predicate `check_fv`
+-- if any /shallow/ free var of a type satisfies a predicate `check_fv`
-- The "env" of the (FV env Any) is a pair (bvs,pred) of
-- the bound variables (which are definitely not free), and
-- an "interesting var" predicate which the client supplies
+--
+-- You can get "deep" by supplying a predicate that also looks in the kind
afvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms]
, tcf_tyvar = do_tcv
, tcf_covar = do_tcv
@@ -1173,8 +1175,7 @@ afvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms]
-- Check the variable itself with check_fv,
-- and check its kind (this is a deep folder)
do_tcv tcv = MkFV $ \ (bvs,check_fv) ->
- Any (not (tcv `elemVarSet` bvs) &&
- (check_fv tcv || runAny check_fv (afv_type (varType tcv))))
+ Any (not (tcv `elemVarSet` bvs) && check_fv tcv)
do_hole hole = do_tcv (coHoleCoVar hole)
afv_type :: Type -> FV (BoundVars, TyVar -> Bool) DM.Any
@@ -1186,16 +1187,32 @@ runAny :: (TyVar -> Bool) -> FV (BoundVars, TyCoVar -> Bool) DM.Any -> Bool
{-# INLINE runAny #-}
runAny check_fv fvs = DM.getAny (runFV fvs (emptyVarSet, check_fv))
+---------------------------------------------
+-- anyShallowFreeVarsOfType and friends look only for shallow free vars
+-- (Currently not needed, left here in case we need it one day)
+-- anyShallowFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool
+-- {-# INLINE anyShallowFreeVarsOfType #-}
+-- anyShallowFreeVarsOfType check_fv ty = runAny check_fv (afv_type ty)
+
+---------------------------------------------
+-- anyFreeVarsOfType and friends look for deep free vars
+
+deep_check :: (TyCoVar -> Bool) -> TyCoVar -> Bool
+-- This is inefficient because if one tyvar occurs many times
+-- in a type, it'll look in its kind at each occurrence. Boo.
+deep_check check_fv tcv = check_fv tcv || anyFreeVarsOfType check_fv (varType tcv)
+
anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool
{-# INLINE anyFreeVarsOfType #-}
-anyFreeVarsOfType check_fv ty = runAny check_fv (afv_type ty)
+-- Looks deeply, into the kinds of the free vars
+anyFreeVarsOfType check_fv ty = runAny (deep_check check_fv) (afv_type ty)
anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool
{-# INLINE anyFreeVarsOfTypes #-}
-anyFreeVarsOfTypes check_fv tys = runAny check_fv (afv_types tys)
+anyFreeVarsOfTypes check_fv tys = runAny (deep_check check_fv) (afv_types tys)
anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool
-anyFreeVarsOfCo check_fv co = runAny check_fv (afv_co co)
+anyFreeVarsOfCo check_fv co = runAny (deep_check check_fv) (afv_co co)
noFreeVarsOfType :: Type -> Bool
noFreeVarsOfType ty = not $ runAny (const True) (afv_type ty)
@@ -1206,6 +1223,7 @@ noFreeVarsOfTypes tys = not $ runAny (const True) (afv_types tys)
noFreeVarsOfCo :: Coercion -> Bool
noFreeVarsOfCo co = not $ runAny (const True) (afv_co co)
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -48,6 +48,8 @@ module GHC.Core.TyCo.Subst
substTyCoBndr,
substVarBndrUsing,
checkValidSubst, isValidTCvSubst,
+
+ deepSubstTy
) where
import GHC.Prelude
@@ -775,9 +777,15 @@ substThetaUnchecked = substTysUnchecked
-- building no thunks. See Note [Specialising mappers] in GHC.Core.TyCo.Make
type SubstM = StrictReaderT Subst StrictIdentity
-runSubstM :: SubstM a -> Subst -> a
-runSubstM m subst = runStrictIdentity (runStrictReaderT m subst)
+runSubstM :: forall a. (a -> SubstM a) -> Subst -> a -> a
{-# INLINE runSubstM #-}
+runSubstM tx subst x = runStrictIdentity (runStrictReaderT (tx x) subst)
+
+subst_ty :: Subst -> Type -> Type
+subst_co :: Subst -> Coercion -> Coercion
+(subst_ty, subst_co)
+ = case mapTyCo substTyCoMapper of
+ (ms_ty, _, ms_co, _) -> (runSubstM ms_ty, runSubstM ms_co)
substTyCoMapper :: TyCoMapper SubstM
substTyCoMapper
@@ -785,8 +793,8 @@ substTyCoMapper
, tcm_covar = subst_cv
, tcm_hole = subst_ch
, tcm_tycobinder = tcv_bndr
- , tcm_tcapp_ty = tcapp_ty
- , tcm_tcapp_co = tcapp_co
+ , tcm_tcapp_ty = nopTcAppTy
+ , tcm_tcapp_co = nopTcAppCo
}
where
subst_tv tv = StrictReaderT $ \subst -> return (substTyVar subst tv)
@@ -802,23 +810,15 @@ substTyCoMapper
-- Avoid allocation in this very
-- common case (E.g. Int, LiftedRep etc)
- tcapp_ty :: Type -> TyCon -> [Type] -> SubstM Type
- tcapp_ty ty tc tys'
- | null tys' = return ty
- | otherwise = return (mkTyConApp tc tys')
- tcapp_co :: Coercion -> Role -> TyCon -> [Coercion] -> SubstM Coercion
- tcapp_co co r tc cos'
- | null cos' = return co
- | otherwise = return (mkTyConAppCo r tc cos')
+nopTcAppTy :: Type -> TyCon -> [Type] -> SubstM Type
+nopTcAppTy ty tc tys'
+ | null tys' = return ty
+ | otherwise = return (mkTyConApp tc tys')
-subst_ty :: Subst -> Type -> Type
-subst_co :: Subst -> Coercion -> Coercion
-(subst_ty, subst_co)
- = case mapTyCo substTyCoMapper of
- (ms_ty, _, ms_co, _) -> (run ms_ty, run ms_co)
- where
- run :: forall a. (a -> SubstM a) -> Subst -> a -> a
- run ms subst x = runSubstM (ms x) subst
+nopTcAppCo :: Coercion -> Role -> TyCon -> [Coercion] -> SubstM Coercion
+nopTcAppCo co r tc cos'
+ | null cos' = return co
+ | otherwise = return (mkTyConAppCo r tc cos')
substTyVar :: Subst -> TyVar -> Type
substTyVar (Subst _ _ tenv _) tv
@@ -1019,3 +1019,86 @@ it is /very/ valuable to /keep/ it empty:
If the substitution is empty, this is a no-op -- but only if it
is empty!
-}
+
+
+{- **********************************************************************
+%* *
+ Deep substitution
+%* *
+%********************************************************************* -}
+
+{- Note [Deep substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deep substitution applies the substitution to the /kinds/ of un-substituted
+type variables. Suppose the substitution is
+ [ k :-> Type ]
+and we apply it to the type
+ Proxy k (a :: k)
+Ordinary shallow substitution will give
+ Proxy Type (a :: k)
+which is ill-kinded. Deep substitution will give
+ Proxy Type (a :: Type)
+
+Ordinary (shallow) substitution is usually fine, because we will substitute for
+`a` as well, but not always. In particular, the pure unifier in GHC.Core.Unify
+uses `niFixSubst` to find a fixpoint, and we really don't want domain tyvars
+appearing in the range. See Note [Finding the substitution fixpoint].
+
+Wrinkles:
+
+(DS1) Deep substitution risks being rather inefficient because it re-applies the
+ substitution to the kind at /each occurrence/ of a free variable. We could
+ perhaps find the free vars, and build a re-kinding substitution, but that's a
+ bit more complicated.
+
+(DS2) Deep substitution, as implemented here, relies on invariant
+ (NoTypeShadowing); see Note [No type-shadowing in Core] in Core.hs.
+ Otherwise we may have e.g.
+ S = [r :-> LiftedRep] in-scope = {r, x}
+ T = forall (r :: RuntimeRep). (x :: TYPE r) -> ...
+ and we would want to apply the outer substitution S to the
+ occurrence of r in the kind of x. But we'll have removed it
+ from the subsitution when pasing the 'forall r'.
+-}
+
+deepSubstTyCoMapper :: TyCoMapper SubstM
+deepSubstTyCoMapper
+ = TyCoMapper { tcm_tyvar = subst_tv
+ , tcm_covar = subst_cv
+ , tcm_hole = subst_ch
+ , tcm_tycobinder = tcv_bndr
+ , tcm_tcapp_ty = nopTcAppTy
+ , tcm_tcapp_co = nopTcAppCo
+ }
+ where
+ subst_tv tv = StrictReaderT $ \subst -> return (deepSubstTyVar subst tv)
+ subst_cv cv = StrictReaderT $ \subst -> return (deepSubstCoVar subst cv)
+ subst_ch ch = StrictReaderT $ \subst -> return (deepSubstCoHole subst ch)
+
+ tcv_bndr :: TyCoVar -> ForAllTyFlag -> (TyCoVar -> SubstM r) -> SubstM r
+ tcv_bndr tcv _vis k
+ = StrictReaderT $ \subst ->
+ let !(subst', tcv') = substVarBndrUsing deepSubstTy subst tcv
+ in runStrictReaderT (k tcv') subst'
+
+deepSubstTy :: Subst -> Type -> Type
+deepSubstTy = case mapTyCo deepSubstTyCoMapper of
+ (subst_ty, _, _, _) -> runSubstM subst_ty
+
+deepSubstTyVar :: Subst -> TyVar -> Type
+deepSubstTyVar subst@(Subst _ _ tenv _) tv
+ = assert (isTyVar tv) $
+ case lookupVarEnv tenv tv of
+ Just ty -> ty
+ Nothing -> TyVarTy (updateVarType (deepSubstTy subst) tv)
+
+deepSubstCoVar :: Subst -> CoVar -> Coercion
+deepSubstCoVar subst@(Subst _ _ _ cenv) cv
+ = case lookupVarEnv cenv cv of
+ Just co -> co
+ Nothing -> CoVarCo (updateVarType (deepSubstTy subst) cv)
+
+deepSubstCoHole :: Subst -> CoercionHole -> Coercion
+-- See Note [Substituting in a coercion hole]
+deepSubstCoHole subst h@(CH { ch_co_var = cv })
+ = HoleCo (h { ch_co_var = updateVarType (deepSubstTy subst) cv })
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -483,7 +483,7 @@ expandTypeSynonyms ty
expandTypeSynonymsX :: Subst -> Type -> Type
expandTypeSynonymsX
= case mapTyCo expandTypeSynonymMapper of
- (exp_ty, _, _, _) -> \subst ty -> runSubstM (exp_ty ty) subst
+ (exp_ty, _, _, _) -> runSubstM exp_ty
expandTypeSynonymMapper :: TyCoMapper SubstM
-- Just like substitution, but treat TyConApp specially
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -28,13 +28,12 @@ import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.Type hiding ( getTvSubstEnv )
import GHC.Core.Coercion hiding ( getCvSubstEnv )
-import GHC.Core.Predicate( scopedSort )
import GHC.Core.TyCon
import GHC.Core.Predicate( CanEqLHS(..), canEqLHS_maybe )
import GHC.Core.TyCon.Env
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare ( eqType, tcEqType, tcEqTyConAppArgs )
-import GHC.Core.TyCo.Subst ( mkTvSubst )
+import GHC.Core.TyCo.Subst ( mkTvSubst, deepSubstTy )
import GHC.Core.Map.Type
import GHC.Core.Multiplicity
@@ -1063,21 +1062,31 @@ During unification we use a TvSubstEnv/CvSubstEnv pair that is
Note [Finding the substitution fixpoint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Finding the fixpoint of a non-idempotent substitution arising from a
-unification is much trickier than it looks, because of kinds. Consider
+We want an /idempotent/ substitution, so `niFixSubst` takes a non-idempotent
+one and composes it with itself until it becomes idempotent. Thus if the original
+is S0, we compute S1 = S0 o S0, S2 = S1 o S1, etc.
+
+A variable chain v0 :-> v1 :-> ... :-> vm therefore takes about log2(m) rounds,
+The unifier can build such chains. For example:
+ (a, a, a, ..., a) ~ (x1, x2, x3, ..., xm)
+produces a :-> x1, x1 :-> x2, ..., x(m-1) :-> xm.
+
+Finding the fixpoint is much trickier than it looks, because of kinds.
+Consider
T k (H k (f:k)) ~ T * (g:*)
If we unify, we get the substitution
[ k -> *
, g -> H k (f:k) ]
+This isn't idempotent: it mentions `k` in the range.
+
To make it idempotent we don't want to get just
[ k -> *
, g -> H * (f:k) ]
-We also want to substitute inside f's kind, to get
- [ k -> *
- , g -> H k (f:*) ]
-If we don't do this, we may apply the substitution to something,
-and get an ill-formed type, i.e. one where typeKind will fail.
+because (H * (f:k)) is itself ill-kinded, and `typeKind` will fail.
This happened, for example, in #9106.
+So (yuckily) we must also substitute inside f's kind, to get
+ [ k -> *
+ , g -> H * (f:*) ]
It gets worse. In #14164 we wanted to take the fixpoint of
this substitution
@@ -1090,84 +1099,53 @@ the invocation of F! We don't have a function that recursively
applies substitutions inside the kinds of variable occurrences (and
probably rightly so).
-So, we work as follows:
-
- 1. Start with the current substitution (which we are
- trying to fixpoint
- [ xs :-> F a (z :: a) (rest :: G a (z :: a))
- , a :-> b ]
-
- 2. Take all the free vars of the range of the substitution:
- {a, z, rest, b}
- NB: the free variable finder closes over
- the kinds of variable occurrences
-
- 3. If none are in the domain of the substitution, stop.
- We have found a fixpoint.
-
- 4. Remove the variables that are bound by the substitution, leaving
- {z, rest, b}
-
- 5. Do a topo-sort to put them in dependency order:
- [ b :: *, z :: a, rest :: G a z ]
-
- 6. Apply the substitution left-to-right to the kinds of these
- tyvars, extending it each time with a new binding, so we
- finish up with
- [ xs :-> ..as before..
- , a :-> b
- , b :-> b :: *
- , z :-> z :: b
- , rest :-> rest :: G b (z :: b) ]
- Note that rest now has the right kind
-
- 7. Apply this extended substitution (once) to the range of the
- /original/ substitution. (Note that the extended substitution
- would go on forever if you tried to find its fixpoint, because it
- maps z to z.)
-
- 8. And go back to step 1
-
-In Step 6 we use the free vars from Step 2 as the initial
-in-scope set, because all of those variables appear in the
-range of the substitution, so they must all be in the in-scope
-set. But NB that the type substitution engine does not look up
-variables in the in-scope set; it is used only to ensure no
-shadowing.
+Ugh! This whole thing is pretty horrible. But the solution is simple enough:
+
+ Use deep substitution (deepSubstTy)
+
+(deepSubst `s` (Proxy k (a::k)) applies the substitution `s` not only to
+the occurrence of `k` in the argument of `Proxy`, but also to the `k` inside
+the kind of `a`. See Note [Deep substitution] in GHC.Core.TyCo.Subst.
+
+So `niFixSubst` just applies the substitution /deeply/ to the types in its
+range, until we reach a fixed point. Easy!
+
+Historical Note:
+ Immediately prior to this solution there was a previous, more complicated
+ `niFixSubst` which involved finding the (deep) free variables and "re-kinding"
+ them. It accomplished essentially the same things, and it avoided the
+ potential duplication noted in Note [Deep substitution]. But it was pretty
+ subtle and this version is more obviously correct.
+End of Historical Note
-}
niFixSubst :: InScopeSet -> TvSubstEnv -> Subst
-- Find the idempotent fixed point of the non-idempotent substitution
-- This is surprisingly tricky:
-- see Note [Finding the substitution fixpoint]
--- ToDo: use laziness instead of iteration?
niFixSubst in_scope tenv
- | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv)
- | otherwise = tenv_subst
+ | isEmptyVarEnv tenv -- Fast path for common case
+ = mkEmptySubst in_scope
+ | otherwise
+ = -- pprTrace "niFixSubst" (vcat [ text "In: " <+> ppr tenv
+ -- , text "Out:" <+> ppr (S.getTvSubstEnv subst) ])
+ subst
where
- tenv_subst = mkTvSubst in_scope tenv -- This is our starting point
-
- range_tvs :: [TyVar]
- range_tvs = nonDetVarSetElems $
- tyCoVarsOfTypes $
- nonDetEltsUFM tenv
- -- It's OK to use nonDetEltsUFM (twice) here because
- -- the order of range_tvs is immaterial
-
- not_fixpoint = any in_domain range_tvs
- in_domain tv = tv `elemVarEnv` tenv
+ subst = niFixSubst' 1 in_scope tenv
- free_tvs = scopedSort (filterOut in_domain range_tvs)
-
- -- See Note [Finding the substitution fixpoint], Step 6
- subst = foldl' add_free_tv tenv_subst free_tvs
-
- add_free_tv :: Subst -> TyVar -> Subst
- add_free_tv subst tv
- | isTyVar tv = extendTvSubst subst tv (mkTyVarTy tv')
- | otherwise = subst -- Ignore free coercion variables
- where
- tv' = updateTyVarKind (substTy subst) tv
+niFixSubst' :: Int -> InScopeSet -> TvSubstEnv -> Subst
+niFixSubst' n in_scope tenv_orig
+ | fixpoint_found = mkTvSubst in_scope tenv_orig
+ | otherwise = niFixSubst' (n+1) in_scope tenv_new
+ where
+ in_dom tv = tv `elemVarEnv` tenv_orig
+ tenv_new = mapVarEnv (deepSubstTy subst) tenv_orig
+ subst = mkTvSubst in_scope tenv_orig
+
+ fixpoint_found = nonDetStrictFoldUFM and_fix True tenv_orig
+ and_fix :: Type -> Bool -> Bool
+ and_fix _ False = False
+ and_fix ty _ = not (anyFreeVarsOfType in_dom ty)
{-
************************************************************************
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Driver.Env
+import GHC.Core.Predicate( saturatedFamApp_maybe )
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.TyCon
@@ -715,15 +716,9 @@ reportInjectivityErrors dflags fi_ax axiom inj
when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom
-- | Is type headed by a type family application?
-isTFHeaded :: Type -> Bool
-- See Note [Verifying injectivity annotation], case 3.
-isTFHeaded ty | Just ty' <- coreView ty
- = isTFHeaded ty'
-isTFHeaded ty | (TyConApp tc args) <- ty
- , isTypeFamilyTyCon tc
- = args `lengthIs` tyConArity tc
-isTFHeaded _ = False
-
+isTFHeaded :: Type -> Bool
+isTFHeaded ty = isJust (saturatedFamApp_maybe ty)
-- | If a RHS is a bare type variable return a set of LHS patterns that are not
-- bare type variables.
=====================================
compiler/GHC/Tc/Solver/FunDeps.hs
=====================================
@@ -24,16 +24,16 @@ import GHC.Tc.Types.Constraint
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.TyCo.Rep( Type(..) )
-import GHC.Core.Predicate( EqRel(..) )
+import GHC.Core.TyCo.Subst( deepSubstTy, elemSubst, extendTvSubstWithClone )
+import GHC.Core.Predicate( EqRel(..), saturatedFamApp_maybe )
import GHC.Core.TyCon
import GHC.Core.Unify( AmIUnifying(..)
, tcUnifyTysForInjectivity, typeListsAreApart )
import GHC.Core.Coercion.Axiom
-import GHC.Core.TyCo.Subst( elemSubst, extendTvSubstWithClone )
import GHC.Builtin.WiredIn.TypeLits( tryInteractTopFam, tryInteractInertFam )
-import GHC.Types.Var( TyVar, tyVarKind, setTyVarKind )
+import GHC.Types.Var( TyVar, updateVarType, tyVarKind )
import GHC.Types.Var.Set
import GHC.Types.Var.Env( mkInScopeSet )
@@ -57,7 +57,6 @@ Here is our plan for dealing with functional dependencies
* send the current constraint back to the start of the pipeline;
it might now be soluble, and it probably isn't inert
-
* Once a unification is done, it can't be un-done. So we must be very careful
not to threaten completeness by doing a unification when there might be
another way to solve the constraint.
@@ -613,6 +612,7 @@ tryFamEqFunDeps mode eqs_for_me fam_tc work_args
mkTopFamEqFDs :: TyCon -> [TcType] -> EqCt -> SolverStage [FunDepEqns]
mkTopFamEqFDs fam_tc work_args work_item
+ -- NB: work_args exactly saturate fam_tc
| isOpenTypeFamilyTyCon fam_tc
, Injective inj_flags <- tyConInjectivityInfo fam_tc
= -- Open, injective type families
@@ -694,6 +694,8 @@ hasRelevantGiven eqs_for_me work_args (EqCt { eq_rhs = work_rhs })
getRelevantBranches :: CoAxiom Branched -> [TcType] -> Xi -> [FunDepEqns]
-- Return the FunDepEqns that arise from each relevant branch
-- Implements Note [Relevance]
+-- Caller will only use these FunDepEqns if there is just one relevant
+-- equation, i.e. the returned [FunDepEqns] is a singleton.
getRelevantBranches ax work_args work_rhs
= go (fromBranches (coAxiomBranches ax))
where
@@ -709,24 +711,33 @@ getRelevantBranches ax work_args work_rhs
, cab_lhs = lhs_tys
, cab_rhs = rhs_ty })
| Just subst <- tcUnifyTysForInjectivity Unifying (rhs_ty:lhs_tys) work_tys
- -- See (RW1)-(RW3) in Note [Relevance]
- -- This is a pre-/unification/ check (not matching)
- -- so `subst` can bind both `qtvs` and fvs(work_tys)
- , let (subst',qtvs') = trim_qtvs subst qtvs
- lhs_tys' = substTys subst' lhs_tys
- rhs_ty' = substTy subst' rhs_ty
- branch_tys' = rhs_ty' : lhs_tys'
+ -- See (RW1)-(RW3) in Note [Relevance]
+ , let lhs_tys' = map (deepSubstTy subst) lhs_tys
+ -- deepSubstTy: see (CF8) in Note [Exploiting closed type families]
, noEarlierMatchCheck lhs_tys' branch -- See (RW4) in Note [Relevance]
- = Just (FDEqns { fd_qtvs = qtvs'
- , fd_eqs = zipWith Pair branch_tys' work_tys })
- -- Do not apply the substition to `work_tys`;
- -- See (CF7) in Note [Exploiting closed type families]
+ = -- Ignore the substitution, except for `noEarlierMatchCheck`
+ Just $
+ if all (`elemSubst` subst) qtvs
+ then -- `subst` eliminates all qtvs; and no qtvs in range of subst
+ -- See (CF7)(A) in Note [Exploiting closed type families]
+ FDEqns { fd_qtvs = []
+ , fd_eqs = zipWith Pair (substTy subst rhs_ty : lhs_tys')
+ work_tys }
+ -- Do not apply `subst` to `work_tys`;
+ -- See (CF9) in Note [Exploiting closed type families]
+
+ else -- Abandon `subst`; re-create it from (rhs_ty ~ work_rhs)
+ -- See (CF7)(B) in Note [Exploiting closed type families]
+ FDEqns { fd_qtvs = qtvs
+ , fd_eqs = zipWith Pair (rhs_ty:lhs_tys) work_tys }
+
| otherwise
= Nothing
mkTopOpenFamEqFDs :: TyCon -> [Bool] -> [TcType] -> EqCt -> TcS [FunDepEqns]
-- Implements (INJFAM:Wanted/top-open)
-- See Note [Exploiting open type families]
+-- NB: work_args exactly saturate fam_tc
mkTopOpenFamEqFDs fam_tc inj_flags work_args (EqCt { eq_rhs = work_rhs })
= do { fam_envs <- getFamInstEnvs
; let branches :: [CoAxBranch]
@@ -739,11 +750,14 @@ mkTopOpenFamEqFDs fam_tc inj_flags work_args (EqCt { eq_rhs = work_rhs })
, cab_lhs = branch_lhs_tys
, cab_rhs = branch_rhs })
| Just subst <- tcUnifyTysForInjectivity Matching [branch_rhs] [work_rhs]
- , let (subst', qtvs') = trim_qtvs subst branch_qtvs
+ -- No need for an apartness check here;
+ -- for open type families there are no "preceding" equations
+ -- Both branch_lhs_tys and work_args exactly saturate fam_tc
+ , let (subst', qtvs') = trimQtvs subst branch_qtvs
branch_lhs_tys' = substTys subst' branch_lhs_tys
- -- No need for an apartness check here; for open type families
- -- there are no "preceding" equations
- = Just (mkInjectivityFDEqn inj_flags qtvs' branch_lhs_tys' work_args)
+ -- We must apply the substitution here see
+ -- the Basic Plan in Note [Exploiting open type families]
+ = Just (mkInjectivityFDEqn qtvs' inj_flags branch_lhs_tys' work_args)
| otherwise
= Nothing
@@ -756,9 +770,9 @@ mkLocalFamEqFDs eqs_for_me fam_tc inj_flags work_args work_rhs
= do { let -- eqns_from_inerts: see (INJFAM:Wanted/other)
eqns_from_inerts = mapMaybe do_one eqs_for_me
-- eqns_from_self: see (INJFAM:Wanted/Self)
- eqns_from_self = case tcSplitTyConApp_maybe work_rhs of
- Just (tc,rhs_tys) | tc==fam_tc -> [mk_eqn rhs_tys]
- _ -> []
+ eqns_from_self = case saturatedFamApp_maybe work_rhs of
+ Just (tc, rhs_tys) | fam_tc == tc -> [mk_eqn rhs_tys]
+ _ -> []
; return (eqns_from_inerts ++ eqns_from_self) }
where
@@ -768,11 +782,12 @@ mkLocalFamEqFDs eqs_for_me fam_tc inj_flags work_args work_rhs
| otherwise = Nothing
do_one _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS
- mk_eqn iargs = mkInjectivityFDEqn inj_flags [] work_args iargs
+ mk_eqn iargs = mkInjectivityFDEqn [] inj_flags work_args iargs
+
-trim_qtvs :: Subst -> [TyVar] -> (Subst, [TyVar])
--- Tricky stuff: see (OF1) in Note [Exploiting open type families]
-trim_qtvs unif_subst qtvs
+trimQtvs :: Subst -> [TyVar] -> (Subst, [TyVar])
+-- Tricky stuff: see Note [Exploiting open type families] and Note [trimQtvs]
+trimQtvs unif_subst qtvs
= go unif_subst qtvs
where
go :: Subst -> [TyVar] -> (Subst, [TyVar])
@@ -786,10 +801,9 @@ trim_qtvs unif_subst qtvs
go_fresh subst tv tvs = (subst'', tv':tvs')
where
!(subst'', tvs') = go subst' tvs
- tv' = tv `setTyVarKind` substTy subst (tyVarKind tv)
+ tv' = updateVarType (substTy subst) tv
subst' = extendTvSubstWithClone subst tv tv'
- -- extendTvSubstWithClone: see (OF1b) in
- -- Note [Exploiting open type families]
+ -- extendTvSubstWithClone: see (TQ1) in Note [trimQtvs]
-----------------------------------------
@@ -883,15 +897,22 @@ mkLocalBuiltinFamEqFDs eqs_for_me fam_tc ops work_args work_rhs
; return (eqns_from_inerts ++ eqns_from_self) }
--------------------
-mkInjectivityFDEqn :: [Bool] -- Injectivity flags
- -> [TcTyVar] -- Quantify these
+mkInjectivityFDEqn :: [TcTyVar] -- Quantify these
+ -> [Bool] -- Injectivity flags
-> [TcType] -> [TcType] -- Make these equal
-> FunDepEqns
-- When F s1 s2 s3 ~ F t1 t2 t3, and F has injectivity info [True,False,True]
-- return the FDEqns { fd_eqs = [Pair s1 t1, Pair s3 t3] }
--- The injectivity flags [Bool] will not all be False, but nothing goes wrong if they are
-mkInjectivityFDEqn inj_args qtvs lhs_args rhs_args
- = FDEqns { fd_qtvs = qtvs, fd_eqs = eqs }
+-- The injectivity flags [Bool] will not all be False,
+-- but nothing goes wrong if they are
+mkInjectivityFDEqn qtvs inj_args lhs_args rhs_args
+ = assertPpr (let len = length inj_args in
+ len == length lhs_args && len == length rhs_args)
+ (vcat [ text "inj_args:" <+> ppr inj_args
+ , text "lhs_args:" <+> ppr lhs_args
+ , text "rhs_args:" <+> ppr rhs_args ]) $
+ -- Need inj_args lhs_args and rhs_args to be same length for zip3
+ FDEqns { fd_qtvs = qtvs, fd_eqs = eqs }
where
eqs = [ Pair lhs_arg rhs_arg
| (True, lhs_arg, rhs_arg) <- zip3 inj_args lhs_args rhs_args ]
@@ -1096,73 +1117,108 @@ Note [Exploiting closed type families].
Note [Exploiting open type families] see `mkTopOpenFamEqFDs`
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generating fundeps from a top-level type instance is covered in Section 5.2 in
-the Injective Type Families paper. For open type families, suppose we have
-
- type family F a = r | r -> a
- type instance F [a] = a->a
-
- [W] F alpha ~ Int->Int
-
-Then, since F has been checked as injective, and the RHS `a->a` (pre-)unifies
-with the `Int->Int` in the Wanted with substitution [a :-> Int], we can
-add a derived FunDepEqns
+For an open type family, generating fundeps from a top-level type instance
+is covered in Section 5.2 in the Injective Type Families paper.
+
+Basic plan: Suppose type family F a b = r | r -> b
+ and Wanted [W] F wlhs1 wlhs2 ~ wrhs
+ Then for each type instance (F lhs1 lhs2 = rhs)
+ * Pre-match `rhs` against `wrhs` to get a substitution S
+ * Generate fundep equalities S(lhs2) ~ wrhs
+ one for each fundep in the type family
+
+For example, suppose we have
+ type family F a b = r | r -> a
+ type instance F [a] Int = a->a
+ [W] F alpha beta ~ Int->Int
+Then we pre-match template (a->a) against target (Int->Int) to get
+substitution S = [a :-> Int]. Then we can generate
FDEqns{ fd_qtvs = [], fd_eqs = [ [Int] ~ alpha ] }
and thereby emit (via `instantiateFunDepEqns`)
[W] [Int] ~ alpha
+Note that `fd_qtvs = []`; we have substituted away the quantifed type variable `a`.
Things are a bit trickier when not all the quantified variables of the
instance are bound by the pre-unification step. Suppose we have
-
type family F a = r | r -> a
- type instance F (Maybe a) = [G a] -- G is a type family
+ type instance F (b -> Maybe a) = [(G a,b)] -- G is a type family
+ [W] F alpha ~ [(ty,Int)]
- [W] F alpha ~ [ty]
-
-Then, the RHS [G a] pre-unifies with the RHS of the Wanted, but with an
-empty substitution, which does not fix `a`. So we get this FunDepEqns:
- FDEqns{ fd_qtvs = a, fd_eqs = [ Maybe a ~ alpha ] }
+Then, the RHS [(G a,b)] pre-matches with the RHS of the Wanted, but with
+the substitution [b :-> Int], which does not fix `a`. So, after trimming
+the quantified type variables, we get this FunDepEqns:
+ FDEqns{ fd_qtvs = [a], fd_eqs = [ (Int -> Maybe a) ~ alpha ] }
(note the fd_qtvs=a) and thereby emit (via `instantiateFunDepEqns`)
- [W] Maybe gamma ~ alpha -- Fresh gamma
-We have learned that `alpha` must be a list, but that is all; we don't
-know what is inside it, hence the fresh `gamma`.
-
-In general we have:
-
- type family F x1 ... xn = r | r -> x1 x3 (say)
- type instance forall qs. F t1 ... tn = rhs
- [W] F a1 ... an ~ b
-
-Suppose `b` pre-unifies with `rhs`, with substitution `S` that binds
-some (but perhaps not all) of the `qs`. Lets say
- unbound_qs = qs \ dom(S)
-
-Then we generate the FunDepEqs
- FDEqns{ fd_qtvs = unbound_qs
- , fd_eqs = [ S(t1) ~ S(a1), S(t3) ~ S(a3) ]
-
-These 'fd_qtvs' are subsequently instantiated to fresh metavariables by
-'instantiateFunDepEqns'.
-
-(OF1) The computation of `unbound_qs` is done by `trim_qtvs`, but we
- have to be careful. Suppose (OF1a)
- qs = [ k::*, a::k ]
- S = [ k :-> UnliftedType ]
- Then we want
- unbound_qs = [ a::UnliftedType ] -- Must apply S to q's kind!!
-
- And (OF1b), although I'm not sure if this can acutally happen:
- qs = [ k::*, a::(k::*), b::(a::k) ]
- S = [ k :-> UnliftedType ]
- We want
- unbound_qs = [ a::UnliftedType, b::(a::UnliftedType) ]
- Note that the occurrence of `a` in b's kind should be replaced by the
- newly-kinded `a` not the original `a::k`.
-
- This fancy footwork for `fd_qtvs` is done by `trim_qtvs`. It
- * Drops a quantified tyvar that /is/ matched
- * Substitutes in the kind of a quantified tyvar `a` that is /not/ matched
- * Adds the substitution [a::k :-> a::S(k)] to the substitution
+ [W] (Int -> Maybe gamma) ~ alpha -- Fresh gamma
+We have learned that `alpha` must be a list of functions, but that is all;
+we don't know `gamma`.
+
+It gets tricker. Suppose we have
+ type family F @k a = r | r -> k,a
+ type instance F @k (Proxy @k (a::k)) = T k
+ [W] F alpha beta ~ T Type
+Matching the RHS gives substitution [k :-> Type]. But we do /not/ want
+to end up with this:
+ FDEqns{ fd_qtvs = [a::k], fd_eqs = [ Proxy @Type (a::k) ~ alpha ] }
+because that `k`, hidden inside the kind of `a`, escapes into the solver.
+
+Instead we must not only "trim" the quantified variables of the equation,
+but /substitute/ in the kinds of the leftover quantified ones: see Note [trimQtvs].
+Then we get
+ FDEqns{ fd_qtvs = [a::Type], fd_eqs = [ Proxy @Type (a::Type) ~ alpha ] }
+
+Side note:
+
+You might wonder whether we can use the same solution as we do for /closed/
+families, by generating an equality for the RHSs; see (CF7). But we can't.
+Example:
+ type family G a where G Int = Char
+ type family F a b = r | r -> a
+ type instance F a [c] = (a, G a) -- (I1)
+ type instance F Int Bool = (Int, Bool) -- (I2)
+ [W] F alpha Bool ~ (Int,gamma)
+Note that (I1) and (I2) are pariwise-injective: if the RHSs are the same,
+the LHSs are the same /in the injective position(s)/. See Section 4.2 in
+the "Injective Type Families" paper. We pre-match (I1) against the Wanted
+giving substitution [a :-> Int]. We /cannot/ then generate
+ FDEqns { fd_qtvs = [a,c], fd_eqs = [ a~alpha
+ , (a,G a)~(Int,gamma) ] }
+where the second equality (wrongly)equates the RHSs. This is wrong because we
+can solve those fundeps unifying alpha:=Int, gamma:=Char, by reducing (G a) to
+Char. So we end up with [W] F Int Char, which is insoluble. Bad.
+
+End of side note.
+
+Note [trimQtvs]
+~~~~~~~~~~~~~~~
+In Note [Exploiting open type families], we needed to "trim" the quantified
+type variables of the axiom, removing ones that are eliminated by the
+auubstitution `S`. So can we just do this?
+ unbound_qs = qs \ dom(S)
+so that we could make fresh meta-variables for only the unbound `qs`.
+No, we can't. Suppose (TQ1)
+ qs = [ k::*, a::k ]
+ S = [ k :-> UnliftedType ]
+Then we want
+ unbound_qs = [ a::UnliftedType ] -- Must apply S to q's kind!!
+
+And (TQ2), although I'm not sure if this can actually happen:
+ qs = [ k::*, a::(k::*), b::(a::k) ]
+ S = [ k :-> UnliftedType ]
+We want
+ unbound_qs = [ a::UnliftedType, b::(a::UnliftedType) ]
+Note that the occurrence of `a` in b's kind should be replaced by the
+newly-kinded `a` not the original `a::k`.
+
+The function `trimQtvs` does the job. It
+ * Drops a quantified tyvar that /is/ matched
+ * Substitutes in the kind of a quantified tyvar `a` that is /not/ matched
+ * Adds the substitution [a::k :-> a::S(k)] to the substitution
+
+We only use `trimQtvs` for /open/ families. For /closed/ families where we
+/unify/ (rather than match) the equation with the Wanted, it just doesn't work
+(#27994), because the substitution `S` has both meta-tyvars and instance-head
+tyvars in the range. See (CF7).
Note [Exploiting closed type families] see `mkTopClosedFamEqFDs`
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1194,9 +1250,6 @@ More precisely, here is the very clever Closed Family Fundep Algorithm (CFFA)
with fresh unification vars in lhs and rhs for the quantified variables of the
equation.
- Actually we take advantage of the substitution generated by the relevance
- check, see (CF7) below.
-
See Note [Relevance] for what "relevant" means.
We need to take care about non-termination; see (CF3).
@@ -1303,7 +1356,7 @@ Key point: equations that are not relevant do not need to be considered for fund
I was looking at non-termination for closed type families, but it's a small
improvement in general.
- This bale-out is implementedn in `tryFDEqns`.
+ This bale-out is implemented in `tryFDEqns`.
(CF5) Consider (see "Yikes5" in #23162):
type family F a where
@@ -1353,32 +1406,20 @@ Key point: equations that are not relevant do not need to be considered for fund
`app` Proxy @'[ty_n]
Every `app` call gives rise to a Wanted of the form:
-
[W] MapId acc_i ++ MapId '[ty_i] ~ MapId (acc_i ++ '[ty_i])
-
while the overall result type gives us a Wanted of the form
-
[W] acc_n ++ '[ty_n] ~ [ty_1, ..., ty_n]
-
By using (CFFA) on this result Wanted, we deduce that we must have
-
acc_n ~ [ty_1, ..., ty_{n-1}]
-
which is a flat list. Repeating the process, (CFFA) allows us to deduce that
-
acc_i ~ [ty_1, ..., ty_{i-1}]
-
for all i. This allows the other Wanteds to be solved directly, giving rise to
proof terms with the typical triangular O(n^2) shape
-
co_i = (O(i) proof that MapId acc_i ++ MapId '[ty_i] ~ acc_{i+1})
; (O(i) proof that acc_{i+1} ~ MapId (acc_i ++ '[ty_i]))
-
However, /without/ (CFFA), 'acc_i' is not unified with a flat list but is left
as the nested application:
-
acc_i ~ (... (('[ty_1] ++ '[ty_2]) ++ '[ty_3]) ... ++ '[ty_{i-1}])
-
This means that 'MapId acc_i' is stuck until we reduce the above, which takes
O(i^2) type family reduction steps, instead of O(i). The same applies to
the other proof term involving 'MapId (acc_i ++ '[ty_i])'.
@@ -1388,29 +1429,77 @@ Key point: equations that are not relevant do not need to be considered for fund
instead of relying on recursively built sub-proof terms, which brings down
coercion sizes (in certain situations) from O(n^3) to O(n^2).
-(CF7) Relevance. When computing relevance in the Closed Family Fundep Algorithm,
- for [W] F wlhs1 wlhs2 ~ wrhs, against an equation F lhs1 lhs2 ~ rhs
- we get back a pre-unifying substitution S that makes the two as equal as poss.
- Then we use `trim_qtvs` in exactly the same way as in
- (OF1) of Note [Exploiting open type families], to generate qtvs' and S'
- Then we generate
- FDEqns { fd_qtvs = qtvs', fd_eqs [ S'(lhs1) ~ wlhs1
- , S'(lhs2) ~ wlhs2
- , S'(rhs) ~ wrhs ] }
- Notice that we do /not/ apply S' to wlhs/wrhs. These type contain unification
- variables that we must actually unify! Example
+(CF7) Relevance. The function `getRelevantBranches` finds the relevant branch(es)
+ using the (CFFA). Given an equation
+ type family F a b where { ...; F lhs1 lhs2 = rhs; ... }
+ is the equation relevant for this Wanted?
+ [W] F wlhs1 wlhs2 ~ wrhs
+ We pre-unify [wrhs,wlhs1,wlhs2] against [rhs,lhs1,lhs2], getting back a
+ substitution `S` that makes the two as equal as poss. This substitution can bind
+ both /quantified/ type variables from the instance, and /unification variables/
+ from the solver. Moreover, both kind of type variable can appear in the range
+ of the substitution.
+
+ That's pretty complicated, so we are very cautious about using the returned
+ substitution `S`. I had a long struggle (#27994) when we were previously trying to
+ apply that returned substitution as an optimisation. But because type variables
+ can occur in kinds, it was a losing battle -- I ended up with TyVars from the
+ instance head escaping into the solver. Consider
+ type F :: forall k. k -> *
+ type instance F k a where
+ F (k->*) (b::k->*) = Int
+ [W] F kappa (alpha::kappa) ~ Int
+ We unify the Wanted with the equation to get the substitution
+ [ kappa :-> k->*, b :-> (alpha::k->*) ]
+ I tried using `trimQtvs` (see Note [trimQtvs]) but my head hurt
+ FAR too much: #27994 is an excellent example.
+
+ So here's the plan:
+ (A) As a fast-path optimisation, if `S` binds all the quantified variables of
+ the type-family equation (which is common), it's all easy: generate
+ FDEqns { fd_qtvs = []
+ , fd_eqs = [ S(lhs1) ~ wlhs1, S(lhs2) ~ wlhs2, S(rhs) ~ wrhs }
+ Note that we do not apply S to `wlhs1/2` or `wrhs`; see (CF9).
+ And note that `fd_qtvs` is empty, because `S` eliminates all the quantified
+ type variables.
+
+ (B) If not, then /discard `S` entirely/ and instead generate
+ FDEqns { fd_qtvs = qtvs
+ , fd_eqs = [ lhs ~ wlhs1, lhs2 ~ wlhs2, rhs ~ wrhs }
+ Now `instantiateFDEqns` will generate fresh unification variables for the
+ `qtvs` and the solver will in effect reconstruct `S`.
+
+(CF8) When computing relevance (Note [Relevance] (R2)) we use `noEarlierMatch`
+ on S(lhs). But we must use /deep/ substitution on LHS. Consider
+ type family F (a :: k) r where
+ F @Type (Maybe Bool) r = r -- B0
+ F @Type ((f :: Type -> Type) Int) r = Bool -- B1
+ F @k ((g :: Type -> k) Int) r = r -- B2
+
+ [W] F @Type alpha Char ~ Char
+ The `tcUnifyTysForInjectivity` will return substitution
+ [k :-> Type, r :-> Char, alpha :-> (g :: Type->Type) Int], with g unbound
+ If we used `substTy` on the LHS-tys for B2 we'd get
+ lhs_tys' = [Type, (g :: Type -> k) Int, Char]
+ That's ill-kinded because of the free `k`; and (worse) when `noEarlierMatch` matches
+ lhs_tys' against earlier equations, (B1) will fail to match. So (B2) will be
+ judged relevant, even though it isn't. Bad, bad. Use deep substitution.
+
+(CF9) Notice that, in (CF7) when generating the fundep equations for the solver to
+ deal with, we do /not/ apply the pre-unifying substitution `S` to the Wanted types.
+ The types wlhs,wrhs contain meta-variables that we must actually unify! Example
type family F a b where
F [a] (Maybe b) = (a, G b)
[W] F alpha beta ~ (Int, [gamma])
Pre-unification gives [alpha :-> [a], beta :-> Maybe b, a :-> Int]
- This substitution eliminates the quantified variable `a` but not `b`, so we
- want this:
- FDEqns { fd_qtvs = [b], fd_eqs [ [Int] ~ alpha
- , Maybe b ~ beta
- , (Int,G b) ~ (Int, [gamma]) ] }
-
- Notice also that by applying the substitution to the template but not to the
- Wanted, we uphold the `fd_eqs` invariant in `FDEqns` (see its data type decl)
+ We don't want to substitute `alpha` away! In fact we just generate these eqns:
+ FDEqns { fd_qtvs = [a,b], fd_eqs [ [a] ~ alpha
+ , Maybe b ~ beta
+ , (a, G b) ~ (Int, [gamma]) ] }
+ with `fd_qtvs` being the quantified variables of the equation, the LHSs
+ being the types from the equation and the RHSs being the types from the Wanted.
+ Notice that we thereby uphold the `fd_eqs` invariant in `FDEqns` (see its data
+ type decl).
Note [Cache-caused loops]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1517,8 +1606,8 @@ instantiateFunDepEqns (FDEqns { fd_qtvs = qtvs, fd_eqs = eqs })
rev_eqs = reverse eqs
-- (reverse eqs): See Note [Reverse order of fundep equations]
- -- The kinds of `qtvs` can have free variables, because of `trim_qtvs`
- -- Example: T27828b
+ -- The kinds of `qtvs` can have free variables;
+ -- in the FDEqns produced by GHC.Tc.Instance.FunDeps.improveFromInstEnv
empty_subst = mkEmptySubst $ mkInScopeSet $
tyCoVarsOfTypes (map tyVarKind qtvs)
=====================================
testsuite/tests/typecheck/should_compile/T27994.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+module T27994a (l2) where
+
+import Data.Kind (Constraint, Type)
+
+l1 :: [String]
+l1 = ["hello", "world!"]
+
+l2 :: [Int]
+l2 = gmap (HCons length HNil) l1
+
+-----
+
+type HList :: [Type] -> Type
+data HList p where
+ HNil :: HList '[]
+ HCons :: x -> HList xs -> HList (x:xs)
+
+type ($$) :: k -> [Type] -> Type
+type family s $$ p where
+ (s :: Type) $$ '[] = s
+ (s :: Type -> k) $$ (a:b) = s a $$ b
+
+type Doms :: [Type] -> [Type]
+type family Doms t where
+ Doms '[] = '[]
+ Doms ((a -> b) : t) = a : Doms t
+
+type Codoms :: [Type] -> [Type]
+type family Codoms t where
+ Codoms '[] = '[]
+ Codoms ((a -> b) : t) = b : Codoms t
+
+type GMap :: k -> [Type] -> Constraint
+class GMap (s :: k) t | t -> k where
+ gmap :: HList t -> s $$ Doms t -> s $$ Codoms t
+
+instance GMap [] '[a -> b] where
+ gmap :: HList '[a -> b] -> [a] -> [b]
+ gmap (HCons f HNil) = go
+ where
+ go :: [a] -> [b]
+ go [] = []
+ go (x:xs) = f x : go xs
=====================================
testsuite/tests/typecheck/should_compile/T27994a.hs
=====================================
@@ -0,0 +1,53 @@
+{-# LANGUAGE DataKinds, TypeFamilies, PolyKinds, GADTs, AllowAmbiguousTypes #-}
+module T27994 where
+
+import Data.Kind (Type)
+import Data.Proxy (Proxy)
+
+type F :: forall{k}. k -> Type -> Type
+type family F s x where
+ F (s :: Type -> k) (Proxy s) = Int
+
+f :: forall k (s :: k) x. F s x -> x
+f _ = undefined
+
+g :: Proxy Maybe -> ()
+g _ = ()
+
+data T a where
+ MkT :: T Int
+
+test :: T a -> ()
+test t = (\y -> case t of MkT -> g y) (f (3 :: Int))
+
+{- [W] F @k_azX (s_azY::k_azX) p_azN ~ Int
+
+unify [*->k, s::*->k, Proxy @(*->k) (s::*->k), Int]
+ ~ [k_azX, s_azY::k_azX, p_azN, Int]
+
+ --> [ k_azX :-> (* -> k)
+ , s :-> s_azY::k_azX
+ , p_azN :-> Proxy @(*->k) (s::*->k) ]
+
+ fixpt --> [ k_azX :-> Type -> k
+ , s :-> s_azY::(Type -> k)
+ , p_azN :-> Proxy @(Type->k) (s::k_azX) ]
+
+Generate a [W] for each pair
+ [W] k ~ k_azX
+ [W] s ~ s_azY
+ [W] Proxy s ~ p_azN
+ [W] Int ~ Int
+As an opt (claim) apply subst first
+ [W] k_azX ~ k_azX
+ [W] s_azY ~ s_azY
+ [W] Proxy s_azY ~ p_azN
+ [W] Int ~ Int
+
+-- [W] F @k_azX s_azY[tau] p_azN ~ Int
+-- Want: fresh k' s'
+-- [W] k' ~ k_azX
+-- [W] s':k' ~ s_azY:k_azX
+-- [W] Proxy s' ~ x
+-}
+
=====================================
testsuite/tests/typecheck/should_compile/T27994b.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+
+
+module T27994b where
+import Data.Proxy
+
+type family G a where G Int = Char
+type family F a b = r | r -> a
+type instance F a [c] = (a, G a) -- instance 1
+type instance F Int Bool = (Int, Bool) -- instance 2
+
+h :: Proxy a -> F a Bool
+h = h
+k :: (Int, b) -> b
+k = k
+
+test = k (h Proxy) `seq` () -- [W] F alpha Bool ~ (Int, gamma)
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -972,4 +972,6 @@ test('T27557', normal, compile, [''])
test('T27664', normal, compile, [''])
test('T27916', normal, compile, [''])
test('T26543_orig', normal, compile, [''])
-
+test('T27994', normal, compile, [''])
+test('T27994a', normal, compile, [''])
+test('T27994b', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0dbb47a8d2c3e0ccb6c0d47014cc28…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0dbb47a8d2c3e0ccb6c0d47014cc28…
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/andreask/9.10.4-batch1] bytecode: SLIDE fix followup backport fixes.
by Andreas Klebinger (＠AndreasK) 30 Oct '26
by Andreas Klebinger (＠AndreasK) 30 Oct '26
30 Oct '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
4d8fa799 by Andreas Klebinger at 2026-10-30T16:00:43+01:00
bytecode: SLIDE fix followup backport fixes.
- - - - -
2 changed files:
- rts/Interpreter.c
- testsuite/tests/bytecode/T27001.stdout
Changes:
=====================================
rts/Interpreter.c
=====================================
@@ -193,10 +193,7 @@ tag functions as tag inference currently doesn't rely on those being properly ta
In practice we're unlikely to have interpreted frames that low on the stack.
*/
#define IS_UNDERFLOW_FRAME(info) \
- ((info) == &stg_stack_underflow_frame_d_info || \
- (info) == &stg_stack_underflow_frame_v16_info || \
- (info) == &stg_stack_underflow_frame_v32_info || \
- (info) == &stg_stack_underflow_frame_v64_info)
+ ((info) == &stg_stack_underflow_frame_info)
#define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord)))
@@ -436,8 +433,6 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
if( IS_UNDERFLOW_FRAME(frame->info) )
{
- INTERP_TICK(it_underflow_lookups);
-
new_stack = (StgStack*)frame->next_chunk;
// How many words were on the stack
@@ -450,7 +445,7 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
}
// 2b. Access the element if there is no underflow frame, it must be right
// at the top of the stack.
- else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) {
+ else if((StgPtr) Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) {
// Still inside the stack chunk
return Sp_plusW(offset_words);
} else {
@@ -572,7 +567,6 @@ eval:
eval_obj:
obj = UNTAG_CLOSURE(tagged_obj);
- INTERP_TICK(it_total_evals);
IF_DEBUG(interpreter,
debugBelch(
@@ -1811,7 +1805,7 @@ run_BCO:
threadStackUnderflow(cap, cap->r.rCurrentTSO);
LOAD_STACK_POINTERS;
by -= sp_to_uf;
- } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) {
+ } else if ((StgPtr) Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) {
// we're within the first stack chunk, this chunk has
// no underflow frame
break;
@@ -1937,7 +1931,7 @@ run_BCO:
itbl->layout.payload.nptrs );
StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
- for (W_ i = 0; i < n_words; i++) {
+ for (i = 0; i < n_words; i++) {
con->payload[i] = (StgClosure*)SpW(i);
}
Sp_addW(n_words);
=====================================
testsuite/tests/bytecode/T27001.stdout
=====================================
@@ -1,4 +1 @@
-(0.15 secs,)
-it :: ()
100000.0
-(0.09 secs, 51,566,104 bytes)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d8fa799ac6886a883e89e455698c20…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d8fa799ac6886a883e89e455698c20…
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/andreask/9.10.4-batch1] 14 commits: AArch64: fix MOVK regUsageOfInstr to mark dst as both read and written
by Andreas Klebinger (＠AndreasK) 30 Oct '26
by Andreas Klebinger (＠AndreasK) 30 Oct '26
30 Oct '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
49de3c2a by Ian Duncan at 2026-10-30T15:31:48+01:00
AArch64: fix MOVK regUsageOfInstr to mark dst as both read and written
MOVK (move with keep) modifies only a 16-bit slice of the destination
register, so the destination is both read and written. The register
allocator must know this to avoid clobbering live values. Update
regUsageOfInstr to list the destination in both src and dst sets.
No regression test: triggering the misallocation requires specific
register pressure around a MOVK sequence, which is difficult to
reliably provoke from Haskell source.
(cherry picked from commit 2823b03966e495581f4695f07649c5885306b656)
- - - - -
9e7ec20a by Matthew Pickering at 2026-10-30T15:31:48+01:00
rts: forward clone-stack messages after TSO migration
MSG_CLONE_STACK assumed that the target TSO was still owned by the
capability that received the message. This is not always true: the TSO
can migrate before the inbox entry is handled.
When that happened, handleCloneStackMessage could clone a live stack from
the wrong capability and use the wrong capability for allocation and
performTryPutMVar, leading to stack sanity failures such as
checkStackFrame: weird activation record found on stack.
Fix this by passing the current capability into
handleCloneStackMessage, rechecking msg->tso->cap at handling time, and
forwarding the message if the TSO has migrated. Once ownership matches,
use the executing capability consistently for cloneStack, rts_apply, and
performTryPutMVar.
Fixes #27008
(cherry picked from commit 5b550754ca0153a705ec607407074fe5716c1f7e)
- - - - -
7b07ad94 by Zubin Duggal at 2026-10-30T15:31:48+01:00
driver: recognise .dyn_o as a valid object file to link if passed on the command line.
This allows plugins compiled with this suffix to run.
Fixes #24486
(cherry picked from commit bc4b44870d096d43e8cbc530da1fd613d9e4514f)
- - - - -
ce3c1eb8 by Zubin Duggal at 2026-10-30T15:31:48+01:00
hadrian: Don't include the package hash in the haddock directory
Since GHC 9.8 and hash_unit_ids, haddock urls have looked like`ghc-9.10.3/doc/html/libraries/base-4.20.2.0-39f9/**/*.html`
The inclusion of the hash makes it hard for downstream non-boot packages to properly link to these files, as the hash is not
part of a standard cabal substitution.
Since we only build one version of each package, we don't need the hash to disambiguate anything, we can just remove it.
Fixes #26635
(cherry picked from commit 07267f79d91169f474cacc8bcd38d76a6e97887d)
- - - - -
a89044fc by Cheng Shao at 2026-10-30T15:31:48+01:00
testsuite: mark T22159 as fragile
This patch marks T22159 as fragile on Windows for issue described in #27248.
Before we get to the bottom of those failures, this unblocks newer
Windows runners.
(cherry picked from commit 38b76b2f1d918f10d2f9d3e57bd0459dfe671d4f)
- - - - -
a6072c84 by Ian Duncan at 2026-10-30T15:31:49+01:00
AArch64: use ASR not LSR for MO_U_Shr at W8/W16
The unsigned right shift (MO_U_Shr) for sub-word widths (W8, W16)
with a variable shift amount was emitting ASR (arithmetic/signed shift
right) after zero-extending with UXTB/UXTH. This should be LSR
(logical/unsigned shift right). After zero-extension the upper bits
happen to be 0 so ASR produces the same result, but it is semantically
wrong and would break if the zero-extension were ever optimized away.
Includes assembly output test (grep for lsr) and runtime test
verifying unsigned right shift of Word8 and Word16 values.
(cherry picked from commit 50188615342098345fc2822ea223ab23791bbf49)
- - - - -
f0bdcc56 by Tom McLaughlin at 2026-10-30T15:31:49+01:00
Event/Windows.hsc: rethrow exceptions in overlapped IO
This prevents the WinIO manager from swallowing exceptions in overlapped IO. It
was added to make WinIO support possible in the `network` library. See
https://gitlab.haskell.org/ghc/ghc/-/issues/27283.
We also bump __IO_MANAGER_WINIO__ to 2 so libraries can gate on this using CPP.
(cherry picked from commit 037a80dc65d3975adf4a35d46876850e644bc80e)
- - - - -
70bd97dc by Ben Gamari at 2026-10-30T15:31:49+01:00
Cmm/Parser: Add surface syntax for Mul2 MachOps
These are otherwise very hard to test in isolation.
(cherry picked from commit ef5470a226dd8fe84df500a6a68672548624559e)
- - - - -
308c2863 by sheaf at 2026-10-30T15:31:49+01:00
Fix AArch64 clobbering bug for MUL2
On AArch64, the code generator could clobber one of the input operands
when computing the lower bits of a MUL2 operation. This rendered invalid
the subsequent computation of the high bits.
This commit fixes that by using a temporary register. The register
allocator can remove the redundant move in the common case when the
registers do not conflict.
Fixes #27046
(cherry picked from commit c9015f0953e72829e89ac768b6ad9ece34c7e187)
- - - - -
ecd3440d by mangoiv at 2026-10-30T15:31:49+01:00
libraries/process: bump submodule to v1.6.30.0
- bump the submodule to the appropriate tag
- suppress benign warning resulting from the change
(cherry picked from commit d9ea2d76545452a7df567b162340079cb024a40c)
- - - - -
60287c7d by Zubin Duggal at 2026-10-30T15:31:49+01:00
rts: fix validate build with gcc 16. `__attribute__((regparm(1)))` is ignored on x86_64 and now
gcc warns that it is ignored:
rts/sm/Evac.h:35:1: error:
error: ‘regparm’ attribute ignored [-Werror=attributes]
See https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=ccead81bbc39668376eb5cf47066a…
Fixes #27366
(cherry picked from commit 9438bec7117433bbc70449d4288f6ee32dbbbec4)
- - - - -
d11fe48d by Sylvain Henry at 2026-10-30T15:31:50+01:00
RTS: fix warnings with doing*Profiling (#24918)
(cherry picked from commit 5132754b80d468e0c24e39b63eea525dc1ee3a5b)
- - - - -
a1166bc0 by Luite Stegeman at 2026-10-30T15:31:50+01:00
bytecode: Carefully SLIDE off the end of a stack chunk
The SLIDE bytecode instruction was not checking for stack chunk
boundaries and could corrupt the stack underflow frame, leading
to crashes.
We add a check to use safe writes if we cross the chunk boundary
and also handle stack underflow if Sp is advanced past the underflow
frame.
fix #27001
(cherry picked from commit 72b20fc0ad4b6ad12c67f686af5cb42700656886)
(cherry picked from commit 52c2ba8f55b6a862df6ff9fc5db5c84853e07d19)
- - - - -
a06adfda by Andreas Klebinger at 2026-10-30T15:38:47+01:00
bytecode: SLIDE fix followup backport fixes.
- - - - -
48 changed files:
- + changelog.d/T26979
- + changelog.d/T27046
- + changelog.d/windows-rethrow-overlapped-exception
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/SysTools/Cpp.hs
- hadrian/bindist/Makefile
- hadrian/src/CommandLine.hs
- hadrian/src/Context.hs
- hadrian/src/Settings/Builders/Cabal.hs
- libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc
- libraries/process
- rts/CloneStack.c
- rts/CloneStack.h
- rts/Interpreter.c
- rts/Messages.c
- rts/RtsFlags.h
- rts/include/rts/storage/ClosureMacros.h
- rts/sm/Evac.h
- testsuite/driver/testlib.py
- + testsuite/tests/bytecode/T27001.hs
- + testsuite/tests/bytecode/T27001.stdout
- testsuite/tests/bytecode/all.T
- + testsuite/tests/codeGen/should_gen_asm/aarch64-shl-subword.asm
- + testsuite/tests/codeGen/should_gen_asm/aarch64-shl-subword.hs
- + testsuite/tests/codeGen/should_gen_asm/aarch64-ushr-subword.asm
- + testsuite/tests/codeGen/should_gen_asm/aarch64-ushr-subword.hs
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_run/T27046.hs
- + testsuite/tests/codeGen/should_run/T27046_cmm.cmm
- + testsuite/tests/codeGen/should_run/aarch64-subword-ops.hs
- + testsuite/tests/codeGen/should_run/aarch64-subword-ops.stdout
- + testsuite/tests/codeGen/should_run/aarch64-ushr-subword-run.hs
- + testsuite/tests/codeGen/should_run/aarch64-ushr-subword-run.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/ffi/should_run/all.T
- testsuite/tests/plugins/Makefile
- + testsuite/tests/plugins/T24486-plugin/Makefile
- + testsuite/tests/plugins/T24486-plugin/Setup.hs
- + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal
- + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs
- + testsuite/tests/plugins/T24486.hs
- + testsuite/tests/plugins/T24486_Helper.hs
- testsuite/tests/plugins/all.T
- testsuite/tests/rts/all.T
- + testsuite/tests/rts/cloneThreadStackMigrating.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb91b665f91575a71676e39472389f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb91b665f91575a71676e39472389f…
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/mangoiv/bp-16719] rts: move stack check to the start of the stg_unpack_cstring thunks
by Magnus (＠MangoIV) 30 Oct '26
by Magnus (＠MangoIV) 30 Oct '26
30 Oct '26
Magnus pushed to branch wip/mangoiv/bp-16719 at Glasgow Haskell Compiler / GHC
Commits:
3abf67a0 by Luite Stegeman at 2026-10-30T15:28:21+01:00
rts: move stack check to the start of the stg_unpack_cstring thunks
fixes a deadlock
see #27272
(cherry picked from commit ff6d941afc5f113f7e8d7487e809584973281c60)
- - - - -
5 changed files:
- + changelog.d/caf-deadlock-27272
- rts/StgStdThunks.cmm
- + testsuite/tests/rts/T27272.hs
- + testsuite/tests/rts/T27272_gen.py
- testsuite/tests/rts/all.T
Changes:
=====================================
changelog.d/caf-deadlock-27272
=====================================
@@ -0,0 +1,5 @@
+section: rts
+synopsis: Fix a deadlock where threads could block forever on a string literal
+ if entering the string literal triggered a stack overflow.
+mrs: !16849
+issues: #27272
=====================================
rts/StgStdThunks.cmm
=====================================
@@ -342,18 +342,11 @@ INFO_TABLE(stg_ap_7_upd,7,0,THUNK,"stg_ap_7_upd_info","stg_ap_7_upd_info")
*
*/
-stg_do_unpack_cstring(P_ node, P_ newCAF_ret) {
- STK_CHK_PP(WDS(SIZEOF_StgUpdateFrame), stg_do_unpack_cstring, node, newCAF_ret);
- W_ str;
- str = StgThunk_payload(node, 2);
- push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
- jump %ENTRY_CODE(HsIface_unpackCStringzh_info(W_[ghc_hs_iface]))(node, str);
- }
-}
-
INFO_TABLE(stg_unpack_cstring, 0, 0, THUNK_STATIC, "stg_unpack_cstring", "stg_unpack_cstring")
(P_ node)
{
+ // The stack check needs to come before newCAF: see #27272
+ STK_CHK_NP(node);
W_ newCAF_ret;
(newCAF_ret) = ccall newCAF(BaseReg "ptr", node "ptr");
@@ -362,22 +355,19 @@ INFO_TABLE(stg_unpack_cstring, 0, 0, THUNK_STATIC, "stg_unpack_cstring", "stg_un
// `node` should now be an indirection.
ENTER(node);
} else {
- jump stg_do_unpack_cstring(node, newCAF_ret);
- }
-}
-
-stg_do_unpack_cstring_utf8(P_ node, P_ newCAF_ret) {
- STK_CHK_PP(WDS(SIZEOF_StgUpdateFrame), stg_do_unpack_cstring_utf8, node, newCAF_ret);
- W_ str;
- str = StgThunk_payload(node, 2);
- push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
- jump %ENTRY_CODE(HsIface_unpackCStringUtf8zh_info(W_[ghc_hs_iface]))(node, str);
+ W_ str;
+ str = StgThunk_payload(node, 2);
+ push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
+ jump %ENTRY_CODE(HsIface_unpackCStringzh_info(W_[ghc_hs_iface]))(node, str);
+ }
}
}
INFO_TABLE(stg_unpack_cstring_utf8, 0, 0, THUNK_STATIC, "stg_unpack_cstring_utf8", "stg_unpack_cstring_utf8")
(P_ node)
{
+ // The stack check needs to come before newCAF: see #27272
+ STK_CHK_NP(node);
W_ newCAF_ret;
(newCAF_ret) = ccall newCAF(BaseReg "ptr", node "ptr");
@@ -386,6 +376,10 @@ INFO_TABLE(stg_unpack_cstring_utf8, 0, 0, THUNK_STATIC, "stg_unpack_cstring_utf8
// `node` should now be an indirection.
ENTER(node);
} else {
- jump stg_do_unpack_cstring_utf8(node, newCAF_ret);
+ W_ str;
+ str = StgThunk_payload(node, 2);
+ push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
+ jump %ENTRY_CODE(HsIface_unpackCStringUtf8zh_info(W_[ghc_hs_iface]))(node, str);
+ }
}
}
=====================================
testsuite/tests/rts/T27272.hs
=====================================
@@ -0,0 +1,146 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+-- Test for deadlocks related to string literal CAFs
+--
+-- Thread A enters a shared thunk X, and from X a string literal whose stack
+-- check fails while another thread B owns X. threadPaused then suspends A's
+-- work on X. If A still owns the literal, B blocks on it forever (#27272).
+module Main (main) where
+
+import T27272_Lits (asciiLits, utf8Lits)
+
+import Control.Concurrent
+import Control.Exception (evaluate)
+import Control.Monad
+import Data.Char (ord)
+import Data.IORef
+import GHC.Conc (BlockReason (..), ThreadStatus (..), threadStatus)
+import GHC.Exts
+import GHC.IO (IO (..))
+import System.Exit
+import System.Timeout
+#if defined(SELF_CHECK)
+import GHC.Exts.Heap
+ (ClosureType (..), GenClosure (..), StgInfoTable (..), getClosureData)
+#endif
+
+-- | Per literal: the gate (0 until A is in X, 1 once it is, 2 once B is in X
+-- too, 3 once B has claimed X), A's thread id, and for the self check whether
+-- A was suspended at the literal's stack check.
+data Gate = Gate (MutableByteArray# RealWorld) (MVar ThreadId) (IORef Bool)
+
+newGate :: IO Gate
+newGate = do
+ aVar <- newEmptyMVar
+ suspended <- newIORef False
+ IO $ \s -> case newByteArray# 8# s of
+ (# s1, g #) -> case writeIntArray# g 0# 0# s1 of
+ s2 -> (# s2, Gate g aVar suspended #)
+
+readGate :: Gate -> IO Int
+readGate (Gate g _ _) = IO $ \s -> case atomicReadIntArray# g 0# s of
+ (# s', n #) -> (# s', I# n #)
+
+data Box = Box String
+
+-- | Force the boxed string under @n@ one-word return frames. 'lazy' hides
+-- the strictness in @s@, otherwise the string is evaluated before the call.
+-- The frames are only one word with -O (see all.T).
+deepFrames :: Int -> Box -> Int
+deepFrames 0 (Box s) = case lazy s of
+ c : _ -> ord c
+ [] -> -1
+deepFrames n b = 1 + deepFrames (n - 1) b
+{-# NOINLINE deepFrames #-}
+
+-- | Build the shared thunk X for a literal and return it unevaluated.
+-- A's path through X only uses inline primops and does not allocate: any
+-- return to the scheduler would claim X for A. The spin is bounded because it
+-- holds up GC syncs.
+mkShared :: Gate -> String -> IO String
+mkShared gate@(Gate g _ _) lit = return x
+ where
+ x = runRW# (\s0 -> case fetchAddIntArray# g 0# 1# s0 of
+ (# s1, 0# #) -> case spin 100000000# s1 of (# _, () #) -> lit
+ (# s1, _ #) -> case claimX gate lit of
+ IO m -> case m s1 of (# _, r #) -> r)
+ spin :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
+ spin 0# s = (# s, () #)
+ spin n s = case atomicReadIntArray# g 0# s of
+ (# s', 3# #) -> (# s', () #)
+ (# s', _ #) -> spin (n -# 1#) s'
+{-# NOINLINE mkShared #-}
+
+-- | B's part of the gate. The yield calls threadPaused, which claims X for B,
+-- and B only enters the literal once A is blocked (suspended) or done.
+-- It is OPAQUE and returns the literal, so X saves nothing across the call:
+-- X's stack check stays small enough for the literal's check to fail.
+claimX :: Gate -> String -> IO String
+claimX (Gate g aVar suspended) lit = do
+ yield
+ IO $ \s -> (# atomicWriteIntArray# g 0# 3# s, () #)
+ a <- readMVar aVar
+ let waitA = do
+ st <- threadStatus a
+ case st of
+ ThreadRunning -> yield >> waitA
+ ThreadBlocked BlockedOnBlackHole ->
+ writeIORef suspended =<< suspendedAtCheck lit
+ _ -> return ()
+ waitA
+ return lit
+{-# OPAQUE claimX #-}
+
+-- Self check of the test, enabled with -DSELF_CHECK -package ghc-heap: fail
+-- if no literal entry was suspended at the literal's own stack check, i.e. if
+-- the test did not exercise the bug. The literal is then still unevaluated.
+suspendedAtCheck :: String -> IO Bool
+selfCheck :: [Bool] -> IO ()
+#if defined(SELF_CHECK)
+suspendedAtCheck lit = do
+ c <- getClosureData lit
+ return $ case c of
+ ThunkClosure { info = i } -> tipe i == THUNK_STATIC
+ _ -> False
+selfCheck results =
+ unless (or results) $ failWith "no literal entry was suspended"
+#else
+suspendedAtCheck _ = return False
+selfCheck _ = return ()
+#endif
+
+failWith :: String -> IO a
+failWith msg = putStrLn msg >> exitFailure
+
+main :: IO ()
+main = do
+ let expect c fmt = [ (c, c : shows i fmt) | i <- [0 :: Int ..] ]
+ lits = zip3 [0 ..] asciiLits (expect 'A' "-ABCDEFGHIJKLMNOPQRSTUVWXYZ") ++
+ zip3 [0 ..] utf8Lits (expect 'U' "-λμν-ÄÖÜ-€")
+ -- Literal d is entered under d frames. With the stack sizes from all.T this
+ -- crosses stack chunk ends, so the literal's stack check fails for some d.
+ results <- forM lits $ \(d, lit, (c, e)) -> do
+ gate@(Gate _ aVar suspended) <- newGate
+ x <- mkShared gate lit
+ doneA <- newEmptyMVar
+ doneB <- newEmptyMVar
+ -- New threads for each literal, so that A's stack only depends on d. A and
+ -- B have their own capabilities (-N3), so that B runs while A spins.
+ a <- forkOn 1 $ do
+ v <- evaluate (deepFrames d (Box x))
+ putMVar doneA (v == d + ord c && x == e)
+ putMVar aVar a
+ _ <- forkOn 2 $ do
+ -- B must only enter X once A is in it
+ let waitA = do
+ n <- readGate gate
+ when (n == 0) (yield >> waitA)
+ waitA
+ _ <- evaluate x
+ putMVar doneB ()
+ -- With the bug, A blocks on X and B on the literal: the timeout catches it
+ r <- timeout 10000000 (takeMVar doneA <* takeMVar doneB)
+ case r of
+ Just True -> readIORef suspended
+ Just False -> failWith ("wrong result at depth " ++ show d)
+ Nothing -> failWith ("deadlock at depth " ++ show d)
+ selfCheck results
=====================================
testsuite/tests/rts/T27272_gen.py
=====================================
@@ -0,0 +1,22 @@
+#!/usr/bin/env python3
+# usage: T27272_gen.py N > T27272_Lits.hs
+import sys
+
+n = int(sys.argv[1])
+out = sys.stdout
+out.reconfigure(encoding="utf-8")
+
+kinds = [
+ ("a", "asciiLits", "A{}-ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
+ ("u", "utf8Lits", "U{}-λμν-ÄÖÜ-€"),
+]
+
+out.write("module T27272_Lits (asciiLits, utf8Lits) where\n")
+for prefix, list_name, fmt in kinds:
+ out.write("\n")
+ for i in range(n):
+ out.write(f'{prefix}{i} :: String\n{prefix}{i} = "{fmt.format(i)}"\n')
+ out.write(f"\n{list_name} :: [String]\n{list_name} =\n [ {prefix}0\n")
+ for i in range(1, n):
+ out.write(f" , {prefix}{i}\n")
+ out.write(" ]\n")
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -647,3 +647,12 @@ test('T27477',
, only_ways(['threaded1', 'threaded2'])
],
compile_and_run, ['-O2'])
+
+test('T27272',
+ [ req_target_smp
+ , omit_ghci
+ , omit_ways(['hpc'])
+ , pre_cmd('$PYTHON T27272_gen.py 200 > T27272_Lits.hs')
+ , extra_run_opts('+RTS -N3 -ki512 -kc1k -kb128 -RTS')
+ ],
+ multimod_compile_and_run, ['T27272', '-O -threaded -fno-prof-auto'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3abf67a062b6c175f7deb7a765b967f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3abf67a062b6c175f7deb7a765b967f…
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/mangoiv/bp-16719] 3 commits: Fix a few tag inference bugs.
by Magnus (＠MangoIV) 30 Oct '26
by Magnus (＠MangoIV) 30 Oct '26
30 Oct '26
Magnus pushed to branch wip/mangoiv/bp-16719 at Glasgow Haskell Compiler / GHC
Commits:
10fb39fb by Andreas Klebinger at 2026-10-30T15:12:46+01:00
Fix a few tag inference bugs.
* Treat bottoming functions and nullary join points as functions.
* When generating bytecode don't rely on imported tag sigs.
Fixes #27831, #27841 and #27842.
(cherry picked from commit 6bbca56943ef68ba32520bcf8712a8faf9021ed6)
- - - - -
dc8c72c7 by Phil Hazelden at 2026-10-30T15:12:46+01:00
Fix build with werror on glibc 2.43.
We've been defining `_XOPEN_SOURCE` and `_POSIX_C_SOURCE` to the same
values as defined in glibc prior to 2.43. But in 2.43, glibc changes
them to new values, which means we get a warning when redefining them.
By `#undef`ing them first, we no longer get a warning.
Closes #27076.
(cherry picked from commit 7b9a75f09a0a8d11d843f43e8e938b6608fb5166)
- - - - -
3a0472df by Zubin Duggal at 2026-10-30T15:12:46+01:00
DmdAnal: Make AbsDmd neutral in maxDmd
fixes #27845
(cherry picked from commit f76464cff4a9b55bb01e612bffe0dd866a9982e3)
- - - - -
38 changed files:
- + changelog.d/27845
- + changelog.d/T27831-bottoming-strict-field
- + changelog.d/T27842-bytecode-imported-tags
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Stg/InferTags/TagSig.hs
- compiler/GHC/Stg/InferTags/Types.hs
- compiler/GHC/Types/Demand.hs
- rts/include/rts/PosixSource.h
- + testsuite/tests/bytecode/T27842.hs
- + testsuite/tests/bytecode/T27842.stdout
- + testsuite/tests/bytecode/T27842A.hs
- + testsuite/tests/bytecode/T27842N.hs
- testsuite/tests/bytecode/all.T
- + testsuite/tests/dmdanal/should_run/T27845.hs
- + testsuite/tests/dmdanal/should_run/T27845.stdout
- + testsuite/tests/dmdanal/should_run/T27845_Lib.hs
- + testsuite/tests/dmdanal/should_run/T27845b.hs
- + testsuite/tests/dmdanal/should_run/T27845b.stdout
- + testsuite/tests/dmdanal/should_run/T27845b_Lib.hs
- testsuite/tests/dmdanal/should_run/all.T
- testsuite/tests/simplCore/should_compile/T4201.stdout
- testsuite/tests/simplCore/should_run/all.T
- testsuite/tests/simplStg/should_compile/all.T
- + testsuite/tests/simplStg/should_compile/inferTags005.hs
- + testsuite/tests/simplStg/should_compile/inferTags005.stderr
- + testsuite/tests/simplStg/should_compile/inferTags006.hs
- + testsuite/tests/simplStg/should_compile/inferTags006.stderr
- + testsuite/tests/simplStg/should_run/InferTags007_A.hs
- − testsuite/tests/simplStg/should_run/T22042.stderr
- testsuite/tests/simplStg/should_run/T22042.stdout
- + testsuite/tests/simplStg/should_run/T27831.hs
- + testsuite/tests/simplStg/should_run/T27831.stdout
- + testsuite/tests/simplStg/should_run/T27857.hs
- + testsuite/tests/simplStg/should_run/T27857.stdout
- testsuite/tests/simplStg/should_run/all.T
- + testsuite/tests/simplStg/should_run/inferTags007.hs
- + testsuite/tests/simplStg/should_run/inferTags007.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a4afcb2a8cc13fc124764434483de…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a4afcb2a8cc13fc124764434483de…
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/andreask/9.10.4-batch1] RTS: fix warnings with doing*Profiling (#24918)
by Andreas Klebinger (＠AndreasK) 30 Oct '26
by Andreas Klebinger (＠AndreasK) 30 Oct '26
30 Oct '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
cb91b665 by Sylvain Henry at 2026-10-30T15:08:23+01:00
RTS: fix warnings with doing*Profiling (#24918)
(cherry picked from commit 5132754b80d468e0c24e39b63eea525dc1ee3a5b)
- - - - -
2 changed files:
- rts/RtsFlags.h
- rts/include/rts/storage/ClosureMacros.h
Changes:
=====================================
rts/RtsFlags.h
=====================================
@@ -24,7 +24,12 @@ void initRtsFlagsDefaults (void);
void setupRtsFlags (int *argc, char *argv[], RtsConfig rtsConfig);
void freeRtsArgs (void);
bool is_io_mng_native_p (void);
-#if defined(PROFILING)
+
+/* These prototypes may also be defined by ClosureMacros.h. We don't want to
+ * define them twice (#24918).
+ */
+#if defined(PROFILING) && !defined(RTS_FLAGS_DOING_PROFILING)
+#define RTS_FLAGS_DOING_PROFILING 1
bool doingLDVProfiling (void);
bool doingRetainerProfiling(void);
bool doingErasProfiling(void);
=====================================
rts/include/rts/storage/ClosureMacros.h
=====================================
@@ -152,10 +152,16 @@ EXTERN_INLINE StgHalfWord GET_TAG(const StgClosure *con)
be duplicated here, otherwise there will be some
-Wimplicit-function-declaration compilation errors. Especially when
GHC compiles out-of-tree cbits that rely on SET_HDR in RTS API.
+
+ However when RtsFlags.h is imported, we don't want to redefine them to avoid
+ spurious warnings (#24918).
*/
+#if !defined(RTS_FLAGS_DOING_PROFILING)
+#define RTS_FLAGS_DOING_PROFILING 1
bool doingLDVProfiling(void);
bool doingRetainerProfiling(void);
bool doingErasProfiling(void);
+#endif
/*
The following macro works for both retainer profiling and LDV profiling. For
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb91b665f91575a71676e39472389fa…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb91b665f91575a71676e39472389fa…
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/romes/async-rpc] fixup! interp: cancel requests if async exceptions while waiting for reply.
by Andrea Vezzosi (＠trac-Saizan) 30 Oct '26
by Andrea Vezzosi (＠trac-Saizan) 30 Oct '26
30 Oct '26
Andrea Vezzosi pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC
Commits:
b784216f by Andrea Vezzosi at 2026-10-30T13:28:14+01:00
fixup! interp: cancel requests if async exceptions while waiting for reply.
fixes gap between readPipe and fetched from queue.
- - - - -
1 changed file:
- libraries/ghci/GHCi/Message/Async.hs
Changes:
=====================================
libraries/ghci/GHCi/Message/Async.hs
=====================================
@@ -314,9 +314,9 @@ handleAsyncReq pipe getit mii k = mask $ \restore -> do
Nothing -> tryReadTQueue $ requestsQueue am
Just ii -> tryReadTQueue =<< getMailbox am ii
case taken of
- Just req@(uq,_) -> fetchedRequest am uq >> pure (Just req)
- Nothing | isClosed -> pure Nothing -- empty and closed
- | otherwise -> retry -- wait for msg
+ Just req@(uq,_) -> pure (Just req)
+ Nothing | isClosed -> pure Nothing -- empty and closed
+ | otherwise -> retry -- wait for msg
case mbreq of
Nothing -> throwIO PipeReadClosedException -- can't expect reqs
@@ -394,8 +394,8 @@ getMailbox am (InboxId ii) = do
-- | Tracks handling status of a received 'Request'. The values are states of a
-- tiny state machine used to coordinate cancelations.
--
--- 'handleAsyncReq' will pop a request from the appropriate queue, setting the
--- status to `Fetched`. Then one of two things can happen first:
+-- 'drainPipe' will push a request to the appropriate queue, and set the
+-- status to `Received`. Then one of two things can happen first:
-- - we receive a 'Cancel', then status is set to `Canceling` so the cancel
-- action will run when set.
-- - handler sets a cancel action, then reception of a `Cancel` runs that
@@ -404,14 +404,14 @@ getMailbox am (InboxId ii) = do
-- If RequestStatus is `Canceling` or absent, then a `Reply` won't be sent.
--
-- The two possible transition paths:
--- requestsQueue -> Fetched -> Active cancel -> gone
--- requestsQueue -> Fetched -> Canceling -> gone
+-- readPipe -> Received -> Active cancel -> gone
+-- readPipe -> Received -> Canceling -> gone
data RequestStatus
- = Fetched -- ^ 'Fetched' from a request queue, to pass to handler.
- | Active (IO ()) -- ^ Handler set a cancel action, and has not sent a reply
+ = Received -- ^ 'Received' from the 'Pipe'.
+ | Active (IO ()) -- ^ Handler has set a cancel action, and has not sent a reply
-- yet. The cancel action must not block.
- | Canceling -- ^ `Cancel` received while status is still `Fetched`.
+ | Canceling -- ^ `Cancel` received while status is still `Received`.
data AsyncManager = AsyncManager
{ pendingReply :: !(TVar (IntMap (TMVar (Either SomeException LB.ByteString))))
@@ -530,7 +530,7 @@ drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPend
putTMVar wv (bimap (toException . RemoteProcessException) id bs)
-- Receive a request and queue it
Request uq mbi bs -> do
- atomically $ case mbi of
+ atomically $ receivedRequest am uq >> case mbi of
Nothing ->
-- "Global" request
writeTQueue (requestsQueue am) (uq,bs)
@@ -548,10 +548,10 @@ cancelRequest :: AsyncManager -> CorrelationId -> IO ()
cancelRequest am uq = join . atomically $ do
cs <- readTVar (cancelStatus am)
case IntMap.lookup uq cs of
- Nothing -> pure (pure ())
- Just Fetched -> writeTVar (cancelStatus am) (IntMap.insert uq Canceling cs) >> pure (pure ())
+ Nothing -> pure (pure ())
+ Just Received -> writeTVar (cancelStatus am) (IntMap.insert uq Canceling cs) >> pure (pure ())
Just (Active cancel) -> writeTVar (cancelStatus am) (IntMap.delete uq cs) >> pure cancel
- Just Canceling -> pure (pure ())
+ Just Canceling -> pure (pure ())
-- | Returns @True@ when the handler should write its 'Reply'.
doneHandling :: AsyncManager -> CorrelationId -> STM Bool
@@ -569,19 +569,19 @@ setActive :: AsyncManager -> CorrelationId -> IO () -> IO ()
setActive am uq cancel = join . atomically $ do
cs <- readTVar (cancelStatus am)
case IntMap.lookup uq cs of
- Nothing -> pure (pure ()) -- reply already received.
- Just Fetched -> writeTVar (cancelStatus am) (IntMap.insert uq (Active cancel) cs) >> pure (pure ())
+ Nothing -> pure (pure ()) -- reply already sent.
+ Just Received -> writeTVar (cancelStatus am) (IntMap.insert uq (Active cancel) cs) >> pure (pure ())
Just (Active _) -> writeTVar (cancelStatus am) (IntMap.insert uq (Active cancel) cs) >> pure (pure ())
- Just Canceling -> pure cancel
+ Just Canceling -> pure cancel
-fetchedRequest :: AsyncManager -> CorrelationId -> STM ()
-fetchedRequest am uq = do
+receivedRequest :: AsyncManager -> CorrelationId -> STM ()
+receivedRequest am uq = do
cs <- readTVar (cancelStatus am)
case IntMap.lookup uq cs of
- Nothing -> writeTVar (cancelStatus am) (IntMap.insert uq Fetched cs)
- Just Fetched -> error "impossible"
+ Nothing -> writeTVar (cancelStatus am) (IntMap.insert uq Received cs)
+ Just Received -> error "impossible"
Just (Active _) -> error "impossible"
- Just Canceling -> error "impossible"
+ Just Canceling -> error "impossible"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b784216f6ebe314dc63b3ad82c00896…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b784216f6ebe314dc63b3ad82c00896…
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/romes/async-rpc] interp: single-threaded sendTHComputation
by Andrea Vezzosi (＠trac-Saizan) 30 Oct '26
by Andrea Vezzosi (＠trac-Saizan) 30 Oct '26
30 Oct '26
Andrea Vezzosi pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC
Commits:
3e76e7c9 by Andrea Vezzosi at 2026-10-30T13:04:38+01:00
interp: single-threaded sendTHComputation
- - - - -
3 changed files:
- compiler/GHC/Runtime/Interpreter/Process.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Message/Async.hs
Changes:
=====================================
compiler/GHC/Runtime/Interpreter/Process.hs
=====================================
@@ -4,6 +4,7 @@ module GHC.Runtime.Interpreter.Process
Message(..)
, sendMessage
, sendTHComputation
+ , sendMessageWithResponse
)
where
@@ -16,9 +17,7 @@ import GHC.Utils.Panic
import GHC.Utils.Exception as Ex
import Data.Binary
-import Control.Concurrent
import Data.IORef
-import Control.Concurrent.STM
-- -----------------------------------------------------------------------------
-- Top-level Message API
@@ -34,29 +33,27 @@ sendMessage i msg =
where
proc = instProcess i
+sendMessageWithResponse :: Binary a => ExtInterpInstance c -> Message a -> (IO a -> IO b) -> IO b
+sendMessageWithResponse i msg k =
+ remoteCallWithResponse (interpPipe proc) msg k
+ where
+ proc = instProcess i
+
-- | Send a message with a TH computation to the ext. interpreter (like
-- 'RunTH', or 'RunModFinalizers') and handle 'THMessage' requests from the
--- ext. interpreter to us in the meantime.
---
--- This function blocks until the TH computation returns a value, but spawns in
--- the background a thread to handle the 'THMessage's until the TH computation
--- is fully done.
+-- ext. interpreter to us until done, then wait for the response.
sendTHComputation
:: Binary a
=> ExtInterpInstance d
-> (InboxId -> Message a)
-> (forall b. Binary b => THMessage b -> IO (Bool, b))
-- ^ Handle one message. Return True to end the loop.
- -- This handler must never uninterrutibly mask an expression which may get
- -- stuck. If it does, then 'sendTHComputation' will also get uninterruptibly stuck.
-> IO a
-sendTHComputation i msg reqHandler = mask $ \restore -> do
- -- inline "withAsync/wait"
- var <- newEmptyTMVarIO
- mbox <- newMailbox (pipeAsyncMngr (interpPipe proc))
- ht <- forkFinally (restore (handlerLoop mbox)) (atomically . putTMVar var)
- restore (sendMessage i (msg mbox) <* atomically (readTMVar var))
- `onException` uninterruptibleMask_ (throwTo ht CancelTHHandler)
+sendTHComputation i msg reqHandler =
+ withNewMailbox (pipeAsyncMngr (interpPipe proc)) $ \ mbox ->
+ sendMessageWithResponse i (msg mbox) $ \ waitRes -> do
+ handlerLoop mbox
+ waitRes
where
proc = instProcess i
handleOne mbox doneRef = do
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -25,13 +25,12 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe(..), mkPipeFromHandles, mkPipeFromContinuations, closePipe
- , remoteCall, remoteTHCall
+ , remoteCall, remoteCallWithResponse, remoteTHCall
, handleRemoteCall, handleRemoteTHCall, writeReply
, RemoteProcessException(..), PipeClosedException(..)
, InboxId(..)
- , newMailbox
- , closeMailbox
+ , withNewMailbox
, BreakModule
, BreakUnitId
@@ -660,8 +659,12 @@ serializeBCOs rbcos = parMap doChunk (chunkList 100 rbcos)
-- | Send a 'Message' request to and wait for a reply from the interpreter
-- (blocks on the calling side, doesn't necessarily block the interpreter)
remoteCall :: Binary a => Pipe -> Message a -> IO a
-remoteCall pipe msg = either throwIO (pure . runGet get)
- =<< remoteAsyncReq pipe (putMessage msg) Nothing
+remoteCall pipe msg = remoteCallWithResponse pipe msg id
+
+remoteCallWithResponse :: Binary a => Pipe -> Message a -> (IO a -> IO b) -> IO b
+remoteCallWithResponse pipe msg k =
+ remoteAsyncReqWithResponse pipe (putMessage msg) Nothing $ \ m ->
+ k $ either throwIO (pure . runGet get) =<< m
-- | Handle a single 'Message' request on the interpreter and reply to the host
handleRemoteCall :: Pipe
=====================================
libraries/ghci/GHCi/Message/Async.hs
=====================================
@@ -11,12 +11,14 @@ module GHCi.Message.Async
-- * Interface for async bidirectional RPC
, remoteAsyncReq, handleAsyncReq
+ , remoteAsyncReqWithResponse
, RemoteProcessException(..), DecodeAsyncReqException(..)
-- ** Mailboxes
, InboxId(..)
, newMailbox
, closeMailbox
+ , withNewMailbox
-- ** Async matching internals
, AsyncManager(..), CorrelationId
@@ -247,24 +249,44 @@ newPendingReply pipe k = do
--
-- See Note [Exceptions during serialization] about exceptions the 'Put' argument might raise.
remoteAsyncReq :: Pipe -> Put -> (Maybe InboxId) -> IO (Either SomeException LB.ByteString)
-remoteAsyncReq pipe msg ii = newPendingReply pipe $ \ uq wv ->
- -- We might send a Cancel even if the request never got sent, but it will just
- -- get ignored in that case.
- handle (\e -> sendCancelMaybe uq e >> throwIO e) $ do
+remoteAsyncReq pipe msg ii = remoteAsyncReqWithResponse pipe msg ii id
- -- Write request
- writePipe pipe (Request uq ii (runPut msg))
- -- Block waiting for reply
- atomically (takeTMVar wv)
+remoteAsyncReqWithResponse :: Pipe
+ -> Put
+ -> Maybe InboxId
+ -> (IO (Either SomeException LB.ByteString) -> IO b)
+ -> IO b
+remoteAsyncReqWithResponse pipe msg ii k = newPendingReply pipe $ \ uq wv -> do
+ -- We use an MVar to only Cancel the request if the response did not get read by `k`.
+ readRes <- newEmptyMVar
+ -- We might send a Cancel even if the request never got sent, but it will just
+ -- get ignored in that case.
+ --
+ -- Waiting for confirmation that the request got sent before "arming" the
+ -- cancelation requires more collaboration from `fillPipe`, because
+ -- writePipe's takeMVar is interruptible. Could be done if we generalize the
+ -- type of `writeQueue` to `TQueue (IddMsg, (Either SomeException ()) -> STM ())`.
+ cancelOnErrorMaybe uq readRes $ do
+ -- Write request
+ writePipe pipe (Request uq ii (runPut msg))
+
+ k $ do
+ -- Block waiting for reply
+ atomically (takeTMVar wv) <* putMVar readRes ()
where
- sendCancelMaybe uq e
- | Just PipeWriteClosedException <- fromException e = pure ()
- | otherwise = sendCancel uq
- sendCancel uq = void . atomically $ do
- -- we don't wait for Cancel to be written on the pipe,
- -- and won't get a reply: nowhere to report it anyway.
- writePipeAsync pipe (Cancel uq)
+ cancelOnErrorMaybe :: CorrelationId -> MVar () -> IO a -> IO a
+ cancelOnErrorMaybe uq readRes = handle (\ e -> sendCancelMaybe e >> throwIO e) where
+ sendCancelMaybe = \case
+ e | Just PipeWriteClosedException <- fromException e ->
+ pure ()
+ | otherwise ->
+ tryTakeMVar readRes >>= \case
+ Just () -> pure ()
+ Nothing -> void . atomically $ do
+ -- we don't wait for Cancel to be written on the pipe,
+ -- and won't get a reply: nowhere to report it anyway.
+ writePipeAsync pipe (Cancel uq)
-- | Receive a single asynchronous request and send a matching reply
-- asynchronously (the handler may fork a computation that eventually replies
@@ -352,6 +374,9 @@ closeMailbox :: AsyncManager -> InboxId -> IO ()
closeMailbox AsyncManager{..} (InboxId ii) =
atomically (modifyTVar mailboxQueues (IntMap.delete ii))
+withNewMailbox :: AsyncManager -> (InboxId -> IO a) -> IO a
+withNewMailbox am = bracket (newMailbox am) (closeMailbox am)
+
-- | Get or create a new mailbox for this 'InboxId'
getMailbox :: AsyncManager -> InboxId -> STM (TQueue (CorrelationId, LB.ByteString))
getMailbox am (InboxId ii) = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e76e7c9165507924ab651c545733d3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e76e7c9165507924ab651c545733d3…
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/andreask/9.10.4-batch1] 4 commits: Cmm/Parser: Add surface syntax for Mul2 MachOps
by Andreas Klebinger (＠AndreasK) 30 Oct '26
by Andreas Klebinger (＠AndreasK) 30 Oct '26
30 Oct '26
Andreas Klebinger pushed to branch wip/andreask/9.10.4-batch1 at Glasgow Haskell Compiler / GHC
Commits:
91389fdf by Ben Gamari at 2026-10-30T11:35:27+01:00
Cmm/Parser: Add surface syntax for Mul2 MachOps
These are otherwise very hard to test in isolation.
(cherry picked from commit ef5470a226dd8fe84df500a6a68672548624559e)
- - - - -
8981fe7a by sheaf at 2026-10-30T11:35:27+01:00
Fix AArch64 clobbering bug for MUL2
On AArch64, the code generator could clobber one of the input operands
when computing the lower bits of a MUL2 operation. This rendered invalid
the subsequent computation of the high bits.
This commit fixes that by using a temporary register. The register
allocator can remove the redundant move in the common case when the
registers do not conflict.
Fixes #27046
(cherry picked from commit c9015f0953e72829e89ac768b6ad9ece34c7e187)
- - - - -
ed19e629 by mangoiv at 2026-10-30T11:35:27+01:00
libraries/process: bump submodule to v1.6.30.0
- bump the submodule to the appropriate tag
- suppress benign warning resulting from the change
(cherry picked from commit d9ea2d76545452a7df567b162340079cb024a40c)
- - - - -
b20f08ad by Zubin Duggal at 2026-10-30T11:35:27+01:00
rts: fix validate build with gcc 16. `__attribute__((regparm(1)))` is ignored on x86_64 and now
gcc warns that it is ignored:
rts/sm/Evac.h:35:1: error:
error: ‘regparm’ attribute ignored [-Werror=attributes]
See https://gcc.gnu.org/git/?p=gcc.git;a=commit;h=ccead81bbc39668376eb5cf47066a…
Fixes #27366
(cherry picked from commit 9438bec7117433bbc70449d4288f6ee32dbbbec4)
- - - - -
9 changed files:
- + changelog.d/T27046
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- libraries/process
- rts/sm/Evac.h
- testsuite/driver/testlib.py
- + testsuite/tests/codeGen/should_run/T27046.hs
- + testsuite/tests/codeGen/should_run/T27046_cmm.cmm
- testsuite/tests/codeGen/should_run/all.T
Changes:
=====================================
changelog.d/T27046
=====================================
@@ -0,0 +1,9 @@
+section: compiler
+issues: #27046
+mrs: !16031
+synopsis:
+ Avoid AArch64 register clobbering bug in MUL2
+description:
+ Fixes an issue in which, on AArch64, code generation for the MUL2 operation
+ could clobber one of the input operands when computing the lower bits, which
+ rendered invalid the subsequent computation of the high bits.
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1164,6 +1164,8 @@ callishMachOps platform = listToUFM $
, allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand)
, allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or)
, allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor)
+ , allWidths "mul2_" (\w -> MO_S_Mul2 w)
+ , allWidths "mul2u_" (\w -> MO_U_Mul2 w)
]
where
allWidths
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -1694,11 +1694,17 @@ genCCall target dest_regs arg_regs bid = do
let lo = getRegisterReg platform (CmmLocal dst_lo)
hi = getRegisterReg platform (CmmLocal dst_hi)
nd = getRegisterReg platform (CmmLocal dst_needed)
+ -- Generate a fresh virtual register for the low word computation.
+ -- This avoids clobbering reg_a or reg_b in the first MUL instruction,
+ -- which could for example happen if 'lo' and 'reg_a' are the same
+ -- virtual register.
+ tmp_lo <- getNewRegNat II64
return (
code_x `appOL`
code_y `snocOL`
- MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`
+ MUL (OpReg W64 tmp_lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`
SMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`
+ MOV (OpReg W64 lo) (OpReg W64 tmp_lo) `snocOL`
-- Are all high bits equal to the sign bit of the low word?
-- nd = (hi == ASR(lo,width-1)) ? 1 : 0
CMP (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL`
=====================================
libraries/process
=====================================
@@ -1 +1 @@
-Subproject commit f7d51387ba7f7f6079f3a9d5ce011ad9359b7dbb
+Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4
=====================================
rts/sm/Evac.h
=====================================
@@ -6,7 +6,7 @@
*
* Documentation on the architecture of the Garbage Collector can be
* found in the online commentary:
- *
+ *
* https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/gc
*
* ---------------------------------------------------------------------------*/
@@ -25,7 +25,9 @@
// registers EAX, EDX, and ECX instead of on the stack. Functions that
// take a variable number of arguments will continue to be passed all of
// their arguments on the stack.
-#if __GNUC__ >= 2 && (defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH))
+// On x86-64 the attribute has no effect (the first argument is already
+// passed in a register) and GCC 16 warns that it is ignored.
+#if defined(i386_HOST_ARCH)
#define REGPARM1 __attribute__((regparm(1)))
#else
#define REGPARM1
=====================================
testsuite/driver/testlib.py
=====================================
@@ -2723,7 +2723,19 @@ def normalise_errmsg(s: str) -> str:
# clang may warn about unused argument when used as assembler
s = re.sub('.*warning: argument unused during compilation:.*\n', '', s)
# Emscripten displays cache info and old emcc doesn't support EMCC_LOGGING=0
- s = re.sub('cache:INFO: .*\n', '', s)
+ s = drop_lines_containing(s, 'cache:INFO:')
+ # Old emcc warns when we export HEAP8 but new one requires it (see #26290)
+ s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','')
+
+ if opsys('darwin'):
+ # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols,
+ # however, these are completely benign stubs.
+ # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116
+ s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l))
+ # we also want to remove linker warnings having to do with undefined dynamic_lookup in combination with
+ # making a single weak symbol undefined as this is dependent on other linker flags
+ # See also https://github.com/haskell/process/pull/377
+ s = drop_lines_containing(s, 'ld: warning: -U option is redundant when using -undefined dynamic_lookup')
return s
=====================================
testsuite/tests/codeGen/should_run/T27046.hs
=====================================
@@ -0,0 +1,29 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes #-}
+
+module Main where
+
+import Control.Monad
+ ( unless )
+import Data.Bits
+ ( shiftL )
+import GHC.Exts
+ ( Int64# )
+import GHC.Int
+ ( Int64(..) )
+
+foreign import prim "test_mul2_clobber"
+ test_mul2_clobber :: Int64# -> Int64# -> Int64#
+
+main :: IO ()
+main = do
+ let
+ I64# x = 1 `shiftL` 32
+ hi = I64# $ test_mul2_clobber x x
+
+ unless ( hi == 1 ) $
+ error $ unlines
+ [ "Incorrect result for Mul2 operation."
+ , "Expected high word: 1"
+ , " Actual high word: " ++ show hi
+ ]
=====================================
testsuite/tests/codeGen/should_run/T27046_cmm.cmm
=====================================
@@ -0,0 +1,13 @@
+#include "Cmm.h"
+
+// Test for #27046
+test_mul2_clobber (bits64 x, bits64 y)
+{
+ bits64 hi, nd;
+
+ // Deliberately alias the destination 'lo' with the source 'x'
+ // This forces the NCG to use the same virtual register for both.
+ (nd, hi, x) = prim %mul2_64(x, y);
+
+ return (hi);
+}
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -253,6 +253,13 @@ test('T24893', normal, compile_and_run, ['-O'])
test('T26061', normal, compile_and_run, [''])
test('T26537', normal, compile_and_run, ['-O2 -fregs-graph'])
test('T24016', normal, compile_and_run, ['-O1 -fPIC'])
+test('T27046',
+ [ req_cmm
+ , when(arch('i386'), skip) # i386 does not support MO_S_Mul2 W64
+ , when(arch('wasm32'), skip)
+ , js_skip
+ , when(unregisterised(), skip) # pprCallishMachOp_for_C: MO_S_Mul2 W64 not supported
+ ], compile_and_run, ['T27046_cmm.cmm'])
# Check that GHC-generated finalizers run on Darwin. The Apple linker doesn't
# support --wrap, so we can't intercept hs_spt_remove directly. Instead we
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3764e95ca5ba389cfb332756000eeb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3764e95ca5ba389cfb332756000eeb…
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