Ben Gamari pushed new branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/backports-9.14
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Ben Gamari deleted branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC
--
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][ghc-9.14] 18 commits: Take more care in zonkEqTypes on AppTy/AppTy
by Ben Gamari (＠bgamari) 04 Sep '25
by Ben Gamari (＠bgamari) 04 Sep '25
04 Sep '25
Ben Gamari pushed to branch ghc-9.14 at Glasgow Haskell Compiler / GHC
Commits:
d5dab939 by Simon Peyton Jones at 2025-09-02T15:03:52-04:00
Take more care in zonkEqTypes on AppTy/AppTy
This patch fixes #26256.
See Note [zonkEqTypes and the PKTI] in GHC.Tc.Solver.Equality
(cherry picked from commit 18036d5205ac648bb245217519fed2fd931a9982)
- - - - -
5c994363 by Andreas Klebinger at 2025-09-02T15:04:00-04:00
Make unexpected LLVM versions a warning rather than an error.
Typically a newer LLVM version *will* work so erroring out if
a user uses a newer LLVM version is too aggressive.
Fixes #25915
(cherry picked from commit 50842f83f467ff54dd22470559a7af79d2025c03)
- - - - -
dbe870cd by Reed Mullanix at 2025-09-02T15:04:56-04:00
ghc-internal: Fix naturalAndNot for NB/NS case
When the first argument to `naturalAndNot` is larger than a `Word` and the second is `Word`-sized, `naturalAndNot` will truncate the
result:
```
>>> naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)
0
```
In contrast, `naturalAndNot` does not truncate when both arguments are larger than a `Word`, so this appears to be a bug.
Luckily, the fix is pretty easy: we just need to call `bigNatAndNotWord#` instead of truncating.
Fixes #26230
(cherry picked from commit a766286fe759251eceb304c54ba52841c2a51f86)
- - - - -
ceb55a1f by Zubin Duggal at 2025-09-02T15:05:08-04:00
testsuite: Be more permissive when filtering out GNU_PROPERTY_TYPE linker warnings
The warning text is slightly different with ld.bfd.
Fixes #26249
(cherry picked from commit 51c701fef034e2062809eed5de3a51bb0a4243ba)
- - - - -
a85edeb7 by Teo Camarasu at 2025-09-02T15:05:18-04:00
rts: ensure MessageBlackHole.link is always a valid closure
We turn a MessageBlackHole into an StgInd in wakeBlockingQueue().
Therefore it's important that the link field, which becomes the
indirection field, always points to a valid closure.
It's unclear whether it's currently possible for the previous behaviour
to lead to a crash, but it's good to be consistent about this invariant nonetheless.
Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at>
(cherry picked from commit a8b2fbae6bcf20bc2f3fe58803096d2a9c5fc43d)
- - - - -
2fded9af by Teo Camarasu at 2025-09-02T15:05:23-04:00
rts: spin if we see a WHITEHOLE in messageBlackHole
When a BLACKHOLE gets cancelled in raiseAsync, we indirect to a THUNK.
GC can then shortcut this, replacing our BLACKHOLE with a fresh THUNK.
This THUNK is not guaranteed to have a valid indirectee field.
If at the same time, a message intended for the previous BLACKHOLE is
processed and concurrently we BLACKHOLE the THUNK, thus temporarily
turning it into a WHITEHOLE, we can get a segfault, since we look at the
undefined indirectee field of the THUNK
The fix is simple: spin if we see a WHITEHOLE, and it will soon be
replaced with a valid BLACKHOLE.
Resolves #26205
(cherry picked from commit 4021181ee0860aca2054883a531f3312361cc701)
- - - - -
addff92e by Cheng Shao at 2025-09-02T15:07:22-04:00
hadrian: enforce have_llvm=False for wasm32/js
This patch fixes hadrian to always pass have_llvm=False to the
testsuite driver for wasm32/js targets. These targets don't really
support the LLVM backend, and the optllvm test way doesn't work. We
used to special-case wasm32/js to avoid auto-adding optllvm way in
testsuite/config/ghc, but this is still problematic if someone writes
a new LLVM-related test and uses something like when(have_llvm(),
extra_ways(["optllvm"])). So better just enforce have_llvm=False for
these targets here.
(cherry picked from commit 1cdc6f46c4168dd92a8f5ea0c398b67fc59449a9)
- - - - -
73364af4 by fendor at 2025-09-02T15:07:38-04:00
rts: Strip lower three bits when hashing Word instead of lower eight bits
(cherry picked from commit 58e46da9dad572b95b4e354d0a0ed25ce9af5d02)
- - - - -
ba8b5927 by Cheng Shao at 2025-09-02T15:07:46-04:00
libffi: update to 3.5.2
Bumps libffi submodule.
(cherry picked from commit 45dbfa23f508f221b6aeb667783a928511a7654e)
- - - - -
d4aeb662 by Simon Peyton Jones at 2025-09-02T15:07:53-04:00
Take yet more care with reporting redundant constraints
This small patch fixes #25992, which relates to reporting redundant
constraints on default-method declarations.
See (TRC5) in Note [Tracking redundant constraints]
(cherry picked from commit f4bac60722ac990d349bdffa3e4fcfcaf6d8f11b)
- - - - -
802372b1 by Vekhir -- at 2025-09-02T15:08:20-04:00
Bump Cabal dependency
(cherry picked from commit 276f8ea8d369b202549a2e30be9b88a95a329083)
- - - - -
893652db by Simon Peyton Jones at 2025-09-02T15:08:30-04:00
Start with empty inerts in shortcut solving
When short-cut solving we were starting with an inert set that had
unsolved Wanteds. This caused an infinite loop (#26314), because a
typechecker plugin kept being given that unsolved Wanted.
It's better just to start with an empty inert set
(cherry picked from commit ccda188d726804e4154de9318c72c5a656f3b015)
- - - - -
2a888147 by fendor at 2025-09-02T15:08:42-04:00
Remove deprecated functions from the ghci package
(cherry picked from commit f0a19d744e339189cfd63b52585e16043ed4997a)
- - - - -
b8b09969 by fendor at 2025-09-02T15:09:26-04:00
base: Remove unstable heap representation details from GHC.Exts
(cherry picked from commit ebeb991b7c81a5e5f5c09aba9a4af0f85e656253)
- - - - -
79cf7742 by Cheng Shao at 2025-09-02T15:10:28-04:00
wasm: ensure setKeepCAFs() is called in ghci
This patch is a critical bugfix for #26106, see comment and linked
issue for details.
(cherry picked from commit 10f06163d9adcb3b6e6438f1524faaca3bf6c3b2)
- - - - -
65325218 by Simon Peyton Jones at 2025-09-02T15:10:44-04:00
Comments only
(cherry picked from commit 00478944861fe3ab146d759898ea0285484d8387)
- - - - -
ca12f880 by Simon Peyton Jones at 2025-09-02T15:10:44-04:00
Type-family occurs check in unification
The occurs check in `GHC.Core.Unify.uVarOrFam` was inadequate in dealing
with type families.
Better now. See Note [The occurs check in the Core unifier].
As I did this I realised that the whole apartness thing is trickier than I
thought: see the new Note [Shortcomings of the apartness test]
(cherry picked from commit a78845896d7f5b692372c137fd7a73bcdf94eddb)
- - - - -
f6a086c3 by Simon Peyton Jones at 2025-09-04T10:34:26-04:00
Fix a long standing bug in the coercion optimiser
We were mis-optimising ForAllCo, leading to #26345
Part of the poblem was the tricky tower of abstractions leading to
the dreadful
GHC.Core.TyCo.Subst.substForAllCoTyVarBndrUsing
This function was serving two masters: regular substitution, but also
coercion optimsation. So tricky was it that it did so wrong.
In this MR I locate all the fancy footwork for coercion optimisation
in GHC.Core.Coercion.Opt, where it belongs. That leaves substitution
free to be much simpler.
(cherry picked from commit fb9cc8825f37b1d7f1bc19d5a5c1425c7613e81a)
Metric Decrease:
CoOpt_Read
- - - - -
44 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Unify.hs
- hadrian/hadrian.cabal
- hadrian/src/Settings/Builders/RunTest.hs
- libffi-tarballs
- libraries/base/changelog.md
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-bignum/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/ghci.cabal.in
- rts/Hash.c
- rts/Messages.c
- rts/StgMiscClosures.cmm
- rts/Updates.h
- testsuite/config/ghc
- testsuite/driver/testlib.py
- − testsuite/tests/module/T21752.stderr
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/partial-sigs/should_compile/T26256.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T25992a.hs
- + testsuite/tests/typecheck/should_compile/T26256a.hs
- + testsuite/tests/typecheck/should_compile/T26345.hs
- + testsuite/tests/typecheck/should_compile/T26346.hs
- + testsuite/tests/typecheck/should_compile/T26358.hs
- testsuite/tests/typecheck/should_compile/all.T
- utils/jsffi/dyld.mjs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5f9c0b626a05313c01ce68f6defe8c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5f9c0b626a05313c01ce68f6defe8c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Add Control.Monad.thenM and Control.Applicative.thenA
by Marge Bot (＠marge-bot) 04 Sep '25
by Marge Bot (＠marge-bot) 04 Sep '25
04 Sep '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8b2c72c0 by L0neGamer at 2025-09-04T06:32:03-04:00
Add Control.Monad.thenM and Control.Applicative.thenA
- - - - -
39e1b7cb by Teo Camarasu at 2025-09-04T06:32:46-04:00
ghc-internal: invert dependency of GHC.Internal.TH.Syntax on Data.Data
This means that Data.Data no longer blocks building TH.Syntax, which
allows greater parallelism in our builds.
We move the Data.Data.Data instances to Data.Data. Quasi depends on
Data.Data for one of its methods, so,
we split the Quasi/Q, etc definition out of GHC.Internal.TH.Syntax
into its own module. This has the added benefit of splitting up this
quite large module.
Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now
it is less of a bottle-neck and is also slightly quicker to
compile (since it no longer contains these instances) at the cost of
making Data.Data slightly more expensive to compile.
TH.Lift which depends on TH.Syntax can also compile quicker and no
longer blocks ghc-internal finishing to compile.
Resolves #26217
-------------------------
Metric Decrease:
MultiLayerModulesTH_OneShot
T13253
T21839c
T24471
Metric Increase:
T12227
-------------------------
- - - - -
bdf82fd2 by Teo Camarasu at 2025-09-04T06:32:46-04:00
compiler: delete unused names in Builtins.Names.TH
returnQ and bindQ are no longer used in the compiler.
There was also a very old comment that referred to them that I have modernized
- - - - -
12952b49 by Ben Gamari at 2025-09-04T11:11:02-04:00
hadrian: Pass lib & include directories to ghc `Setup configure`
- - - - -
65b20357 by Ben Gamari at 2025-09-04T11:11:03-04:00
rts/IPE: Fix compilation when zstd is enabled
This was broken by the refactoring undertaken in
c80dd91c0bf6ac034f0c592f16c548b9408a8481.
Closes #26312.
- - - - -
0f35d855 by sheaf at 2025-09-04T11:11:15-04:00
Make mkCast assertion a bit clearer
This commit changes the assertion message that gets printed when one
calls mkCast with a coercion whose kind does not match the type of the
inner expression. I always found the assertion message a bit confusing,
as it didn't clearly state what exactly was the error.
- - - - -
e07a72f7 by sheaf at 2025-09-04T11:11:15-04:00
Simplifier/rules: fix mistakes in Notes & comments
- - - - -
49 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Types/TH.hs
- hadrian/src/Settings/Packages.hs
- libraries/base/changelog.md
- libraries/base/src/Control/Applicative.hs
- libraries/base/src/Control/Monad.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- + libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- rts/IPE.c
- testsuite/tests/deriving/should_compile/T14682.stderr
- testsuite/tests/deriving/should_compile/drv-empty-data.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/profiling/should_run/callstack001.stdout
- testsuite/tests/splice-imports/SI29.stderr
- testsuite/tests/th/T11452.stderr
- testsuite/tests/th/T15321.stderr
- testsuite/tests/th/T7276.stderr
- testsuite/tests/th/TH_NestedSplicesFail3.stderr
- testsuite/tests/th/TH_NestedSplicesFail4.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ec47211087532100409bd868e01c26…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ec47211087532100409bd868e01c26…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/backports-9.14] Fix a long standing bug in the coercion optimiser
by Ben Gamari (＠bgamari) 04 Sep '25
by Ben Gamari (＠bgamari) 04 Sep '25
04 Sep '25
Ben Gamari pushed to branch wip/backports-9.14 at Glasgow Haskell Compiler / GHC
Commits:
f6a086c3 by Simon Peyton Jones at 2025-09-04T10:34:26-04:00
Fix a long standing bug in the coercion optimiser
We were mis-optimising ForAllCo, leading to #26345
Part of the poblem was the tricky tower of abstractions leading to
the dreadful
GHC.Core.TyCo.Subst.substForAllCoTyVarBndrUsing
This function was serving two masters: regular substitution, but also
coercion optimsation. So tricky was it that it did so wrong.
In this MR I locate all the fancy footwork for coercion optimisation
in GHC.Core.Coercion.Opt, where it belongs. That leaves substitution
free to be much simpler.
(cherry picked from commit fb9cc8825f37b1d7f1bc19d5a5c1425c7613e81a)
Metric Decrease:
CoOpt_Read
- - - - -
6 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- + testsuite/tests/typecheck/should_compile/T26345.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -93,9 +93,10 @@ module GHC.Core.Coercion (
liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,
emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,
liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst,
+ updateLCSubst,
mkSubstLiftingContext, liftingContextSubst, zapLiftingContext,
- substForAllCoBndrUsingLC, lcLookupCoVar, lcInScopeSet,
+ lcLookupCoVar, lcInScopeSet,
LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,
substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,
@@ -2136,15 +2137,11 @@ extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)
zapLiftingContext :: LiftingContext -> LiftingContext
zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv
--- | Like 'substForAllCoBndr', but works on a lifting context
-substForAllCoBndrUsingLC :: SwapFlag
- -> (Coercion -> Coercion)
- -> LiftingContext -> TyCoVar -> Coercion
- -> (LiftingContext, TyCoVar, Coercion)
-substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
- = (LC subst' lc_env, tv', co')
+updateLCSubst :: LiftingContext -> (Subst -> (Subst, a)) -> (LiftingContext, a)
+-- Lift a Subst-update function over LiftingContext
+updateLCSubst (LC subst lc_env) upd = (LC subst' lc_env, res)
where
- (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co
+ (subst', res) = upd subst
-- | The \"lifting\" operation which substitutes coercions for type
-- variables in a type to produce a coercion.
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -358,12 +358,12 @@ opt_co4' env sym rep r (AppCo co1 co2)
(opt_co4 env sym False Nominal co2)
opt_co4' env sym rep r (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
- , fco_kind = k_co, fco_body = co })
- = case optForAllCoBndr env sym tv k_co of
- (env', tv', k_co') -> mkForAllCo tv' visL' visR' k_co' $
- opt_co4 env' sym rep r co
+ , fco_kind = k_co, fco_body = co })
+ = mkForAllCo tv' visL' visR' k_co' $
+ opt_co4 env' sym rep r co
-- Use the "mk" functions to check for nested Refls
where
+ !(env', tv', k_co') = optForAllCoBndr env sym tv k_co
!(visL', visR') = swapSym sym (visL, visR)
opt_co4' env sym rep r (FunCo _r afl afr cow co1 co2)
@@ -1401,10 +1401,68 @@ and these two imply
-}
+{- Note [Optimising ForAllCo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If sym=NotSwapped, optimising ForAllCo is relatively easy:
+ opt env (ForAllCo tcv kco bodyco)
+ = ForAllCo tcv' (opt env kco) (opt env' bodyco)
+ where
+ (env', tcv') = substBndr env tcv
+
+Just apply the substitution to the kind of the binder, deal with
+shadowing etc, and recurse. Remember in (ForAllCo tcv kco bodyco)
+ varKind tcv = coercionLKind kco
+
+But if sym=Swapped, things are trickier. Here is an identity that helps:
+ Sym (ForAllCo (tv:k1) (kco:k1~k2) bodyco)
+ = ForAllCo (tv:k2) (Sym kco : k2~k1)
+ (Sym (bodyco[tv:->tv:k2 |> Sym kco]))
+
+* We re-type tv:k1 to become tv:k2.
+* We push Sym into kco
+* We push Sym into bodyco
+* BUT we must /also/ remember to replace all occurrences of
+ of tv:k1 in bodyco by (tv:k2 |> Sym kco)
+ This mirrors what happens in the typing rule for ForAllCo
+ See Note [ForAllCo] in GHC.Core.TyCo.Rep
+
+-}
optForAllCoBndr :: LiftingContext -> SwapFlag
- -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)
-optForAllCoBndr env sym
- = substForAllCoBndrUsingLC sym (opt_co4 env sym False Nominal) env
+ -> TyCoVar -> Coercion
+ -> (LiftingContext, TyCoVar, Coercion)
+-- See Note [Optimising ForAllCo]
+optForAllCoBndr env sym tcv kco
+ = (env', tcv', kco')
+ where
+ kco' = opt_co4 env sym False Nominal kco -- Push sym into kco
+ (env', tcv') = updateLCSubst env upd_subst
+
+ upd_subst :: Subst -> (Subst, TyCoVar)
+ upd_subst subst
+ | isTyVar tcv = upd_subst_tv subst
+ | otherwise = upd_subst_cv subst
+
+ upd_subst_tv subst
+ | notSwapped sym || isReflCo kco' = (subst1, tv1)
+ | otherwise = (subst2, tv2)
+ where
+ -- subst1,tv1: apply the substitution to the binder and its kind
+ -- NB: varKind tv = coercionLKind kco
+ (subst1, tv1) = substTyVarBndr subst tcv
+ -- In the Swapped case, we re-kind the type variable, AND
+ -- override the substitution for the original variable to the
+ -- re-kinded one, suitably casted
+ tv2 = tv1 `setTyVarKind` coercionLKind kco'
+ subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco'))
+ `extendSubstInScope` tv2
+
+ upd_subst_cv subst -- ToDo: probably not right yet
+ | notSwapped sym || isReflCo kco' = (subst1, cv1)
+ | otherwise = (subst2, cv2)
+ where
+ (subst1, cv1) = substCoVarBndr subst tcv
+ cv2 = cv1 `setTyVarKind` coercionLKind kco'
+ subst2 = subst1 `extendSubstInScope` cv2
{- **********************************************************************
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -60,7 +60,7 @@ import {-# SOURCE #-} GHC.Core.Coercion
, mkAxiomCo, mkAppCo, mkGReflCo
, mkInstCo, mkLRCo, mkTyConAppCo
, mkCoercionType
- , coercionKind, coercionLKind, coVarTypesRole )
+ , coercionLKind, coVarTypesRole )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )
import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr
import {-# SOURCE #-} GHC.Core ( CoreExpr )
@@ -68,12 +68,10 @@ import {-# SOURCE #-} GHC.Core ( CoreExpr )
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.FVs
-import GHC.Types.Basic( SwapFlag(..), isSwapped, pickSwap, notSwapped )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Data.Pair
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Types.Unique.Supply
@@ -922,7 +920,7 @@ substDCoVarSet subst cvs = coVarsOfCosDSet $ map (substCoVar subst) $
substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion
-> (Subst, TyCoVar, Coercion)
substForAllCoBndr subst
- = substForAllCoBndrUsing NotSwapped (substCo subst) subst
+ = substForAllCoBndrUsing (substCo subst) subst
-- | Like 'substForAllCoBndr', but disables sanity checks.
-- The problems that the sanity checks in substCo catch are described in
@@ -932,33 +930,26 @@ substForAllCoBndr subst
substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion
-> (Subst, TyCoVar, Coercion)
substForAllCoBndrUnchecked subst
- = substForAllCoBndrUsing NotSwapped (substCoUnchecked subst) subst
+ = substForAllCoBndrUsing (substCoUnchecked subst) subst
-- See Note [Sym and ForAllCo]
-substForAllCoBndrUsing :: SwapFlag -- Apply sym to binder?
- -> (Coercion -> Coercion) -- transformation to kind co
+substForAllCoBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
-> Subst -> TyCoVar -> KindCoercion
-> (Subst, TyCoVar, KindCoercion)
-substForAllCoBndrUsing sym sco subst old_var
- | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var
- | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var
+substForAllCoBndrUsing sco subst old_var
+ | isTyVar old_var = substForAllCoTyVarBndrUsing sco subst old_var
+ | otherwise = substForAllCoCoVarBndrUsing sco subst old_var
-substForAllCoTyVarBndrUsing :: SwapFlag -- Apply sym to binder?
- -> (Coercion -> Coercion) -- transformation to kind co
+substForAllCoTyVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
-> Subst -> TyVar -> KindCoercion
-> (Subst, TyVar, KindCoercion)
-substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co
+substForAllCoTyVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co
= assert (isTyVar old_var )
( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv
, new_var, new_kind_co )
where
- new_env | no_change, notSwapped sym
- = delVarEnv tenv old_var
- | isSwapped sym
- = extendVarEnv tenv old_var $
- TyVarTy new_var `CastTy` new_kind_co
- | otherwise
- = extendVarEnv tenv old_var (TyVarTy new_var)
+ new_env | no_change = delVarEnv tenv old_var
+ | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
no_kind_change = noFreeVarsOfCo old_kind_co
no_change = no_kind_change && (new_var == old_var)
@@ -974,20 +965,17 @@ substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old
new_var = uniqAway in_scope (setTyVarKind old_var new_ki1)
-substForAllCoCoVarBndrUsing :: SwapFlag -- Apply sym to binder?
- -> (Coercion -> Coercion) -- transformation to kind co
+substForAllCoCoVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
-> Subst -> CoVar -> KindCoercion
-> (Subst, CoVar, KindCoercion)
-substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv)
+substForAllCoCoVarBndrUsing sco (Subst in_scope idenv tenv cenv)
old_var old_kind_co
= assert (isCoVar old_var )
( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv
, new_var, new_kind_co )
where
- new_cenv | no_change, notSwapped sym
- = delVarEnv cenv old_var
- | otherwise
- = extendVarEnv cenv old_var (mkCoVarCo new_var)
+ new_cenv | no_change = delVarEnv cenv old_var
+ | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)
no_kind_change = noFreeVarsOfCo old_kind_co
no_change = no_kind_change && (new_var == old_var)
@@ -995,10 +983,8 @@ substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv)
new_kind_co | no_kind_change = old_kind_co
| otherwise = sco old_kind_co
- Pair h1 h2 = coercionKind new_kind_co
-
- new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type
- new_var_type = pickSwap sym h1 h2
+ new_ki1 = coercionLKind new_kind_co
+ new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1
substCoVar :: Subst -> CoVar -> Coercion
substCoVar (Subst _ _ _ cenv) cv
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -559,11 +559,7 @@ expandTypeSynonyms ty
go_co _ (HoleCo h)
= pprPanic "expandTypeSynonyms hit a hole" (ppr h)
- -- the "False" and "const" are to accommodate the type of
- -- substForAllCoBndrUsing, which is general enough to
- -- handle coercion optimization (which sometimes swaps the
- -- order of a coercion)
- go_cobndr subst = substForAllCoBndrUsing NotSwapped (go_co subst) subst
+ go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst
{- Notes on type synonyms
~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
testsuite/tests/typecheck/should_compile/T26345.hs
=====================================
@@ -0,0 +1,57 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE TypeFamilies #-}
+module Bug where
+
+import Data.Kind (Constraint, Type)
+
+type Sing :: k -> Type
+type family Sing @k
+
+type Tuple0 :: Type
+data Tuple0 = MkTuple0
+
+type STuple0 :: Tuple0 -> Type
+data STuple0 z where
+ SMkTuple0 :: STuple0 MkTuple0
+type instance Sing @Tuple0 = STuple0
+
+type U1 :: Type
+data U1 = MkU1
+
+type SU1 :: U1 -> Type
+data SU1 z where
+ SMkU1 :: SU1 MkU1
+type instance Sing @U1 = SU1
+
+type Generic :: Type -> Constraint
+class Generic a where
+ type Rep a :: Type
+
+type PGeneric :: Type -> Constraint
+class PGeneric a where
+ type PFrom (x :: a) :: Rep a
+
+type SGeneric :: Type -> Constraint
+class SGeneric a where
+ sFrom :: forall (x :: a). Sing x -> Sing (PFrom x)
+
+instance SGeneric Tuple0 where
+ sFrom SMkTuple0 = SMkU1
+
+instance Generic Tuple0 where
+ type Rep Tuple0 = U1
+
+instance PGeneric Tuple0 where
+ type PFrom MkTuple0 = MkU1
+
+type SDecide :: Type -> Constraint
+class SDecide a where
+ sDecide :: forall (x :: a) (y :: a). Sing x -> Sing y -> Bool
+
+instance SDecide U1 where
+ sDecide SMkU1 SMkU1 = True
+
+sDecideDefault :: Sing MkTuple0 -> Sing MkTuple0 -> Bool
+sDecideDefault s1 s2 = sDecide (sFrom s1) (sFrom s2)
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -945,3 +945,5 @@ test('T26256a', normal, compile, [''])
test('T25992a', normal, compile, [''])
test('T26346', normal, compile, [''])
test('T26358', expect_broken(26358), compile, [''])
+test('T26345', normal, compile, [''])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6a086c355eb027cc40a2b9645eedd3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6a086c355eb027cc40a2b9645eedd3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/9.12.3-backports] 40 commits: fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory
by Zubin (＠wz1000) 04 Sep '25
by Zubin (＠wz1000) 04 Sep '25
04 Sep '25
Zubin pushed to branch wip/9.12.3-backports at Glasgow Haskell Compiler / GHC
Commits:
14d75bd1 by Zubin Duggal at 2025-09-04T17:54:57+05:30
fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory
Fixes #24093
(cherry picked from commit 9fa590a6e27545995cdcf419ed7a6504e6668b18)
- - - - -
0088037f by sheaf at 2025-09-04T17:54:57+05:30
Use mkTrAppChecked in ds_ev_typeable
This change avoids violating the invariant of mkTrApp according to which
the argument should not be a fully saturated function type.
This ensures we don't return false negatives for type equality
involving function types.
Fixes #25998
(cherry picked from commit 9c6d2b1bf54310b6d9755aa2ba67fbe38feeac51)
- - - - -
0b1f3bf6 by Ben Gamari at 2025-09-04T17:54:57+05:30
Reapply "Division by constants optimization"
This reverts commit eb2859af981415ed6bf08fcf4d8f19811bf95494.
(cherry picked from commit f0499c94071c11d31d5afc996431cf4b909dbd76)
- - - - -
632623d7 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker: Don't fail due to RTLD_NOW
In !12264 we started using the NativeObj machinery introduced some time
ago for loading of shared objects. One of the side-effects of this
change is shared objects are now loaded eagerly (i.e. with `RTLD_NOW`).
This is needed by NativeObj to ensure full visibility of the mappings of
the loaded object, which is in turn needed for safe shared object
unloading.
Unfortunately, this change subtly regressed, causing compilation
failures in some programs. Specifically, shared objects which refer to
undefined symbols (e.g. which may be usually provided by either the
executable image or libraries loaded via `dlopen`) will fail to load
with eager binding. This is problematic as GHC loads all package
dependencies while, e.g., evaluating TemplateHaskell splices. This
results in compilation failures in programs depending upon (but not
using at compile-time) packages with undefined symbol references.
To mitigate this NativeObj now first attempts to load an object via
eager binding, reverting to lazy binding (and disabling unloading) on
failure.
See Note [Don't fail due to RTLD_NOW].
Fixes #25943.
(cherry picked from commit 715d2a8550418d342bea767e1a4b0c7695966463)
(cherry picked from commit a9de3b73ebb6f29eeae7d170a0210f5bedeb8d85)
- - - - -
ce4c8735 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker: Factor out ProddableBlocks machinery
(cherry picked from commit 2921131cfa185c8e0ec48ddce2c994615493ca0a)
(cherry picked from commit 7d7e096504cd35272df9727b92dcbe7d94927ac8)
- - - - -
3ee32ef9 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker: Improve efficiency of proddable blocks structure
Previously the linker's "proddable blocks" check relied on a simple
linked list of spans. This resulted in extremely poor complexity while
linking objects with lots of small sections (e.g. objects built with
split sections).
Rework the mechanism to instead use a simple interval set implemented
via binary search.
Fixes #26009.
(cherry picked from commit e6e69dba996f47e21391f023010f5b138dc1df9c)
(cherry picked from commit b388ca86b5e56636a1862987ec1b1d3deefedc9e)
- - - - -
bf2d27b5 by Ben Gamari at 2025-09-04T17:54:57+05:30
testsuite: Add simple functional test for ProddableBlockSet
(cherry picked from commit 915902fc09ff4b00cf676c40d31dbbbf7d1cb7d7)
(cherry picked from commit dc4c540ddd39fb99b18630aebd2849ac29a4cd73)
- - - - -
553dcd51 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS
The `LOAD_LIBRARY_SEARCH_USER_DIRS` and
`LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and
have been available every since. As we no longer support Windows XP we
can drop this check.
Addresses #26009.
(cherry picked from commit 1f38e2739fbbae3cbe925320fa70965004aaaca5)
(cherry picked from commit 10cfa8946b76a914fb3ecd4df62d32160b64151a)
- - - - -
754f5c06 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker/PEi386: Clean up code style
(cherry picked from commit facf379b0f1c0d1cbc3c1896cce603c89e837481)
(cherry picked from commit 92793b3799525f46373d9696c7e91c0d14860fa8)
- - - - -
002ac0bf by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/Hash: Factor out hashBuffer
This is a useful helper which can be used for non-strings as well.
(cherry picked from commit 827961b9a724d8b2dd848222f980efc2de3996e3)
(cherry picked from commit a8c1ecb0d45050491496c0d04cc022a294a075b1)
- - - - -
338c6066 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker/PEi386: Fix incorrect use of break in nested for
Previously the happy path of PEi386 used `break` in a double-`for` loop
resulting in redundant calls to `LoadLibraryEx`.
Fixes #26052.
(cherry picked from commit 6fbb05cf8a999628476d0d7274f30ef45e4d3932)
(cherry picked from commit 36a8bd2b7ceb0622e0aca2bed9cee7162076379c)
- - - - -
c3471809 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts: Correctly mark const arguments
(cherry picked from commit 320d7dd3e8de62f970d23ac1d27c665093d22aaa)
(cherry picked from commit 3a389cacefaffb3293f6b5f2ed5b20f2dbb9b4e3)
- - - - -
b79b3668 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker/PEi386: Don't repeatedly load DLLs
Previously every DLL-imported symbol would result in a call to
`LoadLibraryEx`. This ended up constituting over 40% of the runtime of
`ghc --interactive -e 42` on Windows. Avoid this by maintaining a
hash-set of loaded DLL names, skipping the call if we have already
loaded the requested DLL.
Addresses #26009.
(cherry picked from commit e6b0067bfa49b42bf4599af8d6a3c97878302624)
(cherry picked from commit b24be9b90adcf3fb9ee0c6b7e120b4bf1e77f072)
- - - - -
3ebc4f8d by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/linker: Expand comment describing ProddableBlockSet
(cherry picked from commit 9631a12c0b89529c3d1147d0770ec6b9023cdb17)
(cherry picked from commit 6ad664de0a4ab3e1747d318aabb5035ce7c74fcd)
- - - - -
ca493586 by Cheng Shao at 2025-09-04T17:54:57+05:30
rts: fix rts_clearMemory logic when sanity checks are enabled
This commit fixes an RTS assertion failure when invoking
rts_clearMemory with +RTS -DS. -DS implies -DZ which asserts that free
blocks contain 0xaa as the designated garbage value. Also adds the
sanity way to rts_clearMemory test to prevent future regression.
Closes #26011.
ChatGPT Codex automatically diagnosed the issue and proposed the
initial patch in a single shot, given a GHC checkout and the following
prompt:
---
Someone is reporting the following error when attempting to use `rts_clearMemory` with the RTS option `-DS`:
```
test.wasm: internal error: ASSERTION FAILED: file rts/sm/Storage.c, line 1216
(GHC version 9.12.2.20250327 for wasm32_unknown_wasi)
Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug
```
What's the culprit? How do I look into this issue?
---
I manually reviewed & revised the patch, tested and submitted it.
(cherry picked from commit 86406f48659a5ab61ce1fd2a2d427faba2dcdb09)
- - - - -
280f87fe by kwxm at 2025-09-04T17:54:57+05:30
Fix bugs in `integerRecipMod` and `integerPowMod`
This fixes #26017.
* `integerRecipMod x 1` now returns `(# 1 | #)` for all x; previously it
incorrectly returned `(# | () #)`, indicating failure.
* `integerPowMod 0 e m` now returns `(# | () #)` for e<0 and m>1, indicating
failure; previously it incorrectly returned `(# 0 | #)`.
(cherry picked from commit 8ded23300367c6e032b3c5a635fd506b8915374b)
- - - - -
905715ad by Matthew Pickering at 2025-09-04T17:54:57+05:30
interpreter: Fix INTERP_STATS profiling code
The profiling code had slightly bitrotted since the last time it was
used. This just fixes things so that if you toggle the INTERP_STATS
macro then it just works and prints out the stats.
Fixes #25695
(cherry picked from commit 66c7f65676801367f440a6a644f87d71157d2f3f)
- - - - -
8033abd5 by Matthew Pickering at 2025-09-04T17:54:57+05:30
interpreter: Fix overflows and reentrancy in statistics calculation
1. Use unsigned long for counter, as they can easily overflow if you are
running a long benchmark.
2. Make interp_shutdown reentrant by copying the command frequency table
into an array.
Fixes #25756
(cherry picked from commit c4e112fccd10ca745771dd81d2c1eb340aa8dd86)
- - - - -
2759c597 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts: Tighten up invariants of PACK
(cherry picked from commit aa58fc5b9745a2201707de81a91960b213ea3258)
- - - - -
30cd1559 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts: Improve documentation of SLIDE bytecode instruction
(cherry picked from commit 0e084029def86e9e67b89317f44fd71c823e9bca)
- - - - -
f5ff86f2 by Ben Gamari at 2025-09-04T17:54:57+05:30
rts/Interpreter: Assert that TEST*_P discriminators are valid
(cherry picked from commit 9bf3663b9970851e7b5701d68147450272823197)
- - - - -
60906d43 by Ben Gamari at 2025-09-04T17:54:58+05:30
Revert "rts/Interpreter: Assert that TEST*_P discriminators are valid"
This assertion was based on the misconception that `GET_TAG` was
returning the pointer tag whereas it is actually returning the
constructor tag.
This reverts commit 9bf3663b9970851e7b5701d68147450272823197.
Fixes #25527.
(cherry picked from commit dd95940639fd198f97fb3f44e84494eaca721788)
- - - - -
d302744c by Matthew Pickering at 2025-09-04T17:54:58+05:30
interpreter: Fix underflow frame lookups
BCOs can be nested, resulting in nested BCO stack frames where the inner most
stack frame can refer to variables stored on earlier stack frames via the
PUSH_L instruction.
|---------|
| BCO_1 | -<-┐
|---------|
......... |
|---------| | PUSH_L <n>
| BCO_N | ->-┘
|---------|
Here BCO_N is syntactically nested within the code for BCO_1 and will result
in code that references the prior stack frame of BCO_1 for some of it's local
variables. If a stack overflow happens between the creation of the stack frame
for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving
BCO_1 in place, invalidating a simple offset based reference to the outer stack
frames.
Therefore `ReadSpW` first performs a bounds check to ensure that accesses onto
the stack will succeed. If the target address would not be a valid location for
the current stack chunk then `slow_spw` function is called, which dereferences
the underflow frame to adjust the offset before performing the lookup.
┌->--x | CHK_1 |
| CHK_2 | | | |---------|
|---------| | └-> | BCO_1 |
| UD_FLOW | -- x |---------|
|---------| |
| ...... | |
|---------| | PUSH_L <n>
| BCO_ N | ->-┘
|---------|
Fixes #25750
(cherry picked from commit f4da90f11e3a3a634ec3edb6d70d96fe3515b726)
- - - - -
63480835 by Ben Gamari at 2025-09-04T17:54:58+05:30
base: Note strictness changes made in 4.16.0.0
Addresses #25886.
(cherry picked from commit 7722232c6f8f0b57db03d0439d77896d38191bf9)
- - - - -
aaff4d7c by Hécate Kleidukos at 2025-09-04T17:54:58+05:30
Expose all of Backtraces' internals for ghc-internal
Closes #26049
(cherry picked from commit 16014bf84afa0d009b6254b103033bceca42233a)
- - - - -
5e37fa3b by ARATA Mizuki at 2025-09-04T17:54:58+05:30
AArch64 NCG: Fix sub-word arithmetic right shift
As noted in Note [Signed arithmetic on AArch64], we should zero-extend sub-word values.
Fixes #26061
(cherry picked from commit 265d0024abc95be941f8e4769f24af128eedaa10)
- - - - -
76b9fcbd by ARATA Mizuki at 2025-09-04T17:54:58+05:30
x86 NCG: Fix code generation of bswap64 on i386
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
Fix #25601
(cherry picked from commit bfa6b70f27dc2ce7fc890ec71103c40f66497c77)
- - - - -
ac4851da by Cheng Shao at 2025-09-04T17:54:58+05:30
testsuite: add T26120 marked as broken
(cherry picked from commit 44b8cee2d5c114b238898ce4ee7b44ecaa0bf491)
- - - - -
1abd3606 by Berk Özkütük at 2025-09-04T17:54:58+05:30
Consider `PromotedDataCon` in `tyConStupidTheta`
Haddock checks data declarations for the stupid theta so as not to
pretty-print them as empty contexts. Type data declarations end up as
`PromotedDataCon`s by the time Haddock performs this check, causing a
panic. This commit extends `tyConStupidTheta` so that it returns an
empty list for `PromotedDataCon`s. This decision was guided by the fact
that type data declarations never have data type contexts (see (R1) in
Note [Type data declarations]).
Fixes #25739.
(cherry picked from commit 8d33d048dbe159a045a4c304fa92318365a3dfe2)
- - - - -
ebbabfb1 by Cheng Shao at 2025-09-04T17:54:58+05:30
compiler: fix GHC.SysTools.Ar archive member size writing logic
This patch fixes a long-standing bug in `GHC.SysTools.Ar` that emits
the wrong archive member size in each archive header. It should encode
the exact length of the member payload, excluding any padding byte,
otherwise malformed archive that extracts a broken object with an
extra trailing byte could be created.
Apart from the in-tree `T26120` test, I've also created an out-of-tree
testsuite at https://github.com/TerrorJack/ghc-ar-quickcheck that
contains QuickCheck roundtrip tests for `GHC.SysTools.Ar`. With this
fix, simple roundtrip tests and `writeGNUAr`/GNU `ar` roundtrip test
passes. There might be more bugs lurking in here, but this patch is
still a critical bugfix already.
Fixes #26120 #22586.
Co-authored-by: Codex <codex(a)openai.com>
(cherry picked from commit 894a04f3a82dd39ecef71619e2032c4dfead556e)
- - - - -
cf0c68dd by Teo Camarasu at 2025-09-04T17:54:58+05:30
rts/nonmovingGC: remove n_free
We remove the nonmovingHeap.n_free variable.
We wanted this to track the length of nonmovingHeap.free.
But this isn't possible to do atomically.
When this isn't accurate we can get a segfault by going past the end of
the list.
Instead, we just count the length of the list when we grab it in
nonmovingPruneFreeSegment.
Resolves #26186
(cherry picked from commit 45efaf71d97355f76fe0db5af2fc5b4b67fddf47)
- - - - -
1518404f by Andreas Klebinger at 2025-09-04T17:54:58+05:30
Disable -fprof-late-overloaded-calls for join points.
Currently GHC considers cost centres as destructive to
join contexts. Or in other words this is not considered valid:
join f x = ...
in
... -> scc<tick> jmp
This makes the functionality of `-fprof-late-overloaded-calls` not feasible
for join points in general. We used to try to work around this by putting the
ticks on the rhs of the join point rather than around the jump. However beyond
the loss of accuracy this was broken for recursive join points as we ended up
with something like:
rec-join f x = scc<tick> ... jmp f x
Which similarly is not valid as the tick once again destroys the tail call.
One might think we could limit ourselves to non-recursive tail calls and do
something clever like:
join f x = scc<tick> ...
in ... jmp f x
And sometimes this works! But sometimes the full rhs would look something like:
join g x = ....
join f x = scc<tick> ... -> jmp g x
Which, would again no longer be valid. I believe in the long run we can make
cost centre ticks non-destructive to join points. Or we could keep track of
where we are/are not allowed to insert a cost centre. But in the short term I will
simply disable the annotation of join calls under this flag.
(cherry picked from commit 7da86e165612721c4e09f772a3fdaffc733e9293)
- - - - -
41829358 by Sebastian Graf at 2025-09-04T17:54:58+05:30
CprAnal: Detect recursive newtypes (#25944)
While `cprTransformDataConWork` handles recursive data con workers, it
did not detect the case when a newtype is responsible for the recursion.
This is now detected in the `Cast` case of `cprAnal`.
The same reproducer made it clear that `isRecDataCon` lacked congruent
handling for `AppTy` and `CastTy`, now fixed.
Furthermore, the new repro case T25944 triggered this bug via an
infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`.
While it should be much less likely to trigger such an infinite loop now
that `isRecDataCon` has been fixed, I made sure to abort the loop after
10 iterations and emitting a warning instead.
Fixes #25944.
(cherry picked from commit 4bc78496406f7469640faaa46e2f311c05760124)
- - - - -
36436e87 by Ben Gamari at 2025-09-04T17:54:58+05:30
configure: Allow override of CrossCompiling
As noted in #26236, the current inference logic is a bit simplistic. In
particular, there are many cases (e.g. building for a new libc) where
the target and host triples may differ yet we are still able to run the
produced artifacts as native code.
Closes #26236.
(cherry picked from commit 81577fe7c1913c53608bf03e48f84507be904620)
- - - - -
8384119d by Simon Peyton Jones at 2025-09-04T17:54:58+05:30
Take more care in zonkEqTypes on AppTy/AppTy
This patch fixes #26256.
See Note [zonkEqTypes and the PKTI] in GHC.Tc.Solver.Equality
(cherry picked from commit 18036d5205ac648bb245217519fed2fd931a9982)
- - - - -
fa1e584a by Andreas Klebinger at 2025-09-04T17:54:58+05:30
Make unexpected LLVM versions a warning rather than an error.
Typically a newer LLVM version *will* work so erroring out if
a user uses a newer LLVM version is too aggressive.
Fixes #25915
(cherry picked from commit 50842f83f467ff54dd22470559a7af79d2025c03)
- - - - -
3b41b6e2 by Teo Camarasu at 2025-09-04T17:54:58+05:30
rts: spin if we see a WHITEHOLE in messageBlackHole
When a BLACKHOLE gets cancelled in raiseAsync, we indirect to a THUNK.
GC can then shortcut this, replacing our BLACKHOLE with a fresh THUNK.
This THUNK is not guaranteed to have a valid indirectee field.
If at the same time, a message intended for the previous BLACKHOLE is
processed and concurrently we BLACKHOLE the THUNK, thus temporarily
turning it into a WHITEHOLE, we can get a segfault, since we look at the
undefined indirectee field of the THUNK
The fix is simple: spin if we see a WHITEHOLE, and it will soon be
replaced with a valid BLACKHOLE.
Resolves #26205
(cherry picked from commit 4021181ee0860aca2054883a531f3312361cc701)
- - - - -
124fd2fd by Teo Camarasu at 2025-09-04T17:54:58+05:30
rts: ensure MessageBlackHole.link is always a valid closure
We turn a MessageBlackHole into an StgInd in wakeBlockingQueue().
Therefore it's important that the link field, which becomes the
indirection field, always points to a valid closure.
It's unclear whether it's currently possible for the previous behaviour
to lead to a crash, but it's good to be consistent about this invariant nonetheless.
Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at>
(cherry picked from commit a8b2fbae6bcf20bc2f3fe58803096d2a9c5fc43d)
- - - - -
1f8f030e by Reed Mullanix at 2025-09-04T17:54:58+05:30
ghc-internal: Fix naturalAndNot for NB/NS case
When the first argument to `naturalAndNot` is larger than a `Word` and the second is `Word`-sized, `naturalAndNot` will truncate the
result:
```
>>> naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)
0
```
In contrast, `naturalAndNot` does not truncate when both arguments are larger than a `Word`, so this appears to be a bug.
Luckily, the fix is pretty easy: we just need to call `bigNatAndNotWord#` instead of truncating.
Fixes #26230
(cherry picked from commit a766286fe759251eceb304c54ba52841c2a51f86)
- - - - -
d0629aa6 by Ben Gamari at 2025-09-04T17:54:58+05:30
llvmGen: Fix built-in variable predicate
Previously the predicate to identify LLVM builtin global variables was
checking for `$llvm` rather than `@llvm` as it should.
(cherry picked from commit 6e67fa083a50684e1cfae546e07cab4d4250e871)
- - - - -
88 changed files:
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/Cmm/Config.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Driver/Config/Cmm.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/SysTools/Ar.hs
- compiler/GHC/Tc/Solver/Equality.hs
- configure.ac
- docs/users_guide/profiling.rst
- libraries/base/changelog.md
- libraries/ghc-bignum/changelog.md
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- rts/Hash.c
- rts/Hash.h
- rts/Interpreter.c
- rts/Interpreter.h
- rts/Linker.c
- rts/LinkerInternals.h
- rts/Messages.c
- rts/PathUtils.c
- rts/PathUtils.h
- rts/RtsMain.c
- rts/StgMiscClosures.cmm
- rts/Updates.h
- rts/include/rts/storage/InfoTables.h
- rts/linker/Elf.c
- rts/linker/LoadNativeObjPosix.c
- rts/linker/MachO.c
- rts/linker/PEi386.c
- rts/linker/PEi386.h
- + rts/linker/ProddableBlocks.c
- + rts/linker/ProddableBlocks.h
- rts/rts.cabal
- rts/sm/NonMoving.c
- rts/sm/NonMoving.h
- rts/sm/NonMovingAllocate.c
- rts/sm/Sanity.c
- rts/sm/Storage.h
- + testsuite/tests/cmm/should_run/T25601.hs
- + testsuite/tests/cmm/should_run/T25601.stdout
- + testsuite/tests/cmm/should_run/T25601a.cmm
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/codeGen/should_run/T26061.hs
- + testsuite/tests/codeGen/should_run/T26061.stdout
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/cpranal/sigs/T25944.hs
- + testsuite/tests/cpranal/sigs/T25944.stderr
- testsuite/tests/cpranal/sigs/all.T
- testsuite/tests/ffi/should_run/all.T
- + testsuite/tests/ghc-api/T26120.hs
- + testsuite/tests/ghc-api/T26120.stdout
- testsuite/tests/ghc-api/all.T
- + testsuite/tests/lib/integer/T26017.hs
- + testsuite/tests/lib/integer/T26017.stdout
- testsuite/tests/lib/integer/all.T
- testsuite/tests/lib/integer/integerRecipMod.hs
- testsuite/tests/lib/integer/integerRecipMod.stdout
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/partial-sigs/should_compile/T26256.hs
- + testsuite/tests/partial-sigs/should_compile/T26256.stderr
- testsuite/tests/partial-sigs/should_compile/all.T
- + testsuite/tests/rts/TestProddableBlockSet.c
- testsuite/tests/rts/all.T
- + testsuite/tests/typecheck/should_compile/T26256a.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_run/T25998.hs
- + testsuite/tests/typecheck/should_run/T25998.stdout
- testsuite/tests/typecheck/should_run/all.T
- + utils/haddock/html-test/ref/Bug25739.html
- + utils/haddock/html-test/src/Bug25739.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9edb71d5f782b8860e674240b6de71…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9edb71d5f782b8860e674240b6de71…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26343] 38 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Teo Camarasu (＠teo) 04 Sep '25
by Teo Camarasu (＠teo) 04 Sep '25
04 Sep '25
Teo Camarasu pushed to branch wip/T26343 at Glasgow Haskell Compiler / GHC
Commits:
5b5d9d47 by Ben Gamari at 2025-08-25T14:29:35-04:00
Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd
- - - - -
10f06163 by Cheng Shao at 2025-08-25T14:30:16-04:00
wasm: ensure setKeepCAFs() is called in ghci
This patch is a critical bugfix for #26106, see comment and linked
issue for details.
- - - - -
bedc1004 by Cheng Shao at 2025-08-26T09:31:18-04:00
compiler: use zero cost coerce in hoopl setElems/mapToList
This patch is a follow-up of !14680 and changes setElems/mapToList in
GHC/Cmm/Dataflow/Label to use coerce instead of mapping mkHooplLabel
over the keys.
- - - - -
13250d97 by Ryan Scott at 2025-08-26T09:31:59-04:00
Reject infix promoted data constructors without DataKinds
In the rename, make sure to apply the same `DataKinds` checks for both
`HsTyVar` (for prefix promoted data constructors) and `HsOpTy` (for infix
promoted data constructors) alike.
Fixes #26318.
- - - - -
37655c46 by Teo Camarasu at 2025-08-26T15:24:51-04:00
tests: disable T22859 under LLVM
This test was failing under the LLVM backend since the allocations
differ from the NCG.
Resolves #26282
- - - - -
2cbba9d6 by Teo Camarasu at 2025-08-26T15:25:33-04:00
base-exports: update version numbers
As the version of the compiler has been bumped, a lot of the embedded
version numbers will need to be updated if we ever run this test with
`--test-accept` so let's just update them now, and keep future diffs
clean.
- - - - -
f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00
Import new name for 'utimbuf' on windows to fix #26337
Fixes an `-Wincompatible-pointer-types` instance that turns into an error on
recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross.
This long-standing warning has been present at least since 9.4:
```
C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error:
warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types]
|
26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
| ^
HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
^~
C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error:
note: passing argument to parameter '_Utimbuf' here
|
109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
| ^
__CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
```
- - - - -
ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00
Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide.
- - - - -
00478944 by Simon Peyton Jones at 2025-08-27T16:48:30+01:00
Comments only
- - - - -
a7884589 by Simon Peyton Jones at 2025-08-28T11:08:23+01:00
Type-family occurs check in unification
The occurs check in `GHC.Core.Unify.uVarOrFam` was inadequate in dealing
with type families.
Better now. See Note [The occurs check in the Core unifier].
As I did this I realised that the whole apartness thing is trickier than I
thought: see the new Note [Shortcomings of the apartness test]
- - - - -
8adfc222 by sheaf at 2025-08-28T19:47:17-04:00
Fix orientation in HsWrapper composition (<.>)
This commit fixes the order in which WpCast HsWrappers are composed,
fixing a bug introduced in commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1.
Fixes #26350
- - - - -
eb2ab1e2 by Oleg Grenrus at 2025-08-29T11:00:53-04:00
Generalise thNameToGhcName by adding HasHscEnv
There were multiple single monad-specific `getHscEnv` across codebase.
HasHscEnv is modelled on HasDynFlags.
My first idea was to simply add thNameToGhcNameHsc and
thNameToGhcNameTc, but those would been exactly the same
as thNameToGhcName already.
Also add an usage example to thNameToGhcName and mention that it's
recommended way of looking up names in GHC plugins
- - - - -
2d575a7f by fendor at 2025-08-29T11:01:36-04:00
configure: Bump minimal bootstrap GHC version to 9.10
- - - - -
716274a5 by Simon Peyton Jones at 2025-08-29T17:27:12-04:00
Fix deep subsumption again
This commit fixed #26255:
commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1
Author: sheaf <sam.derbyshire(a)gmail.com>
Date: Mon Aug 11 15:50:47 2025 +0200
Improve deep subsumption
This commit improves the DeepSubsumption sub-typing implementation
in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back
to unification.
But alas it still wasn't quite right for view patterns: #26331
This MR does a generalisation to fix it. A bit of a sledgehammer to crack
a nut, but nice.
* Add a field `ir_inst :: InferInstFlag` to `InferResult`, where
```
data InferInstFlag = IIF_Sigma | IIF_ShallowRho | IIF_DeepRho
```
* The flag says exactly how much `fillInferResult` should instantiate
before filling the hole.
* We can also use this to replace the previous very ad-hoc `tcInferSigma`
that was used to implement GHCi's `:type` command.
- - - - -
27206c5e by sheaf at 2025-08-29T17:28:14-04:00
Back-compat for TH SpecialiseP data-con of Pragma
This commit improves the backwards-compatibility story for the
SpecialiseP constructor of the Template Haskell 'Pragma' datatype.
Instead of keeping the constructor but deprecating it, this commit makes
it into a bundled pattern synonym of the Pragma datatype. We no longer
deprecate it; it's useful for handling old-form specialise pragmas.
- - - - -
26dbcf61 by fendor at 2025-08-30T05:10:08-04:00
Move stack decoding logic from ghc-heap to ghc-internal
The stack decoding logic in `ghc-heap` is more sophisticated than the one
currently employed in `CloneStack`. We want to use the stack decoding
implementation from `ghc-heap` in `base`.
We cannot simply depend on `ghc-heap` in `base` due do bootstrapping
issues.
Thus, we move the code that is necessary to implement stack decoding to
`ghc-internal`. This is the right location, as we don't want to add a
new API to `base`.
Moving the stack decoding logic and re-exposing it in ghc-heap is
insufficient, though, as we have a dependency cycle between.
* ghc-heap depends on stage1:ghc-internal
* stage0:ghc depends on stage0:ghc-heap
To fix this, we remove ghc-heap from the set of `stage0` dependencies.
This is not entirely straight-forward, as a couple of boot dependencies,
such as `ghci` depend on `ghc-heap`.
Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci`
to use `ghc-internal` instead of `ghc-heap`, which already exports the
relevant modules.
However, we cannot 100% remove ghc's dependency on `ghc-heap`, since
when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet
available.
Thus, when we compile with the boot-compiler, we still depend on an
older version of `ghc-heap`, and only use the modules from `ghc-internal`,
if the `ghc-internal` version is recent enough.
-------------------------
Metric Increase:
T24602_perf_size
T25046_perf_size_gzip
T25046_perf_size_unicode
T25046_perf_size_unicode_gzip
size_hello_artifact
size_hello_artifact_gzip
size_hello_unicode
size_hello_unicode_gzip
-------------------------
These metric increases are unfortunate, they are most likely caused by
the larger (literally in terms of lines of code) stack decoder implementation
that are now linked into hello-word binaries.
On linux, it is almost a 10% increase, which is considerable.
- - - - -
bd80bb70 by fendor at 2025-08-30T05:10:08-04:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
24441165 by fendor at 2025-08-30T05:10:08-04:00
Remove stg_decodeStackzh
- - - - -
fb9cc882 by Simon Peyton Jones at 2025-08-30T05:10:51-04:00
Fix a long standing bug in the coercion optimiser
We were mis-optimising ForAllCo, leading to #26345
Part of the poblem was the tricky tower of abstractions leading to
the dreadful
GHC.Core.TyCo.Subst.substForAllCoTyVarBndrUsing
This function was serving two masters: regular substitution, but also
coercion optimsation. So tricky was it that it did so wrong.
In this MR I locate all the fancy footwork for coercion optimisation
in GHC.Core.Coercion.Opt, where it belongs. That leaves substitution
free to be much simpler.
- - - - -
6c78de2d by Sylvain Henry at 2025-09-01T08:46:19-04:00
Driver: substitute virtual Prim module in --make mode too
When we build ghc-internal with --make (e.g. with cabal-install), we
need to be careful to substitute the virtual interface file for
GHC.Internal.Prim:
- after code generation (we generate code for an empty module, so we get
an empty interface)
- when we try to reload its .hi file
- - - - -
26e0db16 by fendor at 2025-09-01T08:47:01-04:00
Expose Stack Annotation frames in IPE backtraces by default
When decoding the Haskell-native call stack and displaying the IPE information
for the stack frames, we print the `StackAnnotation` of the `AnnFrame` by default.
This means, when an exception is thrown, any intermediate stack annotations will
be displayed in the `IPE Backtrace`.
Example backtrace:
```
Exception: ghc-internal:GHC.Internal.Exception.ErrorCall:
Oh no!
IPE backtrace:
annotateCallStackIO, called at app/Main.hs:48:10 in backtrace-0.1.0.0-inplace-server:Main
annotateCallStackIO, called at app/Main.hs:46:13 in backtrace-0.1.0.0-inplace-server:Main
Main.handler (app/Main.hs:(46,1)-(49,30))
Main.liftIO (src/Servant/Server/Internal/Handler.hs:30:36-42)
Servant.Server.Internal.Delayed.runHandler' (src/Servant/Server/Internal/Handler.hs:27:31-41)
Control.Monad.Trans.Resource.runResourceT (./Control/Monad/Trans/Resource.hs:(192,14)-(197,18))
Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:195:20-22)
Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:(195,5)-(203,31))
Network.Wai.Handler.Warp.HTTP1.http1server.loop (./Network/Wai/Handler/Warp/HTTP1.hs:(141,9)-(157,42))
HasCallStack backtrace:
error, called at app/Main.hs:48:32 in backtrace-0.1.0.0-inplace-server:Main
```
The first two entries have been added by `annotateCallStackIO`, defined in `annotateCallStackIO`.
- - - - -
a1567efd by Sylvain Henry at 2025-09-01T23:01:35-04:00
RTS: rely less on Hadrian for flag setting (#25843)
Hadrian used to pass -Dfoo command-line flags directly to build the rts.
We can replace most of these flags with CPP based on cabal flags.
It makes building boot libraries with cabal-install simpler (cf #25843).
- - - - -
ca5b0283 by Sergey Vinokurov at 2025-09-01T23:02:23-04:00
Remove unnecessary irrefutable patterns from Bifunctor instances for tuples
Implementation of https://github.com/haskell/core-libraries-committee/issues/339
Metric Decrease:
mhu-perf
- - - - -
2da84b7a by sheaf at 2025-09-01T23:03:23-04:00
Only use active rules when simplifying rule RHSs
When we are simplifying the RHS of a rule, we make sure to only apply
rewrites from rules that are active throughout the original rule's
range of active phases.
For example, if a rule is always active, we only fire rules that are
themselves always active when simplifying the RHS. Ditto for inline
activations.
This is achieved by setting the simplifier phase to a range of phases,
using the new SimplPhaseRange constructor. Then:
1. When simplifying the RHS of a rule, or of a stable unfolding,
we set the simplifier phase to a range of phases, computed from
the activation of the RULE/unfolding activation, using the
function 'phaseFromActivation'.
The details are explained in Note [What is active in the RHS of a RULE?]
in GHC.Core.Opt.Simplify.Utils.
2. The activation check for other rules and inlinings is then:
does the activation of the other rule/inlining cover the whole
phase range set in sm_phase? This continues to use the 'isActive'
function, which now accounts for phase ranges.
On the way, this commit also moves the exact-print SourceText annotation
from the Activation datatype to the ActivationAnn type. This keeps the
main Activation datatype free of any extra cruft.
Fixes #26323
- - - - -
79816cc4 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00
cleanup: Move dehydrateCgBreakInfo to Stg2Bc
This no longer has anything to do with Core.
- - - - -
53da94ff by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00
rts/Disassembler: Fix spacing of BRK_FUN
- - - - -
08c0cf85 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00
debugger: Fix bciPtr in Step-out
We need to use `BCO_NEXT` to move bciPtr to ix=1, because ix=0 points to
the instruction itself!
I do not understand how this didn't crash before.
- - - - -
e7e021fa by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00
debugger: Allow BRK_FUNs to head case continuation BCOs
When we start executing a BCO, we may want to yield to the scheduler:
this may be triggered by a heap/stack check, context switch, or a
breakpoint. To yield, we need to put the stack in a state such that
when execution is resumed we are back to where we yielded from.
Previously, a BKR_FUN could only head a function BCO because we only
knew how to construct a valid stack for yielding from one -- simply add
`apply_interp_info` + the BCO to resume executing. This is valid because
the stack at the start of run_BCO is headed by that BCO's arguments.
However, in case continuation BCOs (as per Note [Case continuation BCOs]),
we couldn't easily reconstruct a valid stack that could be resumed
because we dropped too soon the stack frames regarding the value
returned (stg_ret) and received (stg_ctoi) by that continuation.
This is especially tricky because of the variable type and size return
frames (e.g. pointer ret_p/ctoi_R1p vs a tuple ret_t/ctoi_t2).
The trick to being able to yield from a BRK_FUN at the start of a case
cont BCO is to stop removing the ret frame headers eagerly and instead
keep them until the BCO starts executing. The new layout at the start of
a case cont. BCO is described by the new Note [Stack layout when entering run_BCO].
Now, we keep the ret_* and ctoi_* frames when entering run_BCO.
A BRK_FUN is then executed if found, and the stack is yielded as-is with
the preserved ret and ctoi frames.
Then, a case cont BCO's instructions always SLIDE off the headers of the
ret and ctoi frames, in StgToByteCode.doCase, turning a stack like
| .... |
+---------------+
| fv2 |
+---------------+
| fv1 |
+---------------+
| BCO |
+---------------+
| stg_ctoi_ret_ |
+---------------+
| retval |
+---------------+
| stg_ret_..... |
+---------------+
into
| .... |
+---------------+
| fv2 |
+---------------+
| fv1 |
+---------------+
| retval |
+---------------+
for the remainder of the BCO.
Moreover, this more uniform approach of keeping the ret and ctoi frames
means we need less ad-hoc logic concerning the variable size of
ret_tuple vs ret_p/np frames in the code generator and interpreter:
Always keep the return to cont. stack intact at the start of run_BCO,
and the statically generated instructions will take care of adjusting
it.
Unlocks BRK_FUNs at the start of case cont. BCOs which will enable a
better user-facing step-out (#26042) which is free of the bugs the
current BRK_ALTS implementation suffers from (namely, using BRK_FUN
rather than BRK_ALTS in a case cont. means we'll never accidentally end
up in a breakpoint "deeper" than the continuation, because we stop at
the case cont itself rather than on the first breakpoint we evaluate
after it).
- - - - -
ade3c1e6 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00
BRK_FUN with InternalBreakLocs for code-generation time breakpoints
At the start of a case continuation BCO, place a BRK_FUN.
This BRK_FUN uses the new "internal breakpoint location" -- allowing us
to come up with a valid source location for this breakpoint that is not associated with a source-level tick.
For case continuation BCOs, we use the last tick seen before it as the
source location. The reasoning is described in Note [Debugger: Stepout internal break locs].
Note how T26042c, which was broken because it displayed the incorrect
behavior of the previous step out when we'd end up at a deeper level
than the one from which we initiated step-out, is now fixed.
As of this commit, BRK_ALTS is now dead code and is thus dropped.
Note [Debugger: Stepout internal break locs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Step-out tells the interpreter to run until the current function
returns to where it was called from, and stop there.
This is achieved by enabling the BRK_FUN found on the first RET_BCO
frame on the stack (See [Note Debugger: Step-out]).
Case continuation BCOs (which select an alternative branch) must
therefore be headed by a BRK_FUN. An example:
f x = case g x of <--- end up here
1 -> ...
2 -> ...
g y = ... <--- step out from here
- `g` will return a value to the case continuation BCO in `f`
- The case continuation BCO will receive the value returned from g
- Match on it and push the alternative continuation for that branch
- And then enter that alternative.
If we step-out of `g`, the first RET_BCO on the stack is the case
continuation of `f` -- execution should stop at its start, before
selecting an alternative. (One might ask, "why not enable the breakpoint
in the alternative instead?", because the alternative continuation is
only pushed to the stack *after* it is selected by the case cont. BCO)
However, the case cont. BCO is not associated with any source-level
tick, it is merely the glue code which selects alternatives which do
have source level ticks. Therefore, we have to come up at code
generation time with a breakpoint location ('InternalBreakLoc') to
display to the user when it is stopped there.
Our solution is to use the last tick seen just before reaching the case
continuation. This is robust because a case continuation will thus
always have a relevant breakpoint location:
- The source location will be the last source-relevant expression
executed before the continuation is pushed
- So the source location will point to the thing you've just stepped
out of
- Doing :step-local from there will put you on the selected
alternative (which at the source level may also be the e.g. next
line in a do-block)
Examples, using angle brackets (<<...>>) to denote the breakpoint span:
f x = case <<g x>> {- step in here -} of
1 -> ...
2 -> ...>
g y = <<...>> <--- step out from here
...
f x = <<case g x of <--- end up here, whole case highlighted
1 -> ...
2 -> ...>>
doing :step-local ...
f x = case g x of
1 -> <<...>> <--- stop in the alternative
2 -> ...
A second example based on T26042d2, where the source is a do-block IO
action, optimised to a chain of `case expressions`.
main = do
putStrLn "hello1"
<<f>> <--- step-in here
putStrLn "hello3"
putStrLn "hello4"
f = do
<<putStrLn "hello2.1">> <--- step-out from here
putStrLn "hello2.2"
...
main = do
putStrLn "hello1"
<<f>> <--- end up here again, the previously executed expression
putStrLn "hello3"
putStrLn "hello4"
doing step/step-local ...
main = do
putStrLn "hello1"
f
<<putStrLn "hello3">> <--- straight to the next line
putStrLn "hello4"
Finishes #26042
- - - - -
c66910c0 by Rodrigo Mesquita at 2025-09-02T12:19:59-04:00
debugger: Re-use the last BreakpointId whole in step-out
Previously, to come up with a location to stop at for `:stepout`, we
would store the location of the last BreakpointId surrounding the
continuation, as described by Note [Debugger: Stepout internal break locs].
However, re-using just the location from the last source breakpoint
isn't sufficient to provide the necessary information in the break
location. Specifically, it wouldn't bind any variables at that location.
Really, there is no reason not to re-use the last breakpoint wholesale,
and re-use all the information we had there. Step-out should behave just
as if we had stopped at the call, but s.t. continuing will not
re-execute the call.
This commit updates the CgBreakInfo to always store a BreakpointId, be
it the original one or the one we're emulating (for step-out).
It makes variable bindings on :stepout work
- - - - -
e4abed7b by sheaf at 2025-09-02T12:20:40-04:00
Revert accidental changes to hie.yaml
- - - - -
003b715b by meooow25 at 2025-09-02T23:48:51+02:00
Adjust the strictness of Data.List.iterate'
* Don't force the next element in advance when generating a (:).
* Force the first element to WHNF like every other element.
Now every element in the output list is forced to WHNF when the (:)
containing it is forced.
CLC proposal:
https://github.com/haskell/core-libraries-committee/issues/335
- - - - -
b2f6aad0 by Simon Hengel at 2025-09-03T04:36:10-04:00
Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg
- - - - -
60a16db7 by Rodrigo Mesquita at 2025-09-03T10:55:50+01:00
bytecode: Don't PUSH_L 0; SLIDE 1 1
While looking through bytecode I noticed a quite common unfortunate
pattern:
...
PUSH_L 0
SLIDE 1 1
We do this often by generically constructing a tail call from a function
atom that may be somewhere arbitrary on the stack.
However, for the special case that the function can be found directly on
top of the stack, as part of the arguments, it's plain redundant to push
then slide it.
In this commit we add a small optimisation to the generation of
tailcalls in bytecode. Simply: lookahead for the function in the stack.
If it is the first thing on the stack and it is part of the arguments
which would be dropped as we entered the tail call, then don't push then
slide it.
In a simple example (T26042b), this already produced a drastic
improvement in generated code (left is old, right is with this patch):
```diff
3c3
< 2025-07-29 10:14:02.081277 UTC
---
> 2025-07-29 10:50:36.560949 UTC
160,161c160
< PUSH_L 0
< SLIDE 1 2
---
> SLIDE 1 1
164,165d162
< PUSH_L 0
< SLIDE 1 1
175,176c172
< PUSH_L 0
< SLIDE 1 2
---
> SLIDE 1 1
179,180d174
< PUSH_L 0
< SLIDE 1 1
206,207d199
< PUSH_L 0
< SLIDE 1 1
210,211d201
< PUSH_L 0
< SLIDE 1 1
214,215d203
< PUSH_L 0
< SLIDE 1 1
218,219d205
< PUSH_L 0
< SLIDE 1 1
222,223d207
< PUSH_L 0
< SLIDE 1 1
...
600,601c566
< PUSH_L 0
< SLIDE 1 2
---
> SLIDE 1 1
604,605d568
< PUSH_L 0
< SLIDE 1 1
632,633d594
< PUSH_L 0
< SLIDE 1 1
636,637d596
< PUSH_L 0
< SLIDE 1 1
640,641d598
< PUSH_L 0
< SLIDE 1 1
644,645d600
< PUSH_L 0
< SLIDE 1 1
648,649d602
< PUSH_L 0
< SLIDE 1 1
652,653d604
< PUSH_L 0
< SLIDE 1 1
656,657d606
< PUSH_L 0
< SLIDE 1 1
660,661d608
< PUSH_L 0
< SLIDE 1 1
664,665d610
< PUSH_L 0
< SLIDE 1 1
```
I also compiled lib:Cabal to bytecode and counted the number of bytecode
lines with `find dist-newstyle -name "*.dump-BCOs" -exec wc {} +`:
with unoptimized core:
1190689 lines (before) - 1172891 lines (now)
= 17798 less redundant instructions (-1.5% lines)
with optimized core:
1924818 lines (before) - 1864836 lines (now)
= 59982 less redundant instructions (-3.1% lines)
- - - - -
8b2c72c0 by L0neGamer at 2025-09-04T06:32:03-04:00
Add Control.Monad.thenM and Control.Applicative.thenA
- - - - -
39e1b7cb by Teo Camarasu at 2025-09-04T06:32:46-04:00
ghc-internal: invert dependency of GHC.Internal.TH.Syntax on Data.Data
This means that Data.Data no longer blocks building TH.Syntax, which
allows greater parallelism in our builds.
We move the Data.Data.Data instances to Data.Data. Quasi depends on
Data.Data for one of its methods, so,
we split the Quasi/Q, etc definition out of GHC.Internal.TH.Syntax
into its own module. This has the added benefit of splitting up this
quite large module.
Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now
it is less of a bottle-neck and is also slightly quicker to
compile (since it no longer contains these instances) at the cost of
making Data.Data slightly more expensive to compile.
TH.Lift which depends on TH.Syntax can also compile quicker and no
longer blocks ghc-internal finishing to compile.
Resolves #26217
-------------------------
Metric Decrease:
MultiLayerModulesTH_OneShot
T13253
T21839c
T24471
Metric Increase:
T12227
-------------------------
- - - - -
bdf82fd2 by Teo Camarasu at 2025-09-04T06:32:46-04:00
compiler: delete unused names in Builtins.Names.TH
returnQ and bindQ are no longer used in the compiler.
There was also a very old comment that referred to them that I have modernized
- - - - -
5b6a9de3 by Teo Camarasu at 2025-09-04T12:17:37+00:00
base: don't expose GHC.Num.{BigNat, Integer, Natural}
WIP
- - - - -
244 changed files:
- .gitlab-ci.yml
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Core/Opt/Pipeline/Types.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser.y
- compiler/GHC/Plugins.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- configure.ac
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/separate_compilation.rst
- ghc/GHCi/UI.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- libraries/base/src/Control/Applicative.hs
- libraries/base/src/Control/Monad.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Bifunctor.hs
- libraries/base/src/Data/Fixed.hs
- libraries/base/src/GHC/Num.hs
- − libraries/base/src/GHC/Num/BigNat.hs
- − libraries/base/src/GHC/Num/Integer.hs
- − libraries/base/src/GHC/Num/Natural.hs
- libraries/base/src/GHC/Stack/CloneStack.hs
- libraries/base/src/System/CPUTime/Utils.hs
- libraries/ghc-bignum/ghc-bignum.cabal
- + libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-experimental/src/GHC/TypeNats/Experimental.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs
- + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- − libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout
- libraries/ghc-heap/cbits/HeapPrim.cmm → libraries/ghc-internal/cbits/HeapPrim.cmm
- libraries/ghc-heap/cbits/Stack.cmm → libraries/ghc-internal/cbits/Stack.cmm
- libraries/ghc-internal/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/cbits/Stack_c.c → libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- + libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghc-heap/tests/stack-annotation/Makefile → libraries/ghc-internal/tests/stack-annotation/Makefile
- libraries/ghc-heap/tests/stack-annotation/TestUtils.hs → libraries/ghc-internal/tests/stack-annotation/TestUtils.hs
- libraries/ghc-heap/tests/stack-annotation/all.T → libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs
- + libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- libraries/ghci/GHCi/TH.hs
- libraries/ghci/ghci.cabal.in
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- rts/CloneStack.c
- rts/CloneStack.h
- rts/Disassembler.c
- rts/Interpreter.c
- rts/PrimOps.cmm
- rts/Profiling.c
- rts/RaiseAsync.c
- rts/RtsMessages.c
- rts/RtsSymbols.c
- rts/RtsUtils.c
- rts/STM.c
- rts/Trace.c
- rts/include/rts/Bytecodes.h
- testsuite/.gitignore
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/deriving/should_compile/T14682.stderr
- testsuite/tests/deriving/should_compile/drv-empty-data.stderr
- + testsuite/tests/driver/make-prim/GHC/Internal/Prim.hs
- + testsuite/tests/driver/make-prim/Makefile
- + testsuite/tests/driver/make-prim/Test.hs
- + testsuite/tests/driver/make-prim/Test2.hs
- + testsuite/tests/driver/make-prim/all.T
- testsuite/tests/ghci.debugger/scripts/T26042b.script
- testsuite/tests/ghci.debugger/scripts/T26042b.stdout
- testsuite/tests/ghci.debugger/scripts/T26042c.script
- testsuite/tests/ghci.debugger/scripts/T26042c.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042d2.hs
- + testsuite/tests/ghci.debugger/scripts/T26042d2.script
- + testsuite/tests/ghci.debugger/scripts/T26042d2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042e.stdout
- testsuite/tests/ghci.debugger/scripts/T26042f.script
- testsuite/tests/ghci.debugger/scripts/T26042f1.stdout
- testsuite/tests/ghci.debugger/scripts/T26042f2.stdout
- testsuite/tests/ghci.debugger/scripts/T26042g.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- − testsuite/tests/lib/stm/T26028.hs
- − testsuite/tests/lib/stm/T26028.stdout
- − testsuite/tests/lib/stm/all.T
- + testsuite/tests/patsyn/should_compile/T26331.hs
- + testsuite/tests/patsyn/should_compile/T26331a.hs
- testsuite/tests/patsyn/should_compile/all.T
- testsuite/tests/perf/compiler/T4007.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/profiling/should_run/callstack001.stdout
- testsuite/tests/rts/all.T
- testsuite/tests/simplCore/should_compile/T15056.stderr
- testsuite/tests/simplCore/should_compile/T15445.stderr
- + testsuite/tests/simplCore/should_compile/T26323b.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplCore/should_run/T26323.hs
- + testsuite/tests/simplCore/should_run/T26323.stdout
- testsuite/tests/simplCore/should_run/all.T
- testsuite/tests/splice-imports/SI29.stderr
- testsuite/tests/th/Makefile
- testsuite/tests/th/T11452.stderr
- testsuite/tests/th/T15321.stderr
- testsuite/tests/th/T7276.stderr
- + testsuite/tests/th/TH_Depends_Dir.hs
- + testsuite/tests/th/TH_Depends_Dir.stdout
- + testsuite/tests/th/TH_Depends_Dir_External.hs
- testsuite/tests/th/TH_NestedSplicesFail3.stderr
- testsuite/tests/th/TH_NestedSplicesFail4.stderr
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_compile/T26345.hs
- + testsuite/tests/typecheck/should_compile/T26346.hs
- + testsuite/tests/typecheck/should_compile/T26350.hs
- + testsuite/tests/typecheck/should_compile/T26358.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T26318.hs
- + testsuite/tests/typecheck/should_fail/T26318.stderr
- testsuite/tests/typecheck/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/jsffi/dyld.mjs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0cbf4024a6bc059b8c917743dc036e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0cbf4024a6bc059b8c917743dc036e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26315 at Glasgow Haskell Compiler / GHC
Commits:
6a93a288 by Simon Peyton Jones at 2025-09-04T13:08:04+01:00
Wibbles
- - - - -
8 changed files:
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Solver/Solve.hs-boot
- compiler/GHC/Tc/Types/Evidence.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -741,7 +741,7 @@ Note that
the same (Eq p) dictionary. Reason: we don't want to force them to be visibly
equal at the call site.
-* The `spec_bnrs`, which are lambda-bound in the specialised function `$sf`,
+* The `spec_bndrs`, which are lambda-bound in the specialised function `$sf`,
are a subset of `rule_bndrs`.
spec_bndrs = @p (d2::Eq p) (x::Int) (y::p)
@@ -759,7 +759,8 @@ This is done in three parts.
(1) Typecheck the expression, capturing its constraints
- (2) Solve these constraints
+ (2) Solve these constraints. When doing so, switch on `tcsmFullySolveQCIs`;
+ see wrinkle (NFS1) below.
(3) Compute the constraints to quantify over, using `getRuleQuantCts` on
the unsolved constraints returned by (2).
@@ -795,6 +796,28 @@ This is done in three parts.
of the form:
forall @a @b d1 d2 d3. f d1 d2 d3 = $sf d1 d2 d3
+(NFS1) Consider
+ f :: forall f a. (Ix a, forall x. Eq x => Eq (f x)) => a -> f a
+ {-# SPECIALISE f :: forall f. (forall x. Eq x => Eq (f x)) => Int -> f Int #-}
+ This SPECIALISE is treated like an expression with a type signature, so
+ we instantiate the constraints, simplify them and re-generalise. From the
+ instantiation we get [W] d :: (forall x. Eq a => Eq (f x))
+ and we want to generalise over that. We do not want to attempt to solve it
+ and then get stuck, and emit an error message. If we can't solve it, it is
+ much, much better to leave it alone.
+
+ We still need to simplify quantified constraints that can be /fully solved/
+ from instances, otherwise we would never be able to specialise them
+ away. Example: {-# SPECIALISE f @[] @a #-}. So:
+
+ * The constraint solver has a mode flag `tcsmFullySolveQCIs` that says
+ "fully solve quantified constraint, or leave them alone
+ * When simplifying constraints in a SPECIALISE pragma, we switch on this
+ flag the `SpecPragE` case of `tcSpecPrag`.
+
+ You might worry about the wasted work from failed attempts to fully-solve, but
+ it is seldom repeated (because the constraint solver seldom iterates much).
+
Note [Handling old-form SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB: this code path is deprecated, and is scheduled to be removed in GHC 9.18, as per #25440.
@@ -976,12 +999,11 @@ tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl)
tcInferRho spec_e
-- (2) Solve the resulting wanteds
- -- When doing so, switch on `tcsmFullySolveQCIs`; see (WFA4) in
- -- Note [Solving a Wanted forall-constraint] in GHC.Tc.Solver.Solve
; ev_binds_var <- newTcEvBinds
; spec_e_wanted <- setTcLevel rhs_tclvl $
runTcSWithEvBinds ev_binds_var $
setTcSMode (vanillaTcSMode { tcsmFullySolveQCIs = True }) $
+ -- tcsmFullySolveQCIs: see (NFS1)a
solveWanteds spec_e_wanted
; spec_e_wanted <- liftZonkM $ zonkWC spec_e_wanted
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1028,15 +1028,15 @@ findInferredDiff annotated_theta inferred_theta
; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)
given_cts = mkGivens given_loc given_ids
- ; (residual, _) <- runTcS $
- do { _ <- solveSimpleGivens given_cts
- ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }
+ ; (residual_wc, _) <- runTcS $
+ do { _ <- solveSimpleGivens given_cts
+ ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }
-- NB: There are no meta tyvars fromn this level annotated_theta
-- because we have either promoted them or unified them
-- See `Note [Quantification and partial signatures]` Wrinkle 2
; return (map (box_pred . ctPred) $
- bagToList residual) }
+ bagToList (wc_simple residual_wc)) }
where
box_pred :: PredType -> PredType
box_pred pred = case classifyPredType pred of
=====================================
compiler/GHC/Tc/Solver/Default.hs
=====================================
@@ -1189,7 +1189,7 @@ tryDefaultGroup wanteds (Proposal assignments)
| CtWanted wtd <- map ctEvidence wanteds
]
; residual <- solveSimpleWanteds (listToBag new_wanteds)
- ; return $ if isEmptyBag residual then Just (tvs, subst) else Nothing }
+ ; return $ if isEmptyWC residual then Just (tvs, subst) else Nothing }
| otherwise
= return Nothing
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -834,7 +834,7 @@ tryShortCutSolver try_short_cut dict_w@(DictCt { di_ev = ev_w })
-> tryShortCutTcS $ -- tryTcS tries to completely solve some contraints
do { residual <- solveSimpleWanteds (unitBag (CDictCan dict_w))
- ; return (isEmptyBag residual) }
+ ; return (isEmptyWC residual) }
| otherwise
-> return False }
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -196,9 +196,11 @@ import GHC.Types.Unique.Set( elementOfUniqSet )
import GHC.Types.Id
import GHC.Types.Basic (allImportLevels)
import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel)
+import GHC.Types.SrcLoc
import GHC.Unit.Module
import qualified GHC.Rename.Env as TcM
+import GHC.Rename.Env
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -213,12 +215,11 @@ import GHC.Exts (oneShot)
import Control.Monad
import Data.Foldable hiding ( foldr1 )
import Data.IORef
+import Data.Maybe( catMaybes )
import Data.List ( mapAccumL )
import Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as S
-import GHC.Types.SrcLoc
-import GHC.Rename.Env
import GHC.LanguageExtensions as LangExt
#if defined(DEBUG)
@@ -920,11 +921,14 @@ vanillaTcSMode = TcSMode { tcsmPmCheck = False
instance Outputable TcSMode where
ppr (TcSMode { tcsmPmCheck = pm, tcsmEarlyAbort = ea
, tcsmSkipOverlappable = so, tcsmFullySolveQCIs = fs })
- = text "TcSMode" <> (braces $
- text "pm=" <> ppr pm <> comma <>
- text "ea=" <> ppr ea <> comma <>
- text "so=" <> ppr so <> comma <>
- text "fs=" <> ppr fs)
+ = text "TcSMode" <> (braces $ cat $ punctuate comma $ catMaybes $
+ [ pp_one pm "PmCheck", pp_one ea "EarlyAbort"
+ , pp_one so "SkipOverlappable", pp_one fs "FullySolveQCIs" ])
+ -- We get something like TcSMode{EarlyAbort,FullySolveQCIs},
+ -- mentioning just the flags that are on
+ where
+ pp_one True s = Just (text s)
+ pp_one False _ = Nothing
{- Note [TcSMode]
~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -119,22 +119,18 @@ simplify_loop n limit definitely_redo_implications
, int (lengthBag simples) <+> text "simples to solve" ])
; traceTcS "simplify_loop: wc =" (ppr wc)
- ; (unifs1, simples1) <- reportUnifications $ -- See Note [Superclass iteration]
- solveSimpleWanteds simples
+ ; (unifs1, wc1) <- reportUnifications $ -- See Note [Superclass iteration]
+ solveSimpleWanteds simples
-- Any insoluble constraints are in 'simples' and so get rewritten
-- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet
- -- Now try to solve any Wanted QCInsts in `simples1`
- ; (simples', implics_from_qcis) <- solveWantedQCIs simples1
-
-- Next, solve implications from wc_impl
; implics' <- if not definitely_redo_implications -- See Note [Superclass iteration]
&& unifs1 == 0 -- for this conditional
then return implics
else solveNestedImplications implics
- ; let wc' = wc { wc_simple = simples'
- , wc_impl = implics' `unionBags` implics_from_qcis }
+ ; let wc' = wc1 { wc_impl = wc_impl wc1 `unionBags` implics' }
; unif_happened <- resetUnificationFlag
; csTraceTcS $ text "unif_happened" <+> ppr unif_happened
@@ -1020,7 +1016,9 @@ solveSimpleGivens givens
; when (notNull new_givens) $
go new_givens }
-solveSimpleWanteds :: Cts -> TcS Cts
+solveSimpleWanteds :: Cts -> TcS WantedConstraints
+-- Returns unsolved constraints, mostly just flat ones (Cts),
+-- but also any unsolved implications arising from forall-constraints
-- The result is not necessarily zonked
solveSimpleWanteds simples
= do { mode <- getTcSMode
@@ -1032,43 +1030,59 @@ solveSimpleWanteds simples
, text "Inerts:" <+> ppr inerts
, text "Wanteds to solve:" <+> ppr simples ]
- ; (n,wc) <- go 1 (solverIterations dflags) simples
+ ; (n,simples',implics') <- go (solverIterations dflags) 1 emptyBag simples
+
+ ; let unsolved_wc = emptyWC { wc_simple = simples', wc_impl = implics' }
; traceTcS "solveSimpleWanteds end }" $
vcat [ text "iterations =" <+> ppr n
- , text "residual =" <+> ppr wc ]
- ; return wc }
+ , text "residual =" <+> ppr unsolved_wc ]
+
+ ; return unsolved_wc }
where
- go :: Int -> IntWithInf -> Cts -> TcS (Int, Cts)
+ go :: IntWithInf -- Limit
+ -> Int -- Iteration number
+ -> Bag Implication -- Accumulating parameter: unsolved implications
+ -> Cts -- Try to solve these
+ -> TcS (Int, Cts, Bag Implication)
-- See Note [The solveSimpleWanteds loop]
- go n limit wc
+ go limit n implics wanted
| n `intGtLimit` limit
= failTcS $ TcRnSimplifierTooManyIterations
- simples limit (emptyWC { wc_simple = wc })
- | isEmptyBag wc
- = return (n,wc)
+ simples limit
+ (emptyWC { wc_simple = wanted, wc_impl = implics })
+
+ | isEmptyBag wanted
+ = return (n, wanted, implics)
+
| otherwise
= do { -- Solve
- wc1 <- solve_simple_wanteds wc
+ (wanted1, implics1) <- solve_one wanted
+ ; let implics2 = implics `unionBags` implics1
-- Run plugins
- -- NB: runTcPluginsWanted has a fast path for empty wc1,
- -- which is the common case
- ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
+ -- NB: runTcPluginsWanted has a fast path for
+ -- empty wanted1, which is the common case
+ ; (rerun_plugin, wanted2) <- runTcPluginsWanted wanted1
; if rerun_plugin
then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)
- ; go (n+1) limit wc2 } -- Loop
- else return (n, wc2) } -- Done
+ ; go limit (n+1) implics2 wanted2 } -- Loop
+ else return (n, wanted2, implics2) } -- Done
-solve_simple_wanteds :: Cts -> TcS Cts
--- Try solving these constraints
--- Affects the unification state (of course) but not the inert set
--- The result is not necessarily zonked
-solve_simple_wanteds simples
- = nestTcS $ do { solveSimples simples
- ; getUnsolvedInerts }
+ solve_one :: Cts -> TcS (Cts, Bag Implication)
+ -- Try solving these constraints
+ -- Affects the unification state (of course) but not the inert set
+ -- The result is not necessarily zonked
+ solve_one simples
+ = nestTcS $
+ do { solveSimples simples
+ ; simples' <- getUnsolvedInerts
+ -- Now try to solve any Wanted quantified
+ -- constraints (i.e. QCInsts) in `simples1`
+ ; solveWantedQCIs simples' }
+
{- Note [The solveSimpleWanteds loop]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1320,25 +1334,24 @@ where <binds> is filled in by solving the implication constraint.
What we actually do is this:
* In `solveForAll` we see if we have an identical quantified constraint
- to solve it (using tryInertQCs), and then just add it to `inert_qcis :: [QCInst]`
- See Note [Solving Wanted QCs from Given QCs]
+ to solve it (using tryInertQCs). In particular, solve a Wanted QCI
+ from an identical Given. This is more than a simple optimisation:
+ see Note [Solving Wanted QCs from Given QCs]
-* In the main solver loop, `GHC.Tc.Solver.Solve.simplify_loop`:
+ If not, just stash it in `inert_qcis :: [QCInst]`. (If it's a Given
+ we can use it to solve other constraints; if a Wanted we will solve
+ it later using `solveWantedQCIs`.)
- - We attempt to solve the `wc_simple` constraints with `solveSimpleWanteds`
- Unsolved quantified constraints just accumulate in the `inert_qcis` field
- of the `InertSet`.
+* In the main `solveSimpleWanteds` (specifically `solve_one`):
- - Then we use `solveWantedQCIs` to solve any quantified constraints. It usually
- turns the `QCInst` into an `Implication`; but not invariably (WFA4)
+ - We attempt to solve the `wc_simple` constraints with `solveSimples`
+ Unsolved quantified constraints just accumulate in the `inert_qcis` field
+ of the `InertSet`.
-Wrinkles:
+ - Then we use `solveWantedQCIs` to solve any quantified constraints. That
+ often turns the `QCInst` into an `Implication`; but not invariably (WFA4)
-(WFA1) We can take a more straightforward path when there is a matching Given, e.g.
- [W] dg :: forall c d. (Eq c, Ord d) => C x c d
- In this case, it's better to directly solve the Wanted from the Given, instead
- of building an implication. This is more than a simple optimisation; see
- Note [Solving Wanted QCs from Given QCs].
+Wrinkles:
(WFA2) Termination: see #19690. We want to maintain the invariant (QC-INV):
@@ -1364,27 +1377,9 @@ Wrinkles:
So the `IsQC` origin carries that info, and `GHC.Tc.Errors.Ppr.pprQCOriginExtra`
prints the extra info.
-(WFA4) Consider
- f :: forall f a. (Ix a, forall x. Eq x => Eq (f x)) => a -> f a
- {-# SPECIALISE f :: forall f. (forall x. Eq x => Eq (f x)) => Int -> f Int #-}
- This SPECIALISE is treated like an expression with a type signature, so
- we instantiate the constraints, simplify them and re-generalise. From the
- instantiation we get [W] d :: (forall x. Eq a => Eq (f x))
- and we want to generalise over that. We do not want to attempt to solve it
- and then get stuck, and emit an error message. If we can't solve it, it is
- much, much better to leave it alone.
-
- We still need to simplify quantified constraints that can be /fully solved/
- from instances, otherwise we would never be able to specialise them
- away. Example: {-# SPECIALISE f @[] @a #-}. So:
-
- * The constraint solver has a mode flag `tcsmFullySolveQCIs` that says
- "fully solve quantified constraint, or leave them alone
- * When simplifying constraints in a SPECIALISE pragma, we switch on this
- flag (see `GHC.Tc.Gen.Sig.tcSpecPrag`, the `SpecSigE` case).
-
- You might worry about the wasted work from failed attempts to fully-solve, but
- it is seldom repeated (because the constraint solver seldom iterates much).
+(WFA4) When `tcsmFullySolveQCIs` is on, we adopt an all-or-nothing strategy:
+ either solve the forall-constraint /fully/ or do nothing at all.
+ Why? See (NFS1) in Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
(WFA5) Why not /always/ us the all-or-nothing strategy, so we don't need a
flag? Several reasons:
@@ -1579,7 +1574,7 @@ solveWantedQCI mode ct@(CQuantCan (QCI { qci_ev = ev, qci_tvs = tvs
return (Left ct)
| otherwise
- -> -- Commit to the (partuly or fully solved) implication
+ -> -- Commit to the (partly or fully solved) implication
-- See (WFA5) in Note [Solving a Wanted forall-constraint]
-- Record evidence and return residual implication
-- NB: even if it is fully solved we must return it, because it is
=====================================
compiler/GHC/Tc/Solver/Solve.hs-boot
=====================================
@@ -2,7 +2,7 @@ module GHC.Tc.Solver.Solve where
import Prelude( Bool )
import GHC.Tc.Solver.Monad( TcS )
-import GHC.Tc.Types.Constraint( Cts, Implication )
+import GHC.Tc.Types.Constraint( Cts, Implication, WantedConstraints )
-solveSimpleWanteds :: Cts -> TcS Cts
+solveSimpleWanteds :: Cts -> TcS WantedConstraints
trySolveImplication :: Implication -> TcS Bool
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -956,7 +956,14 @@ nestedEvIdsOfTerm tm = fvVarSet (filterFV isNestedEvId (evTermFVs tm))
evTermFVs :: EvTerm -> FV
evTermFVs (EvExpr e) = exprFVs e
evTermFVs (EvTypeable _ ev) = evFVsOfTypeable ev
-evTermFVs (EvFun {}) = emptyFV -- See Note [Free vars of EvFun]
+evTermFVs (EvFun { et_tvs = tvs, et_given = given
+ , et_binds = tc_ev_binds, et_body = v })
+ = case tc_ev_binds of
+ TcEvBinds {} -> emptyFV -- See Note [Free vars of EvFun]
+ EvBinds binds -> addBndrsFV bndrs fvs
+ where
+ fvs = foldr (unionFV . evTermFVs . eb_rhs) (unitFV v) binds
+ bndrs = foldr ((:) . eb_lhs) (tvs ++ given) binds
evTermFVss :: [EvTerm] -> FV
evTermFVss = mapUnionFV evTermFVs
@@ -975,12 +982,15 @@ Finding the free vars of an EvFun is made tricky by the fact the
bindings et_binds may be a mutable variable. Fortunately, we
can just squeeze by. Here's how.
-* evTermFVs is used only by GHC.Tc.Solver.neededEvVars.
-* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the
- ic_binds field of an Implication
-* So we can track usage via the processing for that implication,
- (see Note [Tracking redundant constraints] in GHC.Tc.Solver).
- We can ignore usage from the EvFun altogether.
+* /During/ typechecking, `evTermFVs` is used only by `GHC.Tc.Solver.neededEvVars`
+ * Each EvBindsVar in an et_binds field of an EvFun is /also/ in the
+ ic_binds field of an Implication
+ * So we can track usage via the processing for that implication,
+ (see Note [Tracking redundant constraints] in GHC.Tc.Solver).
+ We can ignore usage from the EvFun altogether.
+
+* /After/ typechecking `evTermFVs` is used by `GHC.Iface.Ext.Ast`, but by
+ then it has been zonked so we can get at the bindings.
-}
{- *********************************************************************
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a93a2883a2fba1653de0ea71ea57c6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a93a2883a2fba1653de0ea71ea57c6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26369 at Glasgow Haskell Compiler / GHC
Commits:
2897da11 by Simon Peyton Jones at 2025-09-04T12:58:10+01:00
Refactor ForAllCo
This is a pure refactor, addressing #26389.
It arranges that the kind coercion in a ForAllCo is a MCoercion, rather
than a plain Coercion, thus removing redundancy in the common case.
See (FC8) in Note [ForAllCo]
It's a nice cleanup.
- - - - -
22 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion.hs-boot
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Reduction.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -47,7 +47,7 @@ module GHC.Core.Coercion (
mkProofIrrelCo,
downgradeRole,
mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,
- mkKindCo,
+ mkKindCo, forAllCoKindCo,
castCoercionKind, castCoercionKind1, castCoercionKind2,
-- ** Decomposition
@@ -66,11 +66,14 @@ module GHC.Core.Coercion (
tyConRoleListX, tyConRoleListRepresentational, funRole,
pickLR,
- isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
- isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,
+ isReflKindCo,isReflKindMCo,
+ isReflCo, isReflCo_maybe,
+ isReflexiveMCo, isReflexiveCo, isReflexiveCo_maybe,
+ isReflCoVar_maybe, mkGReflLeftMCo, mkGReflRightMCo,
mkCoherenceRightMCo,
- coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,
+ coToMCo, kindCoToMKindCo,
+ mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,
mkFunResMCo, mkPiMCos,
isReflMCo, checkReflexiveMCo,
@@ -85,7 +88,7 @@ module GHC.Core.Coercion (
-- ** Substitution
CvSubstEnv, emptyCvSubstEnv,
lookupCoVar,
- substCo, substCos, substCoVar, substCoVars, substCoWith,
+ substCo, substCos, substCoVar, substCoVars, substCoWithInScope,
substCoVarBndr,
extendTvSubstAndInScope, getCvSubstEnv,
@@ -317,23 +320,23 @@ coToMCo :: Coercion -> MCoercion
coToMCo co | isReflCo co = MRefl
| otherwise = MCo co
+kindCoToMKindCo :: KindCoercion -> KindMCoercion
+-- Convert a KindCoercion to a KindMCoercion,
+-- coToMCo doesn't eliminate GRefl, but kindCoToMCo can
+-- See Note [KindCoercion]
+kindCoToMKindCo co | isReflKindCo co = MRefl
+ | otherwise = MCo co
+
checkReflexiveMCo :: MCoercion -> MCoercion
checkReflexiveMCo MRefl = MRefl
checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl
| otherwise = MCo co
--- | Tests if this MCoercion is obviously generalized reflexive
--- Guaranteed to work very quickly.
-isGReflMCo :: MCoercion -> Bool
-isGReflMCo MRefl = True
-isGReflMCo (MCo co) | isGReflCo co = True
-isGReflMCo _ = False
-
-- | Make a generalized reflexive coercion
mkGReflCo :: Role -> Type -> MCoercionN -> Coercion
mkGReflCo r ty mco
- | isGReflMCo mco = if r == Nominal then Refl ty
- else GRefl r ty MRefl
+ | isReflKindMCo mco = if r == Nominal then Refl ty
+ else GRefl r ty MRefl
| otherwise
= -- I'd like to have this assert, but sadly it's not true during type
-- inference because the types are not fully zonked
@@ -565,10 +568,13 @@ splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res)
splitFunCo_maybe _ = Nothing
-splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
+splitForAllCo_maybe :: Coercion
+ -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
+-- You might think that this function should return KindMCoercion (rather
+-- than a KindCoercion), but in fact most of the clients want a KindCoercion.
splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR
- , fco_kind = k_co, fco_body = co })
- = Just (tv, vL, vR, k_co, co)
+ , fco_kind = k_mco, fco_body = co })
+ = Just (tv, vL, vR, forAllCoKindCo tv k_mco, co)
splitForAllCo_maybe co
| Just (ty, r) <- isReflCo_maybe co
, Just (Bndr tcv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty
@@ -576,7 +582,8 @@ splitForAllCo_maybe co
splitForAllCo_maybe _ = Nothing
-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder
-splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
+splitForAllCo_ty_maybe :: Coercion
+ -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
splitForAllCo_ty_maybe co
| Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co
, isTyVar tv
@@ -584,7 +591,8 @@ splitForAllCo_ty_maybe co
splitForAllCo_ty_maybe _ = Nothing
-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder
-splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
+splitForAllCo_co_maybe :: Coercion
+ -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
splitForAllCo_co_maybe co
| Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co
, isCoVar cv
@@ -676,34 +684,50 @@ isReflCoVar_maybe cv
| otherwise
= Nothing
--- | Tests if this coercion is obviously a generalized reflexive coercion.
+-- | Tests whether this is a "kind coercion":
+-- that is, Nominal and between two types of kind @Type@.
+-- See Note [KindCoercion] in GHC.Core.TyCo.Rep
+isKindCo :: Coercion -> Bool
+isKindCo co
+ = role == Nominal && isLiftedTypeKind kk1 && isLiftedTypeKind kk2
+ where
+ (Pair kk1 kk2, role) = coercionKindRole co
+
+-- | Tests if this /kind/ coercion is Refl
+-- Guaranteed to work very quickly.
+-- PRECONDITION: the argument is a KindCoercion
+-- So if it sees (GRefl k (MCo kk)) :: k ~ (k |> kk)
+-- then we know that kk must be reflexive.
+-- And hence if co = GRefl {} then it is equivalent to Refl,
+-- because GRefl N ty MRefl = Refl ty
+-- so we return True
+-- See Note [KindCoercion] in GHC.Core.TyCo.Rep
+isReflKindCo :: HasDebugCallStack => KindCoercion -> Bool
+isReflKindCo co@(GRefl {}) = assertPpr (isKindCo co) (ppr co) $
+ True
+isReflKindCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl
+isReflKindCo _ = False
+
+-- | Tests if this /kind/ MCoercion is obviously generalized reflexive
-- Guaranteed to work very quickly.
-isGReflCo :: Coercion -> Bool
-isGReflCo (GRefl{}) = True
-isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl
-isGReflCo _ = False
+isReflKindMCo :: KindMCoercion -> Bool
+isReflKindMCo MRefl = True
+isReflKindMCo (MCo co) = isReflKindCo co
-- | Tests if this coercion is obviously reflexive. Guaranteed to work
-- very quickly. Sometimes a coercion can be reflexive, but not obviously
-- so. c.f. 'isReflexiveCo'
isReflCo :: Coercion -> Bool
isReflCo (Refl{}) = True
-isReflCo (GRefl _ _ mco) | isGReflMCo mco = True
+isReflCo (GRefl _ _ mco) | isReflKindMCo mco = True
isReflCo _ = False
--- | Returns the type coerced if this coercion is a generalized reflexive
--- coercion. Guaranteed to work very quickly.
-isGReflCo_maybe :: Coercion -> Maybe (Type, Role)
-isGReflCo_maybe (GRefl r ty _) = Just (ty, r)
-isGReflCo_maybe (Refl ty) = Just (ty, Nominal)
-isGReflCo_maybe _ = Nothing
-
-- | Returns the type coerced if this coercion is reflexive. Guaranteed
-- to work very quickly. Sometimes a coercion can be reflexive, but not
-- obviously so. c.f. 'isReflexiveCo_maybe'
isReflCo_maybe :: Coercion -> Maybe (Type, Role)
isReflCo_maybe (Refl ty) = Just (ty, Nominal)
-isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
+isReflCo_maybe (GRefl r ty mco) | isReflKindMCo mco = Just (ty, r)
isReflCo_maybe _ = Nothing
-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,
@@ -711,11 +735,15 @@ isReflCo_maybe _ = Nothing
isReflexiveCo :: Coercion -> Bool
isReflexiveCo = isJust . isReflexiveCo_maybe
+isReflexiveMCo :: MCoercion -> Bool
+isReflexiveMCo MRefl = True
+isReflexiveMCo (MCo co) = isReflexiveCo co
+
-- | Extracts the coerced type from a reflexive coercion. This potentially
-- walks over the entire coercion, so avoid doing this in a loop.
isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)
isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)
-isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
+isReflexiveCo_maybe (GRefl r ty mco) | isReflKindMCo mco = Just (ty, r)
isReflexiveCo_maybe co
| ty1 `eqType` ty2
= Just (ty1, r)
@@ -723,6 +751,10 @@ isReflexiveCo_maybe co
= Nothing
where (Pair ty1 ty2, r) = coercionKindRole co
+forAllCoKindCo :: TyCoVar -> KindMCoercion -> KindCoercion
+-- Get the kind coercion from a ForAllCo
+forAllCoKindCo _ (MCo co) = co
+forAllCoKindCo tcv MRefl = mkNomReflCo (varType tcv)
{-
%************************************************************************
@@ -939,10 +971,11 @@ mkAppCos co1 cos = foldl' mkAppCo co1 cos
-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.
-mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion
+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag
+ -> KindMCoercion -> Coercion -> Coercion
mkForAllCo v visL visR kind_co co
| Just (ty, r) <- isReflCo_maybe co
- , isReflCo kind_co
+ , isReflMCo kind_co
, visL `eqForAllVis` visR
= mkReflCo r (mkTyCoForAllTy v visL ty)
@@ -955,8 +988,7 @@ mkForAllCo v visL visR kind_co co
mkForAllVisCos :: HasDebugCallStack => [ForAllTyBinder] -> Coercion -> Coercion
mkForAllVisCos bndrs orig_co = foldr go orig_co bndrs
where
- go (Bndr tv vis)
- = mkForAllCo tv coreTyLamForAllTyFlag vis (mkNomReflCo (varType tv))
+ go (Bndr tv vis) = mkForAllCo tv coreTyLamForAllTyFlag vis MRefl
-- | Make a Coercion quantified over a type/coercion variable;
-- the variable has the same kind and visibility in both sides of the coercion
@@ -967,29 +999,30 @@ mkHomoForAllCos vs orig_co
| otherwise
= foldr go orig_co vs
where
- go (Bndr var vis) co
- = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co
+ go :: ForAllTyBinder -> Coercion -> Coercion
+ go (Bndr var vis) = mkForAllCo_NoRefl var vis vis MRefl
-- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl;
-- the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.)
-- The kind of the tycovar should be the left-hand kind of the kind coercion.
-mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion
+mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag
+ -> KindMCoercion -> Coercion -> Coercion
mkForAllCo_NoRefl tcv visL visR kind_co co
= assertGoodForAllCo tcv visL visR kind_co co $
- assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $
+ assertPpr (not (isReflCo co && isReflMCo kind_co && visL == visR)) (ppr co) $
ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
, fco_kind = kind_co, fco_body = co }
assertGoodForAllCo :: HasDebugCallStack
- => TyCoVar -> ForAllTyFlag -> ForAllTyFlag
- -> CoercionN -> Coercion -> a -> a
+ => TyCoVar -> ForAllTyFlag -> ForAllTyFlag
+ -> KindMCoercion -> Coercion -> a -> a
-- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep
assertGoodForAllCo tcv visL visR kind_co co
| isTyVar tcv
- = assertPpr (tcv_type `eqType` kind_co_lkind) doc
+ = assertPpr tcv_kind_co_agree doc
| otherwise
- = assertPpr (tcv_type `eqType` kind_co_lkind) doc
+ = assertPpr tcv_kind_co_agree doc
-- The kind of the tycovar should be the left-hand kind of the kind coercion.
. assertPpr (almostDevoidCoVarOfCo tcv co) doc
-- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep
@@ -998,13 +1031,17 @@ assertGoodForAllCo tcv visL visR kind_co co
-- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep
where
tcv_type = varType tcv
- kind_co_lkind = coercionLKind kind_co
+ tcv_kind_co_agree = case kind_co of
+ MRefl -> True
+ MCo co -> tcv_type `eqType` coercionLKind co
doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type
, text "Vis:" <+> ppr visL <+> ppr visR
- , text "kind_co:" <+> ppr kind_co
- , text "kind_co_lkind" <+> ppr kind_co_lkind
+ , text "kind_co:" <+> pp_kind_co
, text "body_co" <+> ppr co ]
+ pp_kind_co = case kind_co of
+ MRefl -> text "MRefl"
+ MCo co -> ppr co <+> dcolon <+> ppr (coercionKind co)
mkNakedForAllCo :: TyVar -- Never a CoVar
@@ -1024,7 +1061,7 @@ mkNakedForAllCo tv visL visR kind_co co
= mkReflCo r (mkForAllTy (Bndr tv visL) ty)
| otherwise
= ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
- , fco_kind = kind_co, fco_body = co }
+ , fco_kind = MCo kind_co, fco_body = co }
mkCoVarCo :: CoVar -> Coercion
@@ -1149,7 +1186,7 @@ mkSymCo co | isReflCo co = co
mkSymCo (SymCo co) = co
mkSymCo (SubCo (SymCo co)) = SubCo co
mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co })
- | isReflCo kco = co { fco_body = mkSymCo body_co }
+ | isReflMCo kco = co { fco_body = mkSymCo body_co }
mkSymCo co = SymCo co
-- | mkTransCo creates a new 'Coercion' by composing the two
@@ -1193,8 +1230,8 @@ mkSelCo_maybe cs co
go cs co
where
- go SelForAll (ForAllCo { fco_kind = kind_co })
- = Just kind_co
+ go SelForAll (ForAllCo { fco_tcv = tcv, fco_kind = kind_co })
+ = Just (forAllCoKindCo tcv kind_co)
-- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)
-- then (nth SelForAll co :: k1 ~N k2)
-- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)
@@ -1312,46 +1349,45 @@ mkInstCo :: Coercion -> CoercionN -> Coercion
mkInstCo co_fun co_arg
| Just (tcv, _, _, kind_co, body_co) <- splitForAllCo_maybe co_fun
, Just (arg, _) <- isReflCo_maybe co_arg
+ , let in_scope = mkInScopeSet $
+ tyCoVarsOfType arg `unionVarSet` tyCoVarsOfCo body_co
+ subst = extendTCvSubst (mkEmptySubst in_scope) tcv arg
= assertPpr (isReflexiveCo kind_co) (ppr co_fun $$ ppr co_arg) $
-- If the arg is Refl, then kind_co must be reflexive too
- substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co
+ substCo subst body_co
mkInstCo co arg = InstCo co arg
-- | Given @ty :: k1@, @co :: k1 ~ k2@,
-- produces @co' :: ty ~r (ty |> co)@
-mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion
+mkGReflRightCo :: Role -> Type -> KindCoercion -> Coercion
mkGReflRightCo r ty co
- | isGReflCo co = mkReflCo r ty
- -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
- -- instead of @isReflCo@
- | otherwise = mkGReflMCo r ty co
+ | isReflKindCo co = mkReflCo r ty -- Homo (tested) AND nominal (I promise) => Refl
+ | otherwise = mkGReflMCo r ty co
-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@,
-- produces @co' :: (ty |> co) ~r ty@
-mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion
+mkGReflLeftCo :: Role -> Type -> KindCoercion -> Coercion
mkGReflLeftCo r ty co
- | isGReflCo co = mkReflCo r ty
- -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
- -- instead of @isReflCo@
- | otherwise = mkSymCo $ mkGReflMCo r ty co
+ | isReflKindCo co = mkReflCo r ty
+ | otherwise = mkSymCo $ mkGReflMCo r ty co
-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,
-- produces @co' :: (ty |> co) ~r ty'
-- It is not only a utility function, but it saves allocation when co
-- is a GRefl coercion.
-mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
+mkCoherenceLeftCo :: Role -> Type -> KindCoercion -> Coercion -> Coercion
mkCoherenceLeftCo r ty co co2
- | isGReflCo co = co2
- | otherwise = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2
+ | isReflKindCo co = co2
+ | otherwise = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2
-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,
-- produces @co' :: ty' ~r (ty |> co)
-- It is not only a utility function, but it saves allocation when co
-- is a GRefl coercion.
-mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion
+mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> KindCoercion -> Coercion -> Coercion
mkCoherenceRightCo r ty co co2
- | isGReflCo co = co2
- | otherwise = co2 `mkTransCo` mkGReflMCo r ty co
+ | isReflKindCo co = co2
+ | otherwise = co2 `mkTransCo` mkGReflMCo r ty co
-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.
mkKindCo :: Coercion -> Coercion
@@ -1411,18 +1447,19 @@ downgradeRole r1 r2 co
Nothing -> pprPanic "downgradeRole" (ppr co)
-- | Make a "coercion between coercions".
-mkProofIrrelCo :: Role -- ^ role of the created coercion, "r"
- -> CoercionN -- ^ :: phi1 ~N phi2
- -> Coercion -- ^ g1 :: phi1
- -> Coercion -- ^ g2 :: phi2
- -> Coercion -- ^ :: g1 ~r g2
+mkProofIrrelCo :: Role -- ^ role of the created coercion, "r"
+ -> KindCoercion -- ^ :: phi1 ~N phi2
+ -> Coercion -- ^ g1 :: phi1
+ -> Coercion -- ^ g2 :: phi2
+ -> Coercion -- ^ :: g1 ~r g2
-- if the two coercion prove the same fact, I just don't care what
-- the individual coercions are.
-mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g)
- -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@
-mkProofIrrelCo r kco g1 g2 = mkUnivCo ProofIrrelProv [kco] r
- (mkCoercionTy g1) (mkCoercionTy g2)
+mkProofIrrelCo r kco g1 g2
+ | isReflKindCo kco = mkReflCo r (mkCoercionTy g1)
+ -- kco is a kind coercion, thus @isReflKindCo@ rather than @isReflCo@
+ | otherwise = mkUnivCo ProofIrrelProv [kco] r
+ (mkCoercionTy g1) (mkCoercionTy g2)
{-
%************************************************************************
@@ -2165,16 +2202,17 @@ ty_co_subst !lc role ty
go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)
go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2)
go r t@(ForAllTy (Bndr v vis) ty)
- = let (lc', v', h) = liftCoSubstVarBndr lc v
- body_co = ty_co_subst lc' r ty in
- if isTyVar v' || almostDevoidCoVarOfCo v' body_co
+ = let (lc', v', k_co) = liftCoSubstVarBndr lc v
+ body_co = ty_co_subst lc' r ty
+ k_mco = kindCoToMKindCo k_co
+ in if isTyVar v' || almostDevoidCoVarOfCo v' body_co
-- Lifting a ForAllTy over a coercion variable could fail as ForAllCo
-- imposes an extra restriction on where a covar can appear. See
-- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep
-- We specifically check for this and panic because we know that
-- there's a hole in the type system here (see (FC6), and we'd rather
-- panic than fall into it.
- then mkForAllCo v' vis vis h body_co
+ then mkForAllCo v' vis vis k_mco body_co
else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)
go r ty@(LitTy {}) = assert (r == Nominal) $
mkNomReflCo ty
@@ -2262,6 +2300,7 @@ liftCoSubstVarBndr :: LiftingContext -> TyCoVar
liftCoSubstVarBndr lc tv
= liftCoSubstVarBndrUsing id callback lc tv
where
+ callback :: LiftingContext -> Type -> Coercion
callback lc' ty' = ty_co_subst lc' Nominal ty'
-- the callback must produce a nominal coercion
@@ -2424,7 +2463,7 @@ seqCo (SubCo co) = seqCo co
seqCo (AxiomCo _ cs) = seqCos cs
seqCo (ForAllCo tv visL visR k co)
= seqType (varType tv) `seq` rnf visL `seq` rnf visR `seq`
- seqCo k `seq` seqCo co
+ seqMCo k `seq` seqCo co
seqCo (FunCo r af1 af2 w co1 co2)
= r `seq` af1 `seq` af2 `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2
seqCo (UnivCo { uco_prov = p, uco_role = r
@@ -2522,7 +2561,7 @@ coercion_lr_kind which orig_co
, fco_kind = k_co, fco_body = co1 })
= case which of
CLeft -> mkTyCoForAllTy tv1 visL (go co1)
- CRight | isGReflCo k_co -- kind_co always has kind `Type`, thus `isGReflCo`
+ CRight | isReflKindMCo k_co
-> mkTyCoForAllTy tv1 visR (go co1)
| otherwise
-> go_forall_right empty_subst co
@@ -2577,43 +2616,47 @@ coercion_lr_kind which orig_co
-------------
go_forall_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR
- , fco_kind = k_co, fco_body = co })
+ , fco_kind = k_mco, fco_body = co })
-- See Note [Nested ForAllCos]
| isTyVar tv1
- = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co)
- where
- k2 = coercionRKind k_co
- tv2 = setTyVarKind tv1 (substTy subst k2)
- subst' | isGReflCo k_co = extendSubstInScope subst tv1
- -- kind_co always has kind @Type@, thus @isGReflCo@
- | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $
- TyVarTy tv2 `mkCastTy` mkSymCo k_co
+ = case k_mco of
+ MRefl -> mkForAllTy (Bndr tv1 visR) (go_forall_right subst' co)
+ where
+ subst' = extendSubstInScope subst tv1
+ MCo k_co -> mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co)
+ where
+ k2 = coercionRKind k_co
+ tv2 = setTyVarKind tv1 (substTy subst k2)
+ subst' = extendTvSubst (extendSubstInScope subst tv2) tv1 $
+ TyVarTy tv2 `mkCastTy` mkSymCo k_co
go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR
- , fco_kind = k_co, fco_body = co })
+ , fco_kind = k_mco, fco_body = co })
| isCoVar cv1
- = mkTyCoForAllTy cv2 visR (go_forall_right subst' co)
- where
- k2 = coercionRKind k_co
- r = coVarRole cv1
- k_co' = downgradeRole r Nominal k_co
- eta1 = mkSelCo (SelTyCon 2 r) k_co'
- eta2 = mkSelCo (SelTyCon 3 r) k_co'
-
- -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)
- -- k1 = t1 ~r t2
- -- k2 = s1 ~r s2
- -- cv1 :: t1 ~r t2
- -- cv2 :: s1 ~r s2
- -- eta1 :: t1 ~r s1
- -- eta2 :: t2 ~r s2
- -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2
-
- cv2 = setVarType cv1 (substTy subst k2)
- n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)
- subst' | isReflCo k_co = extendSubstInScope subst cv1
- | otherwise = extendCvSubst (extendSubstInScope subst cv2)
- cv1 n_subst
+ = case k_mco of
+ MRefl -> mkTyCoForAllTy cv1 visR (go_forall_right subst' co)
+ where
+ subst' = extendSubstInScope subst cv1
+ MCo k_co -> mkTyCoForAllTy cv2 visR (go_forall_right subst' co)
+ where
+ k2 = coercionRKind k_co
+ r = coVarRole cv1
+ k_co' = downgradeRole r Nominal k_co
+ eta1 = mkSelCo (SelTyCon 2 r) k_co'
+ eta2 = mkSelCo (SelTyCon 3 r) k_co'
+
+ -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)
+ -- k1 = t1 ~r t2
+ -- k2 = s1 ~r s2
+ -- cv1 :: t1 ~r t2
+ -- cv2 :: s1 ~r s2
+ -- eta1 :: t1 ~r s1
+ -- eta2 :: t2 ~r s2
+ -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2
+
+ cv2 = setVarType cv1 (substTy subst k2)
+ n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)
+ subst' = extendCvSubst (extendSubstInScope subst cv2) cv1 n_subst
go_forall_right subst other_co
-- when other_co is not a ForAllCo
@@ -2729,7 +2772,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2)
| isTyVar tv1
= assert (isTyVar tv2) $
- mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2')
+ mkForAllCo tv1 flag1 flag2 (kindCoToMKindCo kind_co) (go ty1 ty2')
where kind_co = go (tyVarKind tv1) (tyVarKind tv2)
in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
ty2' = substTyWithInScope in_scope [tv2]
@@ -2738,7 +2781,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2)
= assert (isCoVar cv1 && isCoVar cv2) $
- mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2')
+ mkForAllCo cv1 flag1 flag2 (kindCoToMKindCo kind_co) (go ty1 ty2')
where s1 = varType cv1
s2 = varType cv2
kind_co = go s1 s2
@@ -2755,7 +2798,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
eta2 = mkSelCo (SelTyCon 3 r) kind_co'
subst = mkEmptySubst $ mkInScopeSet $
- tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
+ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`
mkCoVarCo cv1 `mkTransCo`
eta2)
=====================================
compiler/GHC/Core/Coercion.hs-boot
=====================================
@@ -16,7 +16,7 @@ import GHC.Utils.Misc
mkReflCo :: Role -> Type -> Coercion
mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
mkAppCo :: Coercion -> Coercion -> Coercion
-mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion
+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> MCoercion -> Coercion -> Coercion
mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion
mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion
mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion
@@ -37,7 +37,6 @@ mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion
funRole :: Role -> FunSel -> Role
-isGReflCo :: Coercion -> Bool
isReflCo :: Coercion -> Bool
isReflexiveCo :: Coercion -> Bool
decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -177,12 +177,12 @@ optCoercion opts env co
= optCoercion' env co
{-
- = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $
+ = pprTrace "optCoercion {" (text "Co:" <> ppr co) $
let result = optCoercion' env co in
pprTrace "optCoercion }"
(vcat [ text "Co:" <+> ppr (coercionSize co)
, text "Optco:" <+> ppWhen (isReflCo result) (text "(refl)")
- <+> ppr (coercionSize result) ]) $
+ <+> ppr result ]) $
result
-}
@@ -317,7 +317,7 @@ opt_co4' env sym rep r (GRefl _r ty (MCo kco))
(text "Expected role:" <+> ppr r $$
text "Found role:" <+> ppr _r $$
text "Type:" <+> ppr ty) $
- if isGReflCo kco || isGReflCo kco'
+ if isReflKindCo kco || isReflKindCo kco'
then wrapSym sym ty_co
else wrapSym sym $ mk_coherence_right_co r' (coercionRKind ty_co) kco' ty_co
-- ty :: k1
@@ -841,55 +841,58 @@ opt_trans_rule is co1 co2@(AppCo co2a co2b)
-- Push transitivity inside forall
-- forall over types.
opt_trans_rule is co1 co2
- | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1
- , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2
- = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2
+ | Just (tv1, visL1, _visR1, kco1, r1) <- splitForAllCo_ty_maybe co1
+ , Just (tv2, _visL2, visR2, kco2, r2) <- etaForAllCo_ty_maybe co2
+ = push_trans tv1 kco1 r1 tv2 kco2 r2 visL1 visR2
- | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2
- , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1
- = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2
+ | Just (tv2, _visL2, visR2, kco2, r2) <- splitForAllCo_ty_maybe co2
+ , Just (tv1, visL1, _visR1, kco1, r1) <- etaForAllCo_ty_maybe co1
+ = push_trans tv1 kco1 r1 tv2 kco2 r2 visL1 visR2
where
- push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR
+ push_trans tv1 kco1 r1 tv2 kco2 r2 visL visR
-- Given:
- -- co1 = /\ tv1 : eta1 <visL, visM>. r1
- -- co2 = /\ tv2 : eta2 <visM, visR>. r2
+ -- co1 = /\ tv1 : kco1 <visL, visM>. r1
+ -- co2 = /\ tv2 : kco2 <visM, visR>. r2
-- Wanted:
- -- /\tv1 : (eta1;eta2) <visL, visR>. (r1; r2[tv2 |-> tv1 |> eta1])
+ -- /\tv1 : (kco1;kco2) <visL, visR>. (r1; r2[tv2 |-> tv1 |> kco1])
= fireTransRule "EtaAllTy_ty" co1 co2 $
- mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')
+ mkForAllCo tv1 visL visR
+ (kindCoToMKindCo (opt_trans is kco1 kco2))
+ (opt_trans is' r1 r2')
where
is' = is `extendInScopeSet` tv1
- r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2
+ r2' = substCoWithInScope is' [tv2] [mkCastTy (TyVarTy tv1) kco1] r2
-- Push transitivity inside forall
-- forall over coercions.
opt_trans_rule is co1 co2
- | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1
- , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2
- = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2
+ | Just (cv1, visL1, _visR1, kco1, r1) <- splitForAllCo_co_maybe co1
+ , Just (cv2, _visL2, visR2, kco2, r2) <- etaForAllCo_co_maybe co2
+ = push_trans cv1 kco1 r1 cv2 kco2 r2 visL1 visR2
- | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2
- , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1
- = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2
+ | Just (cv2, _visL2, visR2, kco2, r2) <- splitForAllCo_co_maybe co2
+ , Just (cv1, visL1, _visR1, kco1, r1) <- etaForAllCo_co_maybe co1
+ = push_trans cv1 kco1 r1 cv2 kco2 r2 visL1 visR2
where
- push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR
+ push_trans cv1 kco1 r1 cv2 kco2 r2 visL visR
-- Given:
- -- co1 = /\ (cv1 : eta1) <visL, visM>. r1
- -- co2 = /\ (cv2 : eta2) <visM, visR>. r2
+ -- co1 = /\ (cv1 : kco1) <visL, visM>. r1
+ -- co2 = /\ (cv2 : kco2) <visM, visR>. r2
-- Wanted:
- -- n1 = nth 2 eta1
- -- n2 = nth 3 eta1
- -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])
+ -- n1 = nth 2 kco1
+ -- n2 = nth 3 kco1
+ -- nco = /\ cv1 : (kco1;kco2). (r1; r2[cv2 |-> (sym n1);cv1;n2])
= fireTransRule "EtaAllTy_co" co1 co2 $
- mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')
+ mkForAllCo cv1 visL visR (coToMCo (opt_trans is kco1 kco2))
+ (opt_trans is' r1 r2')
where
is' = is `extendInScopeSet` cv1
role = coVarRole cv1
- eta1' = downgradeRole role Nominal eta1
- n1 = mkSelCo (SelTyCon 2 role) eta1'
- n2 = mkSelCo (SelTyCon 3 role) eta1'
+ kco1' = downgradeRole role Nominal kco1
+ n1 = mkSelCo (SelTyCon 2 role) kco1'
+ n2 = mkSelCo (SelTyCon 3 role) kco1'
r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mk_trans_co`
(mkCoVarCo cv1) `mk_trans_co` n2])
r2
@@ -1285,7 +1288,8 @@ Here,
eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)
h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))
-}
-etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
+etaForAllCo_ty_maybe :: Coercion
+ -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
-- Try to make the coercion be of form (forall tv:kind_co. co)
etaForAllCo_ty_maybe co
| Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co
@@ -1305,7 +1309,8 @@ etaForAllCo_ty_maybe co
| otherwise
= Nothing
-etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
+etaForAllCo_co_maybe :: Coercion
+ -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, KindCoercion, Coercion)
-- Try to make the coercion be of form (forall cv:kind_co. co)
etaForAllCo_co_maybe co
| Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co
@@ -1428,13 +1433,17 @@ But if sym=Swapped, things are trickier. Here is an identity that helps:
-}
optForAllCoBndr :: LiftingContext -> SwapFlag
- -> TyCoVar -> Coercion
- -> (LiftingContext, TyCoVar, Coercion)
+ -> TyCoVar -> MCoercionN
+ -> (LiftingContext, TyCoVar, MCoercionN)
-- See Note [Optimising ForAllCo]
-optForAllCoBndr env sym tcv kco
- = (env', tcv', kco')
+optForAllCoBndr env sym tcv k_mco
+ = (env', tcv', k_mco')
where
- kco' = opt_co4 env sym False Nominal kco -- Push sym into kco
+ -- Push sym into kco
+ k_mco' = case k_mco of
+ MRefl -> MRefl
+ MCo co -> MCo (opt_co4 env sym False Nominal co)
+
(env', tcv') = updateLCSubst env upd_subst
upd_subst :: Subst -> (Subst, TyCoVar)
@@ -1443,26 +1452,32 @@ optForAllCoBndr env sym tcv kco
| otherwise = upd_subst_cv subst
upd_subst_tv subst
- | notSwapped sym || isReflCo kco' = (subst1, tv1)
- | otherwise = (subst2, tv2)
+ = case k_mco' of
+ MCo k_co' | isSwapped sym -> (subst2, tv2)
+ where
+ -- In the Swapped case, we re-kind the type variable, AND
+ -- override the substitution for the original variable to the
+ -- re-kinded one, suitably casted
+ tv2 = tv1 `setTyVarKind` coercionLKind k_co'
+ subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` k_co'))
+ `extendSubstInScope` tv2
+
+ _ -> (subst1, tv1)
where
-- subst1,tv1: apply the substitution to the binder and its kind
-- NB: varKind tv = coercionLKind kco
(subst1, tv1) = substTyVarBndr subst tcv
- -- In the Swapped case, we re-kind the type variable, AND
- -- override the substitution for the original variable to the
- -- re-kinded one, suitably casted
- tv2 = tv1 `setTyVarKind` coercionLKind kco'
- subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco'))
- `extendSubstInScope` tv2
upd_subst_cv subst -- ToDo: probably not right yet
- | notSwapped sym || isReflCo kco' = (subst1, cv1)
- | otherwise = (subst2, cv2)
- where
+ = case k_mco' of
+ MCo k_co' | isSwapped sym -> (subst2, cv2)
+ where
+ cv2 = cv1 `setTyVarKind` coercionLKind k_co'
+ subst2 = subst1 `extendSubstInScope` cv2
+
+ _ -> (subst1, cv1)
+ where
(subst1, cv1) = substCoVarBndr subst tcv
- cv2 = cv1 `setTyVarKind` coercionLKind kco'
- subst2 = subst1 `extendSubstInScope` cv2
{- **********************************************************************
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -2424,15 +2424,19 @@ lintCoercion co@(ForAllCo {})
go :: [OutTyCoVar] -- Binders in reverse order
-> InCoercion -> LintM Role
go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
- , fco_kind = kind_co, fco_body = body_co })
+ , fco_kind = kind_mco, fco_body = body_co })
| not (isTyCoVar tcv)
= failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)
| otherwise
- = do { lk <- lintStarCoercion kind_co
+ = do { mb_lk <- case kind_mco of
+ MRefl -> return Nothing
+ MCo kind_co -> Just <$> lintStarCoercion kind_co
; lintTyCoBndr tcv $ \tcv' ->
- do { ensureEqTys (varType tcv') lk $
- text "Kind mis-match in ForallCo" <+> ppr co
+ do { case mb_lk of
+ Nothing -> return ()
+ Just lk -> ensureEqTys (varType tcv') lk $
+ text "Kind mis-match in ForallCo" <+> ppr co
-- I'm not very sure about this part, because it traverses body_co
-- but at least it's on a cold path (a ForallCo for a CoVar)
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2367,8 +2367,7 @@ mkEtaForAllMCo (Bndr tcv vis) ty mco
| otherwise -> mk_fco (mkRepReflCo ty)
MCo co -> mk_fco co
where
- mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag
- (mkNomReflCo (varType tcv)) co)
+ mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co)
-- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly
-- the (EtaInfo Invariant). (sym co) wraps a lambda that always has
-- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]
@@ -2808,11 +2807,10 @@ tryEtaReduce rec_ids bndrs body eval_sd
| Just tv <- getTyVar_maybe arg_ty
, bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of
Just (Bndr _ vis, _) -> Just (fco, [])
- where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co
+ where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag MRefl co
-- The lambda we are eta-reducing always has visibility
-- 'coreTyLamForAllTyFlag' which may or may not match
-- the visibility on the inner function (#24014)
- kco = mkNomReflCo (tyVarKind tv)
Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type"
(text "fun:" <+> ppr bndr
$$ text "arg:" <+> ppr arg_ty
=====================================
compiler/GHC/Core/Reduction.hs
=====================================
@@ -373,7 +373,7 @@ mkForAllRedn :: ForAllTyFlag
-> Reduction
mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)
= mkReduction
- (mkForAllCo tv1 vis vis h co)
+ (mkForAllCo tv1 vis vis (kindCoToMKindCo h) co)
(mkForAllTy (Bndr tv2 vis) ty)
where
tv2 = setTyVarKind tv1 ki'
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -51,7 +51,6 @@ module GHC.Core.TyCo.FVs
import GHC.Prelude
import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView, rewriterView )
-import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind )
import GHC.Builtin.Types.Prim( funTyFlagTyCon )
@@ -641,8 +640,10 @@ tyCoVarsOfCoList :: Coercion -> [TyCoVar]
tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co
tyCoFVsOfMCo :: MCoercion -> FV
-tyCoFVsOfMCo MRefl = emptyFV
-tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co
+tyCoFVsOfMCo mco fv_cand in_scope acc
+ = case mco of
+ MRefl -> emptyFV fv_cand in_scope acc
+ MCo co -> tyCoFVsOfCo co fv_cand in_scope acc
tyCoFVsOfCo :: Coercion -> FV
-- Extracts type and coercion variables from a coercion
@@ -655,7 +656,7 @@ tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand
tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc
= (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc
tyCoFVsOfCo (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) fv_cand in_scope acc
- = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc
+ = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfMCo kind_co) fv_cand in_scope acc
tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc
= (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc
tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc
@@ -693,6 +694,10 @@ almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool
almostDevoidCoVarOfCo cv co =
almost_devoid_co_var_of_co co cv
+almost_devoid_co_var_of_mco :: MCoercion -> CoVar -> Bool
+almost_devoid_co_var_of_mco MRefl _ = True
+almost_devoid_co_var_of_mco (MCo co) cv = almost_devoid_co_var_of_co co cv
+
almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool
almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and
almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into
@@ -703,7 +708,7 @@ almost_devoid_co_var_of_co (AppCo co arg) cv
= almost_devoid_co_var_of_co co cv
&& almost_devoid_co_var_of_co arg cv
almost_devoid_co_var_of_co (ForAllCo { fco_tcv = v, fco_kind = kind_co, fco_body = co }) cv
- = almost_devoid_co_var_of_co kind_co cv
+ = almost_devoid_co_var_of_mco kind_co cv
&& (v == cv || almost_devoid_co_var_of_co co cv)
almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv
= almost_devoid_co_var_of_co w cv
@@ -1032,7 +1037,7 @@ tyConsOfType ty
go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args
go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg
go_co (ForAllCo { fco_kind = kind_co, fco_body = co })
- = go_co kind_co `unionUniqSets` go_co co
+ = go_mco kind_co `unionUniqSets` go_co co
go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })
= go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r
go_co (AxiomCo ax args) = go_ax ax `unionUniqSets` go_cos args
@@ -1230,14 +1235,14 @@ occCheckExpand vs_to_avoid ty
go_co cxt (SubCo co) = do { co' <- go_co cxt co
; return (SubCo co') }
- go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co })
- = do { kind_co' <- go_co cxt kind_co
- ; let tv' = setVarType tv $
- coercionLKind kind_co'
- env' = extendVarEnv env tv tv'
- as' = as `delVarSet` tv
+ go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = body_co })
+ = do { ki' <- go cxt (varType tcv)
+ ; let tcv' = setVarType tcv ki'
+ env' = extendVarEnv env tcv tcv'
+ as' = as `delVarSet` tcv
+ ; kind_co' <- go_mco cxt kind_co
; body' <- go_co (as', env') body_co
- ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) }
+ ; return (co { fco_tcv = tcv', fco_kind = kind_co', fco_body = body' }) }
go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 })
= do { co1' <- go_co cxt co1
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -39,7 +39,7 @@ module GHC.Core.TyCo.Rep (
UnivCoProvenance(..),
CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
CoercionN, CoercionR, CoercionP, KindCoercion,
- MCoercion(..), MCoercionR, MCoercionN,
+ MCoercion(..), MCoercionR, MCoercionN, KindMCoercion,
-- * Functions over types
mkNakedTyConTy, mkTyVarTy, mkTyVarTys,
@@ -806,6 +806,34 @@ tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res
%************************************************************************
-}
+type CoercionN = Coercion -- always Nominal
+type CoercionR = Coercion -- always Representational
+type CoercionP = Coercion -- always Phantom
+
+type MCoercionN = MCoercion -- alwyas Nominal
+type MCoercionR = MCoercion -- always Representational
+
+{- Note [KindCoercion]
+~~~~~~~~~~~~~~~~~~~~~~
+A KindCoercion kco :: k1 ~r k2 is a Coercion with these properties:
+ (a) It is Nominal; that is r=Nominal
+ (b) Both (k1::Type) and (k2::Type); it is homogeneous
+
+The coercion in (a) ForAllCo and (b) CastTy is a KindCoercion.
+
+The invariants of KindCoercion allow `isReflKindCo` to elminate GRefl,
+whereas isReflCo cannot. In particular, consider a KindCoercion
+ kco = GRefl r k (MCo kk)) :: k ~ (k |> kk)
+Since `kco`is a KindCoercion, we know that
+ r = Nominal
+ k :: Type and (k |> kk) :: Type
+Hence kk must be Refl. And hence kco = GRefl N k MRefl, which is
+the same as Refl. See `isReflKindCo`.
+-}
+
+type KindCoercion = CoercionN -- See Note [KindCoercion]
+type KindMCoercion = MCoercionN -- See Note [KindCoercion]
+
-- | A 'Coercion' is concrete evidence of the equality/convertibility
-- of two types.
@@ -829,7 +857,7 @@ data Coercion
-- GRefl :: "e" -> _ -> Maybe N -> e
-- See Note [Generalized reflexive coercion]
- | GRefl Role Type MCoercionN -- See Note [Refl invariant]
+ | GRefl Role Type KindMCoercion -- See Note [Refl invariant]
-- Use (Refl ty), not (GRefl Nominal ty MRefl)
-- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _))
@@ -853,7 +881,7 @@ data Coercion
, fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind
, fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind
-- See (FC7) of Note [ForAllCo]
- , fco_kind :: KindCoercion
+ , fco_kind :: KindMCoercion -- See (FC8) of Note [ForAllCo]
, fco_body :: Coercion }
-- ForAllCo :: _ -> N -> e -> e
@@ -911,6 +939,15 @@ data Coercion
-- Only present during typechecking
deriving Data.Data
+-- | A semantically more meaningful type to represent what may or may not be a
+-- useful 'Coercion'.
+data MCoercion
+ = MRefl
+ -- A trivial Reflexivity coercion
+ | MCo Coercion
+ -- Other coercions
+ deriving Data.Data
+
data CoSel -- See Note [SelCo]
= SelTyCon Int Role -- Decomposes (T co1 ... con); zero-indexed
-- Invariant: Given: SelCo (SelTyCon i r) co
@@ -932,11 +969,6 @@ data FunSel -- See Note [SelCo]
| SelRes -- Result of function
deriving( Eq, Data.Data, Ord )
-type CoercionN = Coercion -- always nominal
-type CoercionR = Coercion -- always representational
-type CoercionP = Coercion -- always phantom
-type KindCoercion = CoercionN -- always nominal
-
instance Outputable Coercion where
ppr = pprCo
@@ -980,17 +1012,6 @@ instance NFData CoSel where
rnf SelForAll = ()
rnf (SelFun fs) = rnf fs `seq` ()
--- | A semantically more meaningful type to represent what may or may not be a
--- useful 'Coercion'.
-data MCoercion
- = MRefl
- -- A trivial Reflexivity coercion
- | MCo Coercion
- -- Other coercions
- deriving Data.Data
-type MCoercionR = MCoercion
-type MCoercionN = MCoercion
-
instance Outputable MCoercion where
ppr MRefl = text "MRefl"
ppr (MCo co) = text "MCo" <+> ppr co
@@ -1278,6 +1299,14 @@ Several things to note here
fco_visL = fco_visR = coreTyLamForAllTyFlag
c.f. (FT2) in Note [ForAllTy]
+(FC8) We /represent/ a ForAllCo { fco_tcv = tcv, fco_kind = kmco } as follows:
+ * The tcv::TyCoVar has a kind (like any Var), say tcv::ki
+ * The kind-coercion `kmco` is a KindMCoercion:
+ - If kmco = MRefl, then the coercion in the typing rule is (Refl ki)
+ - If kmco = MCo kco, then the coercion in the typing rule is `co`,
+ /and/ ki = coercionLKind kco
+ So in the common MRefl case, the kind of `tcv` plays a useful role.
+
Note [Predicate coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
@@ -1937,11 +1966,14 @@ foldTyCo (TyCoFolder { tcf_view = view
go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })
= go_co env cw `mappend` go_co env c1 `mappend` go_co env c2
- go_co env (ForAllCo tv _vis1 _vis2 kind_co co)
- = go_co env kind_co `mappend` go_ty env (varType tv)
- `mappend` go_co env' co
+ go_co env (ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = co })
+ = go_mco env kind_co `mappend` go_ty env (varType tcv)
+ `mappend` go_co env' co
where
- env' = tycobinder env tv Inferred
+ env' = tycobinder env tcv Inferred
+
+ go_mco _ MRefl = mempty
+ go_mco env (MCo co) = go_co env co
-- | A view function that looks through nothing.
noView :: Type -> Maybe Type
@@ -1983,18 +2015,19 @@ typesSize tys = foldr ((+) . typeSize) 0 tys
coercionSize :: Coercion -> Int
coercionSize (Refl ty) = typeSize ty
-coercionSize (GRefl _ ty MRefl) = typeSize ty
-coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co
+coercionSize (GRefl _ ty mco) = typeSize ty + mCoercionSize mco
coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)
coercionSize (AppCo co arg) = coercionSize co + coercionSize arg
coercionSize (ForAllCo { fco_kind = h, fco_body = co })
- = 1 + coercionSize co + coercionSize h
+ = 1 + coercionSize co + mCoercionSize h
coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2
+ coercionSize w
coercionSize (CoVarCo _) = 1
coercionSize (HoleCo _) = 1
coercionSize (AxiomCo _ cs) = 1 + sum (map coercionSize cs)
-coercionSize (UnivCo { uco_lty = t1, uco_rty = t2 }) = 1 + typeSize t1 + typeSize t2
+coercionSize (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps })
+ = 1 + typeSize t1 + typeSize t2
+ + sum (map coercionSize deps)
coercionSize (SymCo co) = 1 + coercionSize co
coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2
coercionSize (SelCo _ co) = 1 + coercionSize co
@@ -2003,6 +2036,10 @@ coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg
coercionSize (KindCo co) = 1 + coercionSize co
coercionSize (SubCo co) = 1 + coercionSize co
+mCoercionSize :: MCoercion -> Int
+mCoercionSize MRefl = 0
+mCoercionSize (MCo co) = coercionSize co
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -29,11 +29,10 @@ module GHC.Core.TyCo.Subst
mkTvSubstPrs,
substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,
- substCoWith,
+ substCoWithInScope,
substTy, substTyAddInScope, substScaledTy,
substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked,
substTyWithUnchecked, substScaledTyUnchecked,
- substCoUnchecked, substCoWithUnchecked,
substTyWithInScope,
substTys, substScaledTys, substTheta,
lookupTyVar,
@@ -44,8 +43,8 @@ module GHC.Core.TyCo.Subst
substCoVarBndr, substDCoVarSet,
substTyVar, substTyVars, substTyVarToTyVar,
substTyCoVars,
- substTyCoBndr, substForAllCoBndr,
- substVarBndrUsing, substForAllCoBndrUsing,
+ substTyCoBndr,
+ substVarBndrUsing,
checkValidSubst, isValidTCvSubst,
) where
@@ -60,7 +59,7 @@ import {-# SOURCE #-} GHC.Core.Coercion
, mkAxiomCo, mkAppCo, mkGReflCo
, mkInstCo, mkLRCo, mkTyConAppCo
, mkCoercionType
- , coercionLKind, coVarTypesRole )
+ , coVarTypesRole )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )
import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr
import {-# SOURCE #-} GHC.Core ( CoreExpr )
@@ -618,28 +617,19 @@ substTyWithUnchecked tvs tys
-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution
-- invariant]; specifically it should include the free vars of 'tys',
-- and of 'ty' minus the domain of the subst.
-substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type
+substTyWithInScope :: HasDebugCallStack
+ => InScopeSet -> [TyVar] -> [Type] -> Type -> Type
substTyWithInScope in_scope tvs tys ty =
assert (tvs `equalLength` tys )
substTy (mkTvSubst in_scope tenv) ty
where tenv = zipTyEnv tvs tys
-- | Coercion substitution, see 'zipTvSubst'
-substCoWith :: HasDebugCallStack => [TyVar] -> [Type] -> Coercion -> Coercion
-substCoWith tvs tys = assert (tvs `equalLength` tys )
- substCo (zipTvSubst tvs tys)
-
--- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.
--- The problems that the sanity checks in substCo catch are described in
--- Note [The substitution invariant].
--- The goal of #11371 is to migrate all the calls of substCoUnchecked to
--- substCo and remove this function. Please don't use in new code.
-substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion
-substCoWithUnchecked tvs tys
+substCoWithInScope :: HasDebugCallStack
+ => InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion
+substCoWithInScope in_scope tvs tys co
= assert (tvs `equalLength` tys )
- substCoUnchecked (zipTvSubst tvs tys)
-
-
+ substCo (mkTvSubst in_scope (zipTyEnv tvs tys)) co
-- | Substitute covars within a type
substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type
@@ -800,10 +790,10 @@ subst_ty subst ty
!res' = go res
in ty { ft_mult = mult', ft_arg = arg', ft_res = res' }
go (ForAllTy (Bndr tv vis) ty)
- = case substVarBndrUnchecked subst tv of
- (subst', tv') ->
- (ForAllTy $! ((Bndr $! tv') vis)) $!
- (subst_ty subst' ty)
+ = (ForAllTy $! ((Bndr $! tv') vis)) $! (subst_ty subst' ty)
+ where
+ !(subst',tv') = substVarBndrUnchecked subst tv
+ -- Unchecked because subst_ty is used from substTyUnchecked
go (LitTy n) = LitTy $! n
go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co)
go (CoercionTy co) = CoercionTy $! (subst_co subst co)
@@ -850,16 +840,6 @@ substCo subst co
| isEmptyTCvSubst subst = co
| otherwise = checkValidSubst subst [] [co] $ subst_co subst co
--- | Substitute within a 'Coercion' disabling sanity checks.
--- The problems that the sanity checks in substCo catch are described in
--- Note [The substitution invariant].
--- The goal of #11371 is to migrate all the calls of substCoUnchecked to
--- substCo and remove this function. Please don't use in new code.
-substCoUnchecked :: Subst -> Coercion -> Coercion
-substCoUnchecked subst co
- | isEmptyTCvSubst subst = co
- | otherwise = subst_co subst co
-
-- | Substitute within several 'Coercion's
-- The substitution has to satisfy the invariants described in
-- Note [The substitution invariant].
@@ -868,7 +848,7 @@ substCos subst cos
| isEmptyTCvSubst subst = cos
| otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos
-subst_co :: Subst -> Coercion -> Coercion
+subst_co :: HasDebugCallStack => Subst -> Coercion -> Coercion
subst_co subst co
= go co
where
@@ -885,10 +865,14 @@ subst_co subst co
go (TyConAppCo r tc args)= mkTyConAppCo r tc $! go_cos args
go (AxiomCo con cos) = mkAxiomCo con $! go_cos cos
go (AppCo co arg) = (mkAppCo $! go co) $! go arg
- go (ForAllCo tv visL visR kind_co co)
- = case substForAllCoBndrUnchecked subst tv kind_co of
- (subst', tv', kind_co') ->
- ((mkForAllCo $! tv') visL visR $! kind_co') $! subst_co subst' co
+ go (ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
+ , fco_kind = kind_co, fco_body = co })
+ = ((mkForAllCo $! tcv') visL visR
+ $! go_mco kind_co)
+ $! subst_co subst' co
+ where
+ !(subst', tcv') = substVarBndrUnchecked subst tcv
+ -- Unchecked because used from substTyUnchecked
go (FunCo r afl afr w co1 co2) = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2
go (CoVarCo cv) = substCoVar subst cv
go (UnivCo { uco_prov = p, uco_role = r
@@ -917,75 +901,6 @@ substDCoVarSet :: Subst -> DCoVarSet -> DCoVarSet
substDCoVarSet subst cvs = coVarsOfCosDSet $ map (substCoVar subst) $
dVarSetElems cvs
-substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion
- -> (Subst, TyCoVar, Coercion)
-substForAllCoBndr subst
- = substForAllCoBndrUsing (substCo subst) subst
-
--- | Like 'substForAllCoBndr', but disables sanity checks.
--- The problems that the sanity checks in substCo catch are described in
--- Note [The substitution invariant].
--- The goal of #11371 is to migrate all the calls of substCoUnchecked to
--- substCo and remove this function. Please don't use in new code.
-substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion
- -> (Subst, TyCoVar, Coercion)
-substForAllCoBndrUnchecked subst
- = substForAllCoBndrUsing (substCoUnchecked subst) subst
-
--- See Note [Sym and ForAllCo]
-substForAllCoBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
- -> Subst -> TyCoVar -> KindCoercion
- -> (Subst, TyCoVar, KindCoercion)
-substForAllCoBndrUsing sco subst old_var
- | isTyVar old_var = substForAllCoTyVarBndrUsing sco subst old_var
- | otherwise = substForAllCoCoVarBndrUsing sco subst old_var
-
-substForAllCoTyVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
- -> Subst -> TyVar -> KindCoercion
- -> (Subst, TyVar, KindCoercion)
-substForAllCoTyVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co
- = assert (isTyVar old_var )
- ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv
- , new_var, new_kind_co )
- where
- new_env | no_change = delVarEnv tenv old_var
- | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
-
- no_kind_change = noFreeVarsOfCo old_kind_co
- no_change = no_kind_change && (new_var == old_var)
-
- new_kind_co | no_kind_change = old_kind_co
- | otherwise = sco old_kind_co
-
- new_ki1 = coercionLKind new_kind_co
- -- We could do substitution to (tyVarKind old_var). We don't do so because
- -- we already substituted new_kind_co, which contains the kind information
- -- we want. We don't want to do substitution once more. Also, in most cases,
- -- new_kind_co is a Refl, in which case coercionKind is really fast.
-
- new_var = uniqAway in_scope (setTyVarKind old_var new_ki1)
-
-substForAllCoCoVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co
- -> Subst -> CoVar -> KindCoercion
- -> (Subst, CoVar, KindCoercion)
-substForAllCoCoVarBndrUsing sco (Subst in_scope idenv tenv cenv)
- old_var old_kind_co
- = assert (isCoVar old_var )
- ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv
- , new_var, new_kind_co )
- where
- new_cenv | no_change = delVarEnv cenv old_var
- | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)
-
- no_kind_change = noFreeVarsOfCo old_kind_co
- no_change = no_kind_change && (new_var == old_var)
-
- new_kind_co | no_kind_change = old_kind_co
- | otherwise = sco old_kind_co
-
- new_ki1 = coercionLKind new_kind_co
- new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1
-
substCoVar :: Subst -> CoVar -> Coercion
substCoVar (Subst _ _ _ cenv) cv
= case lookupVarEnv cenv cv of
=====================================
compiler/GHC/Core/TyCo/Tidy.hs
=====================================
@@ -334,7 +334,7 @@ tidyCo env co
go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos
go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
go (ForAllCo tv visL visR h co)
- = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co)
+ = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go_mco h)) $! (tidyCo envp co)
where (envp, tvp) = tidyVarBndr env tv
-- the case above duplicates a bit of work in tidying h and the kind
-- of tv. But the alternative is to use coercionKind, which seems worse.
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -210,7 +210,7 @@ module GHC.Core.Type (
substTyAddInScope,
substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked,
substThetaUnchecked, substTyWithUnchecked,
- substCo, substCoUnchecked, substCoWithUnchecked,
+ substCo, substCoWithInScope,
substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
substVarBndr, substVarBndrs,
substTyCoBndr, substTyVarToTyVar,
@@ -530,10 +530,13 @@ expandTypeSynonyms ty
= mkTyConAppCo r tc (map (go_co subst) args)
go_co subst (AppCo co arg)
= mkAppCo (go_co subst co) (go_co subst arg)
- go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
+ go_co subst (ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR
, fco_kind = kind_co, fco_body = co })
- = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in
- mkForAllCo tv' visL visR kind_co' (go_co subst' co)
+ = mkForAllCo tcv' visL visR
+ (go_mco subst kind_co)
+ (go_co subst' co)
+ where
+ (subst', tcv') = substVarBndr subst tcv
go_co subst (FunCo r afl afr w co1 co2)
= mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2)
go_co subst (CoVarCo cv)
@@ -559,8 +562,6 @@ expandTypeSynonyms ty
go_co _ (HoleCo h)
= pprPanic "expandTypeSynonyms hit a hole" (ppr h)
- go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst
-
{- Notes on type synonyms
~~~~~~~~~~~~~~~~~~~~~~~~~
The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
@@ -971,7 +972,7 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar
= mkTyConAppCo r tc <$> go_cos env cos
go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
, fco_kind = kind_co, fco_body = co })
- = do { kind_co' <- go_co env kind_co
+ = do { kind_co' <- go_mco env kind_co
; tycobinder env tv visL $ \env' tv' -> do
; co' <- go_co env' co
; return $ mkForAllCo tv' visL visR kind_co' co' }
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -2414,14 +2414,15 @@ ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 })
-- not doing so caused #21205.
ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1)
- (ForAllCo tv2 vis1c vis2c kind_co2 co2)
+ (ForAllCo tv2 vis1c vis2c kind_mco2 co2)
lkco rkco
| isTyVar tv1 && isTyVar tv2
, vis1t == vis1c && vis1c == vis2c -- Is this necessary?
-- Is this visibility check necessary? @rae says: yes, I think the
-- check is necessary, if we're caring about visibility (and we are).
-- But ty_co_match is a dark and not important corner.
- = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2
+ = do { subst1 <- ty_co_match menv subst (tyVarKind tv1)
+ (forAllCoKindCo tv2 kind_mco2)
ki_ki_co ki_ki_co
; let rn_env0 = me_env menv
rn_env1 = rnBndr2 rn_env0 tv1 tv2
@@ -2522,6 +2523,6 @@ pushRefl co =
-> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))
Just (ForAllTy (Bndr tv vis) ty, r)
-> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis
- , fco_kind = mkNomReflCo (varType tv)
+ , fco_kind = MRefl
, fco_body = mkReflCo r ty })
_ -> Nothing
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -312,7 +312,7 @@ toIfaceCoercionX fr co
= IfaceForAllCo (toIfaceBndr tv)
visL
visR
- (toIfaceCoercionX fr' k)
+ (go_mco k)
(toIfaceCoercionX fr' co)
where
fr' = fr `delVarSet` tv
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -689,7 +689,7 @@ rnIfaceCo (IfaceAxiomCo ax cos) = IfaceAxiomCo ax <$> mapM rnIfaceCo cos
rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
rnIfaceCo (IfaceForAllCo bndr visL visR co1 co2)
= (\bndr' co1' co2' -> IfaceForAllCo bndr' visL visR co1' co2')
- <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+ <$> rnIfaceBndr bndr <*> rnIfaceMCo co1 <*> rnIfaceCo co2
rnIfaceCo (IfaceUnivCo s r t1 t2 deps)
= IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 <*> mapM rnIfaceCo deps
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -2076,7 +2076,7 @@ freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
freeNamesIfCoercion (IfaceAppCo c1 c2)
= freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co)
- = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
+ = freeNamesIfMCoercion kind_co &&& freeNamesIfCoercion co
freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet
freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet
freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -132,7 +132,7 @@ data IfaceBndr -- Local (non-top-level) binders
deriving (Eq, Ord)
-type IfaceIdBndr = (IfaceType, IfLclName, IfaceType)
+type IfaceIdBndr = (IfaceType, IfLclName, IfaceType) -- (multiplicity, name, type)
type IfaceTvBndr = (IfLclName, IfaceKind)
ifaceTvBndrName :: IfaceTvBndr -> IfLclName
@@ -479,7 +479,7 @@ data IfaceCoercion
| IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion
| IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
| IfaceAppCo IfaceCoercion IfaceCoercion
- | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceCoercion IfaceCoercion
+ | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceMCoercion IfaceCoercion
| IfaceCoVarCo IfLclName
| IfaceAxiomCo IfaceAxiomRule [IfaceCoercion]
-- ^ There are only a fixed number of CoAxiomRules, so it suffices
@@ -1454,10 +1454,9 @@ pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
pprIfaceForAllPartMust tvs ctxt sdoc
= ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc
-pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)]
+pprIfaceForAllCoPart :: [(IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag)]
-> SDoc -> SDoc
-pprIfaceForAllCoPart tvs sdoc
- = sep [ pprIfaceForAllCo tvs, sdoc ]
+pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs, sdoc ]
ppr_iface_forall_part :: ShowForAllFlag
-> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
@@ -1494,11 +1493,11 @@ ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1
| otherwise = (all_bndrs, [])
ppr_itv_bndrs [] _ = ([], [])
-pprIfaceForAllCo :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
+pprIfaceForAllCo :: [(IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
pprIfaceForAllCo [] = empty
pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
-pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
+pprIfaceForAllCoBndrs :: [(IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc
pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
@@ -1513,10 +1512,17 @@ pprIfaceForAllBndr bndr =
-- See Note [Suppressing binder signatures]
suppress_sig = SuppressBndrSig False
-pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc
-pprIfaceForAllCoBndr (tv, kind_co, visL, visR)
- = parens (ppr tv <> pp_vis <+> dcolon <+> pprIfaceCoercion kind_co)
+pprIfaceForAllCoBndr :: (IfaceBndr, IfaceMCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc
+pprIfaceForAllCoBndr (tcv, kind_mco, visL, visR)
+ = parens (ppr (ifaceBndrName tcv) <> pp_vis
+ <+> text "::~" <+> pprIfaceCoercion kind_co)
+ -- We print (tcv ::~ kind_co), with the "::~" reminding us the type of tcv
+ -- isn't kind_co; rather it's (coercionLKind kind_co). We used "::" previously
+ -- which grievously confused me.
where
+ kind_co = case kind_mco of
+ IfaceMRefl -> IfaceReflCo (ifaceBndrType tcv)
+ IfaceMCo co -> co
pp_vis | visL == coreTyLamForAllTyFlag
, visR == coreTyLamForAllTyFlag
= empty
@@ -2069,10 +2075,8 @@ ppr_co ctxt_prec co@(IfaceForAllCo {})
where
(tvs, inner_co) = split_co co
- split_co (IfaceForAllCo (IfaceTvBndr (name, _)) visL visR kind_co co')
- = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')
- split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) visL visR kind_co co')
- = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')
+ split_co (IfaceForAllCo bndr visL visR kind_co co')
+ = let (tvs, co'') = split_co co' in ((bndr,kind_co,visL,visR):tvs,co'')
split_co co' = ([], co')
-- Why these three? See Note [Free TyVars and CoVars in IfaceType]
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1576,9 +1576,12 @@ tcIfaceCo = go
go (IfaceFunCo r w c1 c2) = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2
go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
- go (IfaceForAllCo tv visL visR k c) = do { k' <- go k
- ; bindIfaceBndr tv $ \ tv' ->
- ForAllCo tv' visL visR k' <$> go c }
+ go (IfaceForAllCo tcv visL visR k co)
+ = do { k' <- go_mco k
+ ; bindIfaceBndr tcv $ \ tv' ->
+ do { co' <- go co
+ ; return (ForAllCo { fco_tcv = tv', fco_visL = visL, fco_visR = visR
+ , fco_kind = k', fco_body = co' }) } }
go (IfaceCoVarCo n) = CoVarCo <$> go_var n
go (IfaceUnivCo p r t1 t2 ds) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2
; ds' <- mapM go ds
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -135,7 +135,7 @@ synonymTyConsOfType ty
go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs
go_co (AppCo co co') = go_co co `plusNameEnv` go_co co'
go_co (ForAllCo { fco_kind = kind_co, fco_body = body_co })
- = go_co kind_co `plusNameEnv` go_co body_co
+ = go_mco kind_co `plusNameEnv` go_co body_co
go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })
= go_co m `plusNameEnv` go_co a `plusNameEnv` go_co r
go_co (CoVarCo _) = emptyNameEnv
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1586,7 +1586,7 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co
go_co dv (CoVarCo cv) = go_cv dv cv
go_co dv (ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = co })
- = do { dv1 <- go_co dv kind_co
+ = do { dv1 <- go_mco dv kind_co
; collect_cand_qtvs_co orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co }
go_mco dv MRefl = return dv
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -176,7 +176,6 @@ module GHC.Tc.Utils.TcType (
substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,
substThetaUnchecked,
substTyWithUnchecked,
- substCoUnchecked, substCoWithUnchecked,
substTheta,
isUnliftedType,
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -1206,10 +1206,11 @@ wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty
boxer = Boxer $ \ subst ->
do { (rep_ids, rep_expr)
<- case box_rep of
- UnitBox -> do { rep_id <- newLocal (fsLit "cowrap_bx") (linear $ TcType.substTy subst rep_ty)
+ UnitBox -> do { rep_id <- newLocal (fsLit "cowrap_bx")
+ (linear $ TcType.substTy subst rep_ty)
; return ([rep_id], Var rep_id) }
Boxer boxer -> boxer subst
- ; let sco = substCoUnchecked subst co
+ ; let sco = substCo subst co
; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
------------------------
=====================================
testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr
=====================================
@@ -1,24 +1,24 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 82, types: 52, coercions: 29, joins: 0/0}
+ = {terms: 82, types: 52, coercions: 26, joins: 0/0}
-- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0}
unsafeToInteger1 :: forall (n :: Nat). Signed n -> Signed n
[GblId, Arity=1, Unf=OtherCon []]
unsafeToInteger1 = \ (@(n :: Nat)) (ds :: Signed n) -> ds
--- RHS size: {terms: 1, types: 0, coercions: 8, joins: 0/0}
+-- RHS size: {terms: 1, types: 0, coercions: 7, joins: 0/0}
unsafeToInteger :: forall (n :: Nat). Signed n -> Integer
[GblId[[RecSel]], Arity=1, Unf=OtherCon []]
unsafeToInteger
= unsafeToInteger1
- `cast` (forall (n :: <Nat>_N).
+ `cast` (forall (n ::~ <Nat>_N).
<Signed n>_R %<Many>_N ->_R OpaqueNoCastWW.N:Signed <n>_P
:: (forall (n :: Nat). Signed n -> Signed n)
~R# (forall (n :: Nat). Signed n -> Integer))
--- RHS size: {terms: 8, types: 7, coercions: 21, joins: 0/0}
+-- RHS size: {terms: 8, types: 7, coercions: 19, joins: 0/0}
times [InlPrag=OPAQUE]
:: forall (m :: Nat) (n :: Nat).
Signed m -> Signed n -> Signed (m + n)
@@ -33,7 +33,7 @@ times
(ds `cast` (OpaqueNoCastWW.N:Signed <m>_P :: Signed m ~R# Integer))
(ds1
`cast` (OpaqueNoCastWW.N:Signed <n>_P :: Signed n ~R# Integer)))
- `cast` (forall (m :: <Nat>_N) (n :: <Nat>_N).
+ `cast` (forall (m ::~ <Nat>_N) (n ::~ <Nat>_N).
<Signed m>_R
%<Many>_N ->_R <Signed n>_R
%<Many>_N ->_R Sym (OpaqueNoCastWW.N:Signed <m + n>_P)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2897da11f158099cb3c6e9834e7fe0c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2897da11f158099cb3c6e9834e7fe0c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: ghc-internal: invert dependency of GHC.Internal.TH.Syntax on Data.Data
by Marge Bot (＠marge-bot) 04 Sep '25
by Marge Bot (＠marge-bot) 04 Sep '25
04 Sep '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
39e1b7cb by Teo Camarasu at 2025-09-04T06:32:46-04:00
ghc-internal: invert dependency of GHC.Internal.TH.Syntax on Data.Data
This means that Data.Data no longer blocks building TH.Syntax, which
allows greater parallelism in our builds.
We move the Data.Data.Data instances to Data.Data. Quasi depends on
Data.Data for one of its methods, so,
we split the Quasi/Q, etc definition out of GHC.Internal.TH.Syntax
into its own module. This has the added benefit of splitting up this
quite large module.
Previously TH.Syntax was a bottleneck when compiling ghc-internal. Now
it is less of a bottle-neck and is also slightly quicker to
compile (since it no longer contains these instances) at the cost of
making Data.Data slightly more expensive to compile.
TH.Lift which depends on TH.Syntax can also compile quicker and no
longer blocks ghc-internal finishing to compile.
Resolves #26217
-------------------------
Metric Decrease:
MultiLayerModulesTH_OneShot
T13253
T21839c
T24471
Metric Increase:
T12227
-------------------------
- - - - -
bdf82fd2 by Teo Camarasu at 2025-09-04T06:32:46-04:00
compiler: delete unused names in Builtins.Names.TH
returnQ and bindQ are no longer used in the compiler.
There was also a very old comment that referred to them that I have modernized
- - - - -
36 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Types/TH.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- + libraries/ghc-boot-th/GHC/Boot/TH/Monad.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- + libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Quote.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/tests/deriving/should_compile/T14682.stderr
- testsuite/tests/deriving/should_compile/drv-empty-data.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/splice-imports/SI29.stderr
- testsuite/tests/th/T11452.stderr
- testsuite/tests/th/T15321.stderr
- testsuite/tests/th/T7276.stderr
- testsuite/tests/th/TH_NestedSplicesFail3.stderr
- testsuite/tests/th/TH_NestedSplicesFail4.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b2c72c039ddf3eaa292e32556a291…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b2c72c039ddf3eaa292e32556a291…
You're receiving this email because of your account on gitlab.haskell.org.
1
0