Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
3fdf6a43 by Apoorv Ingle at 2025-08-26T16:22:28-05:00
This commit:
- Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr`
Calls `setInGeneratedCode` everytime the typechecker goes over an `XExpr`
- Kills `VACtxt` (and its associated VAExpansion and VACall) datatype, it is subsumed by simply a SrcSpan.
- Kills the function `addHeadCtxt` as it is now mearly setting a location
- The function `tcValArgs` does its own argument number management
- Makes `splitHsApps` not look through `XExpr`
- `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr`
- Removes location information from `OrigPat` payload
- Removes special case of tcBody from `tcLambdaMatches`
- Removes special case of `dsExpr` for `ExpandedThingTc`
- Moves `setQLInstLevel` inside `tcInstFun`
- Rename `HsThingRn` to `SrcCodeCtxt`
- Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack`
- Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin`
- Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression
- Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax
- Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo`
- Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr`
- Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span`
Notes added [Error Context Stack]
Notes updated Note [Expanding HsDo with XXExprGhcRn]
-------------------------
Metric Decrease:
T9020
-------------------------
- - - - -
60 changed files:
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- + compiler/GHC/Tc/Gen/App.hs-boot
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- + testsuite/tests/deSugar/should_compile/T10662
- testsuite/tests/default/default-fail05.stderr
- + testsuite/tests/ghci.debugger/Do
- + testsuite/tests/ghci.debugger/Do.hs
- + testsuite/tests/ghci.debugger/T25996.hs
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/polykinds/T13393.stderr
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/rep-poly/RepPolyDoBind.stderr
- testsuite/tests/rep-poly/RepPolyDoBody1.stderr
- testsuite/tests/rep-poly/RepPolyDoBody2.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/typecheck/should_compile/T14590.stderr
- + testsuite/tests/typecheck/should_compile/T25996.hs
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T24064.stderr
- + testsuite/tests/typecheck/should_fail/T25970.hs
- + testsuite/tests/typecheck/should_fail/T25996.hs
- testsuite/tests/typecheck/should_fail/T3323.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/tcfail102.stderr
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail168.stderr
- testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3fdf6a43359d6fb12ed266ccf94f9d7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3fdf6a43359d6fb12ed266ccf94f9d7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
26 Aug '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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.
- - - - -
4 changed files:
- 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
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2cbba9d67160c50f80cfcf08969c197…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2cbba9d67160c50f80cfcf08969c197…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
26 Aug '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
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
- - - - -
1 changed file:
- testsuite/tests/rts/all.T
Changes:
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -643,6 +643,7 @@ test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
test('T22859',
[js_skip,
- # Allocation behaviour differs with the wasm backend so we get different output
- when(arch('wasm32'), skip)],
+ # This test is vulnerable to changes in allocation behaviour, so we disable it in some ways
+ when(arch('wasm32'), skip),
+ omit_ways(llvm_ways)],
compile_and_run, ['-with-rtsopts -A8K'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37655c467af932eb6ac846d888b1fa7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37655c467af932eb6ac846d888b1fa7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 7 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Hannes Siebenhandl (＠fendor) 26 Aug '25
by Hannes Siebenhandl (＠fendor) 26 Aug '25
26 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode 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.
- - - - -
2177a06c by fendor at 2025-08-26T21:10:59+02: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.
- - - - -
297f8632 by fendor at 2025-08-26T21:10:59+02:00
Implement `decode` in terms of `decodeStackWithIpe`
Uses the more efficient stack decoder implementation.
- - - - -
3e80d28e by fendor at 2025-08-26T21:10:59+02:00
Remove stg_decodeStackzh
- - - - -
66 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.16.1-notes.rst
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Stack/CloneStack.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/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/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/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-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-heap/tests/stack-annotation/ann_frame004.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/ghci.cabal.in
- rts/CloneStack.c
- rts/CloneStack.h
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/RtsSymbols.c
- rts/STM.c
- 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/lib/stm/T26028.hs
- − testsuite/tests/lib/stm/T26028.stdout
- − testsuite/tests/lib/stm/all.T
- + testsuite/tests/typecheck/should_fail/T26318.hs
- + testsuite/tests/typecheck/should_fail/T26318.stderr
- testsuite/tests/typecheck/should_fail/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/e46cdffeea52155d710147e6ab5a83…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e46cdffeea52155d710147e6ab5a83…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed new branch wip/26331 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/26331
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26255] 5 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Simon Peyton Jones (＠simonpj) 26 Aug '25
by Simon Peyton Jones (＠simonpj) 26 Aug '25
26 Aug '25
Simon Peyton Jones pushed to branch wip/T26255 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.
- - - - -
ca1b9bea by Simon Peyton Jones at 2025-08-26T17:30:29+01:00
Report solid equality errors before custom errors
This MR fixes #26255 by reporting solid equality errors like
Int ~ Bool
before "custom type errors". Details in #26255, and the comments
with `report1` in the patch.
The priority for custom type errors was introduced in the original
custom-type-error patch, and has (sadly) been present since GHC 9.4
Better position for custom errors
Prioritise errors with a (F tys ~ rigid)
See the ticket for more
Further improvements
* Suppress all Wanted superclass constraints
* Priorities (F tys ~ rigid) over custom type errors
Wibble comments
More wibbles
Wibble
- - - - -
26 changed files:
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Utils/TcType.hs
- docs/users_guide/9.16.1-notes.rst
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/STM.c
- − testsuite/tests/lib/stm/T26028.hs
- − testsuite/tests/lib/stm/T26028.stdout
- − testsuite/tests/lib/stm/all.T
- testsuite/tests/typecheck/should_fail/T18851.hs
- + testsuite/tests/typecheck/should_fail/T26255a.hs
- + testsuite/tests/typecheck/should_fail/T26255a.stderr
- + testsuite/tests/typecheck/should_fail/T26255b.hs
- + testsuite/tests/typecheck/should_fail/T26255b.stderr
- + testsuite/tests/typecheck/should_fail/T26255c.hs
- + testsuite/tests/typecheck/should_fail/T26255c.stderr
- + testsuite/tests/typecheck/should_fail/T26318.hs
- + testsuite/tests/typecheck/should_fail/T26318.stderr
- testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr
- testsuite/tests/typecheck/should_fail/all.T
- utils/jsffi/dyld.mjs
Changes:
=====================================
compiler/GHC/Cmm/Dataflow/Label.hs
=====================================
@@ -83,6 +83,7 @@ import GHC.Data.Word64Map.Strict (Word64Map)
import qualified GHC.Data.Word64Map.Strict as M
import GHC.Data.TrieMap
+import Data.Coerce
import Data.Word (Word64)
@@ -164,7 +165,7 @@ setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s
{-# INLINE setElems #-}
setElems :: LabelSet -> [Label]
-setElems (LS s) = map mkHooplLabel (S.elems s)
+setElems (LS s) = coerce $ S.elems s
{-# INLINE setFromList #-}
setFromList :: [Label] -> LabelSet
@@ -272,7 +273,7 @@ mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m)
{-# INLINE mapToList #-}
mapToList :: LabelMap b -> [(Label, b)]
-mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m]
+mapToList (LM m) = coerce $ M.toList m
{-# INLINE mapFromList #-}
mapFromList :: [(Label, v)] -> LabelMap v
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -132,7 +132,7 @@ module GHC.Core.Type (
kindBoxedRepLevity_maybe,
mightBeLiftedType, mightBeUnliftedType,
definitelyLiftedType, definitelyUnliftedType,
- isAlgType, isDataFamilyAppType,
+ isAlgType, isDataFamilyApp, isSatTyFamApp,
isPrimitiveType, isStrictType, isTerminatingType,
isLevityTy, isLevityVar,
isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
@@ -2295,6 +2295,21 @@ isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty
isFamFreeTy (CastTy ty _) = isFamFreeTy ty
isFamFreeTy (CoercionTy _) = False -- Not sure about this
+-- | Check whether a type is a data family type
+isDataFamilyApp :: Type -> Bool
+isDataFamilyApp ty = case tyConAppTyCon_maybe ty of
+ Just tc -> isDataFamilyTyCon tc
+ _ -> False
+
+isSatTyFamApp :: Type -> Maybe (TyCon, [Type])
+-- Return the argument if we have a saturated type family application
+-- Why saturated? See (ATF4) in Note [Apartness and type families]
+isSatTyFamApp (TyConApp tc tys)
+ | isTypeFamilyTyCon tc
+ && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated
+ = Just (tc, tys)
+isSatTyFamApp _ = Nothing
+
buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind
-> [Role] -> KnotTied Type -> TyCon
-- This function is here because here is where we have
@@ -2462,12 +2477,6 @@ isAlgType ty
isAlgTyCon tc
_other -> False
--- | Check whether a type is a data family type
-isDataFamilyAppType :: Type -> Bool
-isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of
- Just tc -> isDataFamilyTyCon tc
- _ -> False
-
-- | Computes whether an argument (or let right hand side) should
-- be computed strictly or lazily, based only on its type.
-- Currently, it's just 'isUnliftedType'.
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1690,8 +1690,8 @@ unify_ty env ty1 ty2 kco
where
mb_tc_app1 = splitTyConApp_maybe ty1
mb_tc_app2 = splitTyConApp_maybe ty2
- mb_sat_fam_app1 = isSatFamApp ty1
- mb_sat_fam_app2 = isSatFamApp ty2
+ mb_sat_fam_app1 = isSatTyFamApp ty1
+ mb_sat_fam_app2 = isSatTyFamApp ty2
unify_ty _ _ _ _ = surelyApart
@@ -1750,16 +1750,6 @@ unify_tys env orig_xs orig_ys
-- Possibly different saturations of a polykinded tycon
-- See Note [Polykinded tycon applications]
----------------------------------
-isSatFamApp :: Type -> Maybe (TyCon, [Type])
--- Return the argument if we have a saturated type family application
--- Why saturated? See (ATF4) in Note [Apartness and type families]
-isSatFamApp (TyConApp tc tys)
- | isTypeFamilyTyCon tc
- && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated
- = Just (tc, tys)
-isSatFamApp _ = Nothing
-
---------------------------------
uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM ()
-- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy
@@ -1876,7 +1866,7 @@ uVarOrFam env ty1 ty2 kco
| otherwise -> maybeApart MARTypeFamily
-- Check for equality F tys1 ~ F tys2
- | Just (tc2, tys2) <- isSatFamApp ty2
+ | Just (tc2, tys2) <- isSatTyFamApp ty2
, tc1 == tc2
= go_fam_fam tc1 tys1 tys2 kco
=====================================
compiler/GHC/HsToCore/Pmc/Solver.hs
=====================================
@@ -363,7 +363,7 @@ pmTopNormaliseType (TySt _ inert) typ = {-# SCC "pmTopNormaliseType" #-} do
eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)
is_closed_or_data_family :: Type -> Bool
- is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty
+ is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyApp ty
-- For efficiency, represent both lists as difference lists.
-- comb performs the concatenation, for both lists.
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -547,15 +547,7 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name))
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalTyName name
- ; when (isDataConName name && not (isKindName name)) $
- -- Any use of a promoted data constructor name (that is not
- -- specifically exempted by isKindName) is illegal without the use
- -- of DataKinds. See Note [Checking for DataKinds] in
- -- GHC.Tc.Validity.
- checkDataKinds env tv
- ; when (isDataConName name && not (isPromoted ip)) $
- -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.
- addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
+ ; checkPromotedDataConName env tv Prefix ip name
; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) }
rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
@@ -567,8 +559,7 @@ rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2'
- ; when (isDataConName op_name && not (isPromoted prom)) $
- addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
+ ; checkPromotedDataConName env ty Infix prom op_name
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
rnHsTyKi env (HsParTy _ ty)
@@ -1670,6 +1661,30 @@ checkDataKinds env thing
type_or_kind | isRnKindLevel env = KindLevel
| otherwise = TypeLevel
+-- | If a 'Name' is that of a promoted data constructor, perform various
+-- validity checks on it.
+checkPromotedDataConName ::
+ RnTyKiEnv ->
+ -- | The type that the 'Name' belongs to. This will always be an 'HsTyVar'
+ -- (for 'Prefix' names) or an 'HsOpTy' (for 'Infix' names).
+ HsType GhcPs ->
+ -- | Whether the type is written 'Prefix' or 'Infix'.
+ LexicalFixity ->
+ -- | Whether the name was written with an explicit promotion tick or not.
+ PromotionFlag ->
+ -- | The name to check.
+ Name ->
+ TcM ()
+checkPromotedDataConName env ty fixity ip name
+ = do when (isDataConName name && not (isKindName name)) $
+ -- Any use of a promoted data constructor name (that is not
+ -- specifically exempted by isKindName) is illegal without the use
+ -- of DataKinds. See Note [Checking for DataKinds] in
+ -- GHC.Tc.Validity.
+ checkDataKinds env ty
+ when (isDataConName name && not (isPromoted ip)) $
+ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor fixity name)
+
warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll doc (L loc tvb) used_names =
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -50,6 +50,8 @@ import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Error
+import GHC.Types.Unique( hasKey )
+import GHC.Builtin.Names( errorMessageTypeErrorFamKey )
import qualified GHC.Types.Unique.Map as UM
import GHC.Unit.Module
@@ -439,10 +441,9 @@ reportBadTelescope _ _ skol_info skols
-- See Note [Constraints to ignore].
ignoreConstraint :: Ct -> Bool
ignoreConstraint ct
- | AssocFamPatOrigin <- ctOrigin ct
- = True
- | otherwise
- = False
+ = case ctOrigin ct of
+ AssocFamPatOrigin -> True -- See (CIG1)
+ _ -> False
-- | Makes an error item from a constraint, calculating whether or not
-- the item should be suppressed. See Note [Wanteds rewrite Wanteds]
@@ -538,7 +539,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs
-- See Note [Suppressing confusing errors]
- ; let (suppressed_items, items0) = partition suppress tidy_items
+ ; let (suppressed_items, items0) = partition suppressItem tidy_items
; traceTc "reportWanteds suppressed:" (ppr suppressed_items)
; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0
@@ -546,7 +547,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-- any of the first batch failed, or if the enclosing context
-- says to suppress
; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
- ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1
+ ; (_, leftovers) <- tryReporters ctxt2 report2 items1
; massertPpr (null leftovers)
(text "The following unsolved Wanted constraints \
\have not been reported to the user:"
@@ -557,12 +558,16 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-- wanted insoluble here; but do suppress inner insolubles
-- if there's a *given* insoluble here (= inaccessible code)
- -- Only now, if there are no errors, do we report suppressed ones
- -- See Note [Suppressing confusing errors]
- -- We don't need to update the context further because of the
- -- whenNoErrs guard
- ; whenNoErrs $
- do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items
+ -- If there are no other errors to report, report suppressed errors.
+ -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors
+ -- we might have reported warnings only from `items0`, but we still want to
+ -- suppress the `suppressed_items`.
+ ; when (null items0) $
+ do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2)
+ suppressed_items
+ -- ctxt_for_insols: the suppressed errors can be Int~Bool, which
+ -- will have made the incoming `ctxt` be True; don't make that suppress
+ -- the Int~Bool error!
; massertPpr (null more_leftovers) (ppr more_leftovers) } }
where
env = cec_tidy ctxt
@@ -585,29 +590,49 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
DE_Multiplicity mult_co loc
-> (es1, es2, es3, (mult_co, loc):es4)
- -- See Note [Suppressing confusing errors]
- suppress :: ErrorItem -> Bool
- suppress item
- | Wanted <- ei_flavour item
- = is_ww_fundep_item item
- | otherwise
- = False
-
-- report1: ones that should *not* be suppressed by
-- an insoluble somewhere else in the tree
-- It's crucial that anything that is considered insoluble
-- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise
-- we might suppress its error message, and proceed on past
-- type checking to get a Lint error later
- report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter)
- -- (Handles TypeError and Unsatisfiable)
+ report1 = [ -- We put implicit lifting errors first, because are solid errors
+ -- See "Implicit lifting" in GHC.Tc.Gen.Splice
+ -- Note [Lifecycle of an untyped splice, and PendingRnSplice]
+ ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter)
- , ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter)
+ -- Next, solid equality errors
, given_eq_spec
, ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
, ("skolem eq1", very_wrong, True, mkSkolReporter)
, ("FixedRuntimeRep", is_FRR, True, mkGroupReporter mkFRRErr)
, ("skolem eq2", skolem_eq, True, mkSkolReporter)
+
+ -- Next, family applications like (F t1 t2 ~ rigid_ty)
+ -- These could be solved by doing a type-family reduction for F
+ -- which probably means fixing a unfication variable in t1/t2
+ -- See discussion in #26255, where F had an injectivity annotation,
+ -- and we had [W] F alpha ~ "foo"
+ -- The real error is that the "foo" should be "bar", because there is
+ -- type instance F Int = "bar"
+ -- We could additionally filter on the injectivty annotation,
+ -- but currently we don't.
+ , ("fam app", is_fam_app_eq, True, mkGroupReporter mkEqErr)
+
+ -- Put custom type errors after solid equality errors. In #26255 we
+ -- had a custom error (T <= F alpha) which was suppressing a far more
+ -- informative (K Int ~ [K alpha]). That mismatch between K and [] is
+ -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence
+ -- perhaps be able to solve T <= F alpha, by reducing F Int.
+ --
+ -- Custom errors should precede "non-tv eq", becuase if we have
+ -- () ~ TypeError blah
+ -- we want to report it as a custom error, /not/ as a mis-match
+ -- between TypeError and ()!
+ , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter)
+ -- (Handles TypeError and Unsatisfiable)
+
+ -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar
, ("non-tv eq", non_tv_eq, True, mkSkolReporter)
-- The only remaining equalities are alpha ~ ty,
@@ -617,6 +642,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-- See Note [Equalities with heterogeneous kinds] in GHC.Tc.Solver.Equality
, ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr)
, ("Other eqs", is_equality, True, mkGroupReporter mkEqErr)
+
]
-- report2: we suppress these if there are insolubles elsewhere in the tree
@@ -625,11 +651,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
, ("Dicts", is_dict, False, mkGroupReporter mkDictErr)
, ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ]
- -- report3: suppressed errors should be reported as categorized by either report1
- -- or report2. Keep this in sync with the suppress function above
- report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)
- ]
-
-- rigid_nom_eq, rigid_nom_tv_eq,
is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool
@@ -650,6 +671,13 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-- Representation-polymorphism errors, to be reported using mkFRRErr.
is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item
+ -- Things like (F t1 t2 ~N Maybe s)
+ -- But only proper type families; not (TypeError t1 t2 ~N blah)
+ is_fam_app_eq _ (EqPred NomEq ty1 ty2)
+ | Just (tc,_) <- isSatTyFamApp ty1
+ = not (tc `hasKey` errorMessageTypeErrorFamKey) && isRigidTy ty2
+ is_fam_app_eq _ _ = False
+
-- Things like (a ~N b) or (a ~N F Bool)
skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
skolem_eq _ _ = False
@@ -690,10 +718,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
is_qc _ (ForAllPred {}) = True
is_qc _ _ = False
- -- See situation (1) of Note [Suppressing confusing errors]
- is_ww_fundep item _ = is_ww_fundep_item item
- is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin
-
given_eq_spec -- See Note [Given errors]
| has_gadt_match_here
= ("insoluble1a", is_given_eq, True, mkGivenErrorReporter)
@@ -719,6 +743,16 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
= has_gadt_match implics
---------------
+suppressItem :: ErrorItem -> Bool
+ -- See Note [Suppressing confusing errors]
+suppressItem item
+ | Wanted <- ei_flavour item
+ , let orig = errorItemOrigin item
+ = isWantedSuperclassOrigin orig -- See (SCE1)
+ || isWantedWantedFunDepOrigin orig -- See (SCE2)
+ | otherwise
+ = False
+
isSkolemTy :: TcLevel -> Type -> Bool
-- The type is a skolem tyvar
isSkolemTy tc_lvl ty
@@ -743,7 +777,23 @@ If there are any other errors to report, at all, we want to suppress these.
Which errors (only 1 case right now):
-1) Errors which arise from the interaction of two Wanted fun-dep constraints.
+(SCE1) Superclasses of Wanteds. These are generated on in case they trigger functional
+ dependencies. If such a constraint is unsolved, then its "parent" constraint must
+ also be unsolved, and is much more informative to the user. Example (#26255):
+ class (MinVersion <= F era) => Era era where { ... }
+ f :: forall era. EraFamily era -> IO ()
+ f = ..blah... -- [W] Era era
+ Here we have simply omitted "Era era =>" from f's type. But we'll end up with
+ /two/ Wanted constraints:
+ [W] d1 : Era era
+ [W] d2 : MinVersion <= F era -- Superclass of d1
+ We definitely want to report d1 and not d2! Happily it's easy to filter out those
+ superclass-Wanteds, becuase their Origin betrays them.
+
+ See test T18851 for an example of how it is (just, barely) possible for the /only/
+ errors to be superclass-of-Wanted constraints.
+
+(SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints.
Example:
class C a b | a -> b where
@@ -786,7 +836,7 @@ they will remain unfilled, and might have been used to rewrite another constrain
Currently, the constraints to ignore are:
-1) Constraints generated in order to unify associated type instance parameters
+(CIG1) Constraints generated in order to unify associated type instance parameters
with class parameters. Here are two illustrative examples:
class C (a :: k) where
@@ -814,6 +864,9 @@ Currently, the constraints to ignore are:
If there is any trouble, checkValidFamInst bleats, aborting compilation.
+(Note: Aug 25: this seems a rather tricky corner;
+ c.f. Note [Suppressing confusing errors])
+
Note [Implementation of Unsatisfiable constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-u…)
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -2059,6 +2059,7 @@ isRigidTy ty
| Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal
| Just {} <- tcSplitAppTy_maybe ty = True
| isForAllTy ty = True
+ | Just {} <- isLitTy ty = True
| otherwise = False
{-
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -11,6 +11,11 @@ for specific guidance on migrating programs to this release.
Language
~~~~~~~~
+- Fix a bug introduced in GHC 9.10 where GHC would erroneously accept infix uses
+ of promoted data constructors without enabling :extension:`DataKinds`. As a
+ result, you may need to enable :extension:`DataKinds` in code that did not
+ previously require it.
+
Compiler
~~~~~~~~
=====================================
rts/PrimOps.cmm
=====================================
@@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
gcptr trec, outer, arg;
trec = StgTSO_trec(CurrentTSO);
- if (running_alt_code != 1) {
- // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup
- // the nested transaction.
- // See Note [catchRetry# implementation]
- outer = StgTRecHeader_enclosing_trec(trec);
- (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
- if (r != 0) {
- // Succeeded in first branch
- StgTSO_trec(CurrentTSO) = outer;
- return (ret);
- } else {
- // Did not commit: abort and restart.
- StgTSO_trec(CurrentTSO) = outer;
- jump stg_abort();
- }
- }
- else {
- // nothing to do in the rhs code of catchRetry# lhs rhs, it's already
- // using the parent transaction (not a nested one).
- // See Note [catchRetry# implementation]
- return (ret);
+ outer = StgTRecHeader_enclosing_trec(trec);
+ (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
+ if (r != 0) {
+ // Succeeded (either first branch or second branch)
+ StgTSO_trec(CurrentTSO) = outer;
+ return (ret);
+ } else {
+ // Did not commit: abort and restart.
+ StgTSO_trec(CurrentTSO) = outer;
+ jump stg_abort();
}
}
@@ -1464,26 +1453,21 @@ retry_pop_stack:
outer = StgTRecHeader_enclosing_trec(trec);
if (frame_type == CATCH_RETRY_FRAME) {
- // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME
-
+ // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
+ ASSERT(outer != NO_TREC);
+ // Abort the transaction attempting the current branch
+ ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+ ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
- // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested
- // transaction. See Note [catchRetry# implementation]
-
- // check that we have a parent transaction
- ASSERT(outer != NO_TREC);
-
- // Abort the nested transaction
- ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
- ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
-
- // As we are retrying in the lhs code, we must now try the rhs code
- StgTSO_trec(CurrentTSO) = outer;
+ // Retry in the first branch: try the alternative
+ ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
+ StgTSO_trec(CurrentTSO) = trec;
StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
R1 = StgCatchRetryFrame_alt_code(frame);
jump stg_ap_v_fast [R1];
} else {
- // Retry in the rhs code: propagate the retry
+ // Retry in the alternative code: propagate the retry
+ StgTSO_trec(CurrentTSO) = outer;
Sp = Sp + SIZEOF_StgCatchRetryFrame;
goto retry_pop_stack;
}
=====================================
rts/RaiseAsync.c
=====================================
@@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
}
case CATCH_STM_FRAME:
- // CATCH_STM frame within an atomically block: abort the
+ case CATCH_RETRY_FRAME:
+ // CATCH frames within an atomically block: abort the
// inner transaction and continue. Eventually we will
// hit the outer transaction that will get frozen (see
// above).
@@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
{
StgTRecHeader *trec = tso -> trec;
StgTRecHeader *outer = trec -> enclosing_trec;
- debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
+ debugTraceCap(DEBUG_stm, cap,
+ "found atomically block delivering async exception");
stmAbortTransaction(cap, trec);
stmFreeAbortedTRec(cap, trec);
tso -> trec = outer;
break;
};
- case CATCH_RETRY_FRAME:
- // CATCH_RETY frame within an atomically block: if we're executing
- // the lhs code, abort the inner transaction and continue; if we're
- // executing thr rhs, continue (no nested transaction to abort. See
- // Note [catchRetry# implementation]). Eventually we will hit the
- // outer transaction that will get frozen (see above).
- //
- // As for the CATCH_STM_FRAME case above, we do not care
- // whether the transaction is valid or not because its
- // possible validity cannot have caused the exception
- // and will not be visible after the abort.
- {
- if (!((StgCatchRetryFrame *)frame) -> running_alt_code) {
- debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)");
- StgTRecHeader *trec = tso -> trec;
- StgTRecHeader *outer = trec -> enclosing_trec;
- stmAbortTransaction(cap, trec);
- stmFreeAbortedTRec(cap, trec);
- tso -> trec = outer;
- }
- else
- {
- debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)");
- }
- break;
- };
-
default:
// see Note [Update async masking state on unwind] in Schedule.c
if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {
=====================================
rts/STM.c
=====================================
@@ -1505,30 +1505,3 @@ void stmWriteTVar(Capability *cap,
}
/*......................................................................*/
-
-
-
-/*
-
-Note [catchRetry# implementation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-catchRetry# creates a nested transaction for its lhs:
-- if the lhs transaction succeeds:
- - the lhs transaction is committed
- - its read-variables are merged with those of the parent transaction
- - the rhs code is ignored
-- if the lhs transaction retries:
- - the lhs transaction is aborted
- - its read-variables are merged with those of the parent transaction
- - the rhs code is executed directly in the parent transaction (see #26028).
-
-So note that:
-- lhs code uses a nested transaction
-- rhs code doesn't use a nested transaction
-
-We have to take which case we're in into account (using the running_alt_code
-field of the catchRetry frame) in catchRetry's entry code, in retry#
-implementation, and also when an async exception is received (to cleanup the
-right number of transactions).
-
-*/
=====================================
testsuite/tests/lib/stm/T26028.hs deleted
=====================================
@@ -1,23 +0,0 @@
-module Main where
-
-import GHC.Conc
-
-forever :: IO String
-forever = delay 10 >> forever
-
-terminates :: IO String
-terminates = delay 1 >> pure "terminates"
-
-delay s = threadDelay (1000000 * s)
-
-async :: IO a -> IO (STM a)
-async a = do
- var <- atomically (newTVar Nothing)
- forkIO (a >>= atomically . writeTVar var . Just)
- pure (readTVar var >>= maybe retry pure)
-
-main :: IO ()
-main = do
- x <- mapM async $ terminates : replicate 50000 forever
- r <- atomically (foldr1 orElse x)
- print r
=====================================
testsuite/tests/lib/stm/T26028.stdout deleted
=====================================
@@ -1 +0,0 @@
-"terminates"
=====================================
testsuite/tests/lib/stm/all.T deleted
=====================================
@@ -1 +0,0 @@
-test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])
=====================================
testsuite/tests/typecheck/should_fail/T18851.hs
=====================================
@@ -33,3 +33,14 @@ f = show (undefined :: c)
-- blows up at run time once type checks
g :: String
g = f @A @B
+
+{-
+[W] Show c, Num int, C int A, C int B, C int c
+Superclasses
+ C_FD int ~ A
+ C_FD int ~ B
+ C_FD int ~ c
+-->
+ C_FD int ~ B
+ B ~ A
+-}
=====================================
testsuite/tests/typecheck/should_fail/T26255a.hs
=====================================
@@ -0,0 +1,47 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T26255a where
+
+import Data.Proxy
+import GHC.TypeLits
+
+type MinVersion = 1
+
+class
+ ( KnownNat (ProtVerLow era)
+ , MinVersion <= ProtVerLow era
+ , KnownSymbol (EraName era)
+ ) =>
+ Era era
+ where
+ type EraName era = (r :: Symbol) | r -> era
+
+ type ProtVerLow era :: Nat
+
+ eraName :: Proxy era -> String
+ eraName _ = symbolVal (Proxy :: Proxy (EraName era))
+
+data FooEra
+
+instance Era FooEra where
+ type EraName FooEra = "Foo"
+ type ProtVerLow FooEra = 1
+
+data BarEra
+
+instance Era BarEra where
+ type EraName BarEra = "Bar"
+ type ProtVerLow BarEra = 2
+
+fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era
+fromEraName _ = Proxy
+
+noCompileErrorMessage :: IO ()
+noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar")
+
+brokenCompileErrorMessage1 :: IO ()
+brokenCompileErrorMessage1 = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah")
+
=====================================
testsuite/tests/typecheck/should_fail/T26255a.stderr
=====================================
@@ -0,0 +1,10 @@
+T26255a.hs:46:51: error: [GHC-18872]
+ • Couldn't match type ‘EraName era0’ with ‘"Blah"’
+ arising from a use of ‘fromEraName’
+ The type variable ‘era0’ is ambiguous
+ • In the second argument of ‘($)’, namely
+ ‘fromEraName (Proxy :: Proxy "Blah")’
+ In the second argument of ‘($)’, namely
+ ‘eraName $ fromEraName (Proxy :: Proxy "Blah")’
+ In the expression:
+ putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah")
=====================================
testsuite/tests/typecheck/should_fail/T26255b.hs
=====================================
@@ -0,0 +1,46 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T26255b where
+
+import Data.Proxy
+import GHC.TypeLits
+
+type MinVersion = 1
+
+class
+ ( KnownNat (ProtVerLow era)
+ , MinVersion <= ProtVerLow era
+ , KnownSymbol (EraName era)
+ ) =>
+ Era era
+ where
+ type EraName era = (r :: Symbol) | r -> era
+
+ type ProtVerLow era :: Nat
+
+ eraName :: Proxy era -> String
+ eraName _ = symbolVal (Proxy :: Proxy (EraName era))
+
+data FooEra
+
+instance Era FooEra where
+ type EraName FooEra = "Foo"
+ type ProtVerLow FooEra = 1
+
+data BarEra
+
+instance Era BarEra where
+ type EraName BarEra = "Bar"
+ type ProtVerLow BarEra = 2
+
+fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era
+fromEraName _ = Proxy
+
+noCompileErrorMessage :: IO ()
+noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar")
+
+brokenCompileErrorMessage2 :: IO ()
+brokenCompileErrorMessage2 = putStrLn $ eraName $ head $ fromEraName (Proxy :: Proxy "Bar")
=====================================
testsuite/tests/typecheck/should_fail/T26255b.stderr
=====================================
@@ -0,0 +1,9 @@
+T26255b.hs:46:58: error: [GHC-83865]
+ • Couldn't match expected type: [Proxy era0]
+ with actual type: Proxy BarEra
+ • In the second argument of ‘($)’, namely
+ ‘fromEraName (Proxy :: Proxy "Bar")’
+ In the second argument of ‘($)’, namely
+ ‘head $ fromEraName (Proxy :: Proxy "Bar")’
+ In the second argument of ‘($)’, namely
+ ‘eraName $ head $ fromEraName (Proxy :: Proxy "Bar")’
=====================================
testsuite/tests/typecheck/should_fail/T26255c.hs
=====================================
@@ -0,0 +1,30 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T26255c where
+
+import Data.Kind
+import Data.Proxy
+import GHC.TypeLits
+
+type MinVersion = 1
+
+class
+ ( KnownNat (ProtVerLow era)
+ , MinVersion <= ProtVerLow era
+ ) =>
+ Era era
+ where
+ type ProtVerLow era :: Nat
+
+newtype EraFamily era = EraFamily Int
+
+class Era era => NewEra era where
+ eraFamilySize :: EraFamily era -> Int
+
+printEraFamilySize :: EraFamily era -> IO ()
+printEraFamilySize = print . eraFamilySize
=====================================
testsuite/tests/typecheck/should_fail/T26255c.stderr
=====================================
@@ -0,0 +1,11 @@
+T26255c.hs:30:30: error: [GHC-39999]
+ • No instance for ‘NewEra era’
+ arising from a use of ‘eraFamilySize’
+ Possible fix:
+ add (NewEra era) to the context of
+ the type signature for:
+ printEraFamilySize :: forall {k} (era :: k). EraFamily era -> IO ()
+ • In the second argument of ‘(.)’, namely ‘eraFamilySize’
+ In the expression: print . eraFamilySize
+ In an equation for ‘printEraFamilySize’:
+ printEraFamilySize = print . eraFamilySize
=====================================
testsuite/tests/typecheck/should_fail/T26318.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE NoDataKinds #-}
+module T26318 where
+
+class C1 l
+instance C1 (x : xs)
+
+class C2 l
+instance C2 (x ': xs)
+
+class C3 l
+instance C3 ((:) x xs)
+
+class C4 l
+instance C4 ('(:) x xs)
=====================================
testsuite/tests/typecheck/should_fail/T26318.stderr
=====================================
@@ -0,0 +1,20 @@
+T26318.hs:6:16: error: [GHC-68567]
+ Illegal type: ‘x : xs’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
+T26318.hs:9:16: error: [GHC-68567]
+ Illegal type: ‘x ': xs’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
+T26318.hs:12:14: error: [GHC-68567]
+ Illegal type: ‘(:)’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
+T26318.hs:15:14: error: [GHC-68567]
+ Illegal type: ‘'(:)’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
=====================================
testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr
=====================================
@@ -1,3 +1,7 @@
+UnliftedNewtypesFamilyKindFail2.hs:12:1: error: [GHC-83865]
+ • Expected a type, but ‘F 5’ has kind ‘5’
+ • In the newtype family instance declaration for ‘F’
+
UnliftedNewtypesFamilyKindFail2.hs:12:20: error: [GHC-83865]
• Expected a type,
but ‘5’ has kind
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -741,3 +741,6 @@ test('T25325', normal, compile_fail, [''])
test('T25004', normal, compile_fail, [''])
test('T25004k', normal, compile_fail, [''])
test('T26004', normal, compile_fail, [''])
+test('T26318', normal, compile_fail, [''])
+test('T26255a', normal, compile_fail, [''])
+test('T26255b', normal, compile_fail, [''])
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1105,6 +1105,20 @@ class DyLD {
if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) {
this.rts_init();
delete this.rts_init;
+
+ // At this point the RTS symbols in linear memory are fixed
+ // and constructors are run, especially the one in JSFFI.c
+ // that does GHC RTS initialization for any code that links
+ // JSFFI.o. Luckily no Haskell computation or gc has taken
+ // place yet, so we must set keepCAFs=1 right now! Otherwise,
+ // any BCO created by later TH splice or ghci expression may
+ // refer to any CAF that's not reachable from GC roots (here
+ // our only entry point is defaultServer) and the CAF could
+ // have been GC'ed! (#26106)
+ //
+ // We call it here instead of in RTS C code, since we only
+ // want keepCAFs=1 for ghci, not user code.
+ this.exportFuncs.setKeepCAFs();
}
init();
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7477a4ab24e6727634a129a031a29f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7477a4ab24e6727634a129a031a29f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-apporv-Oct24] 5 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Apoorv Ingle (＠ani) 26 Aug '25
by Apoorv Ingle (＠ani) 26 Aug '25
26 Aug '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 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.
- - - - -
34f4884d by Apoorv Ingle at 2025-08-26T11:24:19-05:00
This commit:
- Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr`
Calls `setInGeneratedCode` everytime the typechecker goes over an `XExpr`
- Kills `VACtxt` (and its associated VAExpansion and VACall) datatype, it is subsumed by simply a SrcSpan.
- Kills the function `addHeadCtxt` as it is now mearly setting a location
- The function `tcValArgs` does its own argument number management
- Makes `splitHsApps` not look through `XExpr`
- `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr`
- Removes location information from `OrigPat` payload
- Removes special case of tcBody from `tcLambdaMatches`
- Removes special case of `dsExpr` for `ExpandedThingTc`
- Moves `setQLInstLevel` inside `tcInstFun`
- Rename `HsThingRn` to `SrcCodeCtxt`
- Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack`
- Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin`
- Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression
- Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax
- Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo`
- Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr`
- Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span`
Notes added [Error Context Stack]
Notes updated Note [Expanding HsDo with XXExprGhcRn]
-------------------------
Metric Decrease:
T9020
-------------------------
- - - - -
66 changed files:
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- + compiler/GHC/Tc/Gen/App.hs-boot
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- docs/users_guide/9.16.1-notes.rst
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/STM.c
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- − testsuite/tests/lib/stm/T26028.hs
- − testsuite/tests/lib/stm/T26028.stdout
- − testsuite/tests/lib/stm/all.T
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/polykinds/T13393.stderr
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/rep-poly/RepPolyDoBind.stderr
- testsuite/tests/rep-poly/RepPolyDoBody1.stderr
- testsuite/tests/rep-poly/RepPolyDoBody2.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/typecheck/should_compile/T14590.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T24064.stderr
- + testsuite/tests/typecheck/should_fail/T26318.hs
- + testsuite/tests/typecheck/should_fail/T26318.stderr
- testsuite/tests/typecheck/should_fail/T3323.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail102.stderr
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail168.stderr
- testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
- 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/c4b833d240488b2211774ce7f352a1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4b833d240488b2211774ce7f352a1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
26 Aug '25
Apoorv Ingle pushed new branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ani/kill-popErrCtxt
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26255 at Glasgow Haskell Compiler / GHC
Commits:
7477a4ab by Simon Peyton Jones at 2025-08-26T17:21:47+01:00
Wibble
- - - - -
1 changed file:
- compiler/GHC/Tc/Errors.hs
Changes:
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -558,10 +558,11 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-- wanted insoluble here; but do suppress inner insolubles
-- if there's a *given* insoluble here (= inaccessible code)
- -- Only now, if there are no errors, do we report suppressed ones
- -- See Note [Suppressing confusing errors]. We don't need to update
- -- the context further because of the whenNoErrs guard
- ; whenNoErrs $
+ -- If there are no other errors to report, report suppressed errors.
+ -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors
+ -- we might have reported warnings only from `items0`, but we still want to
+ -- suppress the `suppressed_items`.
+ ; when (null items0) $
do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2)
suppressed_items
-- ctxt_for_insols: the suppressed errors can be Int~Bool, which
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7477a4ab24e6727634a129a031a29f7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7477a4ab24e6727634a129a031a29f7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26346] 6 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Simon Peyton Jones (＠simonpj) 26 Aug '25
by Simon Peyton Jones (＠simonpj) 26 Aug '25
26 Aug '25
Simon Peyton Jones pushed to branch wip/T26346 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.
- - - - -
279a6fd3 by Simon Peyton Jones at 2025-08-26T17:17:15+01:00
Comments only
- - - - -
40276cda by Simon Peyton Jones at 2025-08-26T17:17:42+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 (ATF13) in Note [Apartness and type families]
- - - - -
17 changed files:
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- docs/users_guide/9.16.1-notes.rst
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/STM.c
- − testsuite/tests/lib/stm/T26028.hs
- − testsuite/tests/lib/stm/T26028.stdout
- − testsuite/tests/lib/stm/all.T
- + testsuite/tests/typecheck/should_compile/T26346.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/jsffi/dyld.mjs
Changes:
=====================================
compiler/GHC/Cmm/Dataflow/Label.hs
=====================================
@@ -83,6 +83,7 @@ import GHC.Data.Word64Map.Strict (Word64Map)
import qualified GHC.Data.Word64Map.Strict as M
import GHC.Data.TrieMap
+import Data.Coerce
import Data.Word (Word64)
@@ -164,7 +165,7 @@ setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s
{-# INLINE setElems #-}
setElems :: LabelSet -> [Label]
-setElems (LS s) = map mkHooplLabel (S.elems s)
+setElems (LS s) = coerce $ S.elems s
{-# INLINE setFromList #-}
setFromList :: [Label] -> LabelSet
@@ -272,7 +273,7 @@ mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m)
{-# INLINE mapToList #-}
mapToList :: LabelMap b -> [(Label, b)]
-mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m]
+mapToList (LM m) = coerce $ M.toList m
{-# INLINE mapFromList #-}
mapFromList :: [(Label, v)] -> LabelMap v
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -245,16 +245,21 @@ give up on), but for /substitutivity/. If we have (F x x), we can see that (F x
can reduce to Double. So, it had better be the case that (F blah blah) can
reduce to Double, no matter what (blah) is!
-To achieve this, `go_fam` in `uVarOrFam` does this;
+To achieve this, `go` in `uVarOrFam` does this;
+
+* We maintain /two/ substitutions, not just one:
+ * um_tv_env: the regular substitution, mapping TyVar :-> Type
+ * um_fam_env: maps (TyCon,[Type]) :-> Type, where the LHS is a type-fam application
+ In effect, these constitute one substitution mapping
+ CanEqLHS :-> Types
* When we attempt to unify (G Float) ~ Int, we return MaybeApart..
- but we /also/ extend a "family substitution" [G Float :-> Int],
- in `um_fam_env`, alongside the regular [tyvar :-> type] substitution in
- `um_tv_env`. See the `BindMe` case of `go_fam` in `uVarOrFam`.
+ but we /also/ add a "family substitution" [G Float :-> Int],
+ to `um_fam_env`. See the `BindMe` case of `go` in `uVarOrFam`.
* When we later encounter (G Float) ~ Bool, we apply the family substitution,
very much as we apply the conventional [tyvar :-> type] substitution
- when we encounter a type variable. See the `lookupFamEnv` in `go_fam` in
+ when we encounter a type variable. See the `lookupFamEnv` in `go` in
`uVarOrFam`.
So (G Float ~ Bool) becomes (Int ~ Bool) which is SurelyApart. Bingo.
@@ -329,7 +334,7 @@ Wrinkles
alternative path. So `noMatchableGivenDicts` must return False;
so `mightMatchLater` must return False; so when um_bind_fam_fun returns
`DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`. See
- `go_fam` in `uVarOrFam`
+ `go` in `uVarOrFam`
(ATF6) When /matching/ can we ever have a type-family application on the LHS, in
the template? You might think not, because type-class-instance and
@@ -426,6 +431,26 @@ Wrinkles
(ATF12) There is a horrid exception for the injectivity check. See (UR1) in
in Note [Specification of unification].
+(ATF13) Consider unifying
+ [F a, F Int, Int] ~ [Bool, Char, a]
+ Working left to right you might think we would build the mapping
+ F a :-> Bool
+ F Int :-> Char
+ Now we discover that `a` unifies with `Int`. So really these two lists are Apart
+ because F Int can't be both Bool and Char.
+
+ But that is very tricky! Perhaps whenever we unify a type variable we should
+ run it over the domain and (maybe range) of the type-family mapping too?
+ Sigh.
+
+ For we make no such attempt. The um_fam_env has only pre-substituted types.
+ Fortunately, while this may make use say MaybeApart when we could say SurelyApart,
+ it has no effect on the correctness of unification: if we return Unifiable, it
+ really is Unifiable.
+
+(ATF14) We have to be careful about the occurs check.
+ See Note [The occurs check in the Core unifier]
+
SIDE NOTE. The paper "Closed type families with overlapping equations"
http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-e…
tries to achieve the same effect with a standard yes/no unifier, by "flattening"
@@ -1776,16 +1801,11 @@ uVarOrFam env ty1 ty2 kco
-- E.g. a ~ F p q
-- Starts with: go a (F p q)
-- if `a` not bindable, swap to: go (F p q) a
- go swapped substs (TyVarLHS tv1) ty2 kco
- = go_tv swapped substs tv1 ty2 kco
-
- go swapped substs (TyFamLHS tc tys) ty2 kco
- = go_fam swapped substs tc tys ty2 kco
-----------------------------
- -- go_tv: LHS is a type variable
+ -- LHS is a type variable
-- The sequence of tests is very similar to go_tv
- go_tv swapped substs tv1 ty2 kco
+ go swapped substs lhs@(TyVarLHS tv1) ty2 kco
| Just ty1' <- lookupVarEnv (um_tv_env substs) tv1'
= -- We already have a substitution for tv1
if | um_unif env -> unify_ty env ty1' ty2 kco
@@ -1837,7 +1857,6 @@ uVarOrFam env ty1 ty2 kco
where
tv1' = umRnOccL env tv1
ty2_fvs = tyCoVarsOfType ty2
- rhs_fvs = ty2_fvs `unionVarSet` tyCoVarsOfCo kco
rhs = ty2 `mkCastTy` mkSymCo kco
tv1_is_bindable | not (tv1' `elemVarSet` um_foralls env)
-- tv1' is not forall-bound, but tv1 can still differ
@@ -1848,16 +1867,15 @@ uVarOrFam env ty1 ty2 kco
| otherwise
= False
- occurs_check = um_unif env &&
- occursCheck (um_tv_env substs) tv1 rhs_fvs
+ occurs_check = um_unif env && uOccursCheck substs lhs rhs
-- Occurs check, only when unifying
-- see Note [Infinitary substitutions]
- -- Make sure you include `kco` in rhs_tvs #14846
+ -- Make sure you include `kco` in rhs #14846
-----------------------------
- -- go_fam: LHS is a saturated type-family application
+ -- LHS is a saturated type-family application
-- Invariant: ty2 is not a TyVarTy
- go_fam swapped substs tc1 tys1 ty2 kco
+ go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco
-- If we are under a forall, just give up and return MaybeApart
-- see (ATF3) in Note [Apartness and type families]
| not (isEmptyVarSet (um_foralls env))
@@ -1883,9 +1901,10 @@ uVarOrFam env ty1 ty2 kco
-- Now check if we can bind the (F tys) to the RHS
-- This can happen even when matching: see (ATF7)
| BindMe <- um_bind_fam_fun env tc1 tys1 rhs
- = -- ToDo: do we need an occurs check here?
- do { extendFamEnv tc1 tys1 rhs
- ; maybeApart MARTypeFamily }
+ = if uOccursCheck substs lhs rhs
+ then maybeApart MARInfinite
+ else do { extendFamEnv tc1 tys1 rhs -- We don't substitue tys1; see (ATF13)
+ ; maybeApart MARTypeFamily }
-- Swap in case of (F a b) ~ (G c d e)
-- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e)
@@ -1939,17 +1958,67 @@ uVarOrFam env ty1 ty2 kco
rhs2 = mkTyConApp tc tys1 `mkCastTy` kco
-occursCheck :: TvSubstEnv -> TyVar -> TyCoVarSet -> Bool
-occursCheck env tv1 tvs
- = anyVarSet bad tvs
+uOccursCheck :: UMState -> CanEqLHS -> Type -> Bool
+-- See Note [The occurs check in the Core unifier] and (ATF13)
+uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty
+ = go emptyVarSet ty
where
- bad tv | Just ty <- lookupVarEnv env tv
- = anyVarSet bad (tyCoVarsOfType ty)
- | otherwise
- = tv == tv1
+ go :: TyCoVarSet -- Bound by enclosing foralls
+ -> Type -> Bool
+ go bvs ty | Just ty' <- coreView ty = go bvs ty'
+ go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv
+ = go bvs ty'
+ | TyVarLHS tv' <- lhs, tv==tv'
+ = True
+ | otherwise
+ = go bvs (tyVarKind tv)
+ go bvs (AppTy ty1 ty2) = go bvs ty1 || go bvs ty2
+ go _ (LitTy {}) = False
+ go bvs (FunTy _ w arg res) = go bvs w || go bvs arg || go bvs res
+ go bvs (TyConApp tc tys) = go_tc bvs tc tys
+
+ go bvs (ForAllTy (Bndr tv _) ty)
+ = go bvs (tyVarKind tv) ||
+ (case lhs of
+ TyVarLHS tv' | tv==tv' -> False -- Shadowing
+ | otherwise -> go (bvs `extendVarSet` tv) ty
+ TyFamLHS {} -> False) -- Lookups don't happen under a forall
+
+ go bvs (CastTy ty _co) = go bvs ty -- ToDo: should we worry about `co`?
+ go _ (CoercionTy _co) = False -- ToDo: should we worry about `co`?
+
+ go_tc bvs tc tys
+ | isTypeFamilyTyCon tc
+ , Just ty' <- lookupFamEnv fam_env tc (take arity tys)
+ = go bvs ty' || any (go bvs) (drop arity tys)
+
+ | TyFamLHS tc' tys' <- lhs
+ , tc == tc'
+ , tys `lengthAtLeast` arity -- Saturated, or over-saturated
+ , and (zipWith tcEqType tys tys')
+ = True
+
+ | otherwise
+ = any (go bvs) tys
+ where
+ arity = tyConArity tc
-{- Note [Unifying coercion-foralls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [The occurs check in the Core unifier]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The unifier applies both substitutions (um_tv_env and um_fam_env) as it goes,
+so we'll get an infinite loop if we have, for example
+ um_tv_env: a :-> F b -- (1)
+ um_fam_env F b :-> a -- (2)
+
+So (uOccursCheck substs lhs ty) returns True iff extending `substs` with `lhs :-> ty`
+could lead to a loop. That is, could there by a type `s` such that
+ applySubsts( (substs + lhs:->ty), s ) is infinite
+
+It's vital that we do both at once: we might have (1) already and add (2);
+or we might have (2) already and add (1).
+
+Note [Unifying coercion-foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we try to unify (forall cv. t1) ~ (forall cv. t2).
See Note [ForAllTy] in GHC.Core.TyCo.Rep.
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -547,15 +547,7 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name))
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalTyName name
- ; when (isDataConName name && not (isKindName name)) $
- -- Any use of a promoted data constructor name (that is not
- -- specifically exempted by isKindName) is illegal without the use
- -- of DataKinds. See Note [Checking for DataKinds] in
- -- GHC.Tc.Validity.
- checkDataKinds env tv
- ; when (isDataConName name && not (isPromoted ip)) $
- -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.
- addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
+ ; checkPromotedDataConName env tv Prefix ip name
; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) }
rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
@@ -567,8 +559,7 @@ rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2'
- ; when (isDataConName op_name && not (isPromoted prom)) $
- addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
+ ; checkPromotedDataConName env ty Infix prom op_name
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
rnHsTyKi env (HsParTy _ ty)
@@ -1670,6 +1661,30 @@ checkDataKinds env thing
type_or_kind | isRnKindLevel env = KindLevel
| otherwise = TypeLevel
+-- | If a 'Name' is that of a promoted data constructor, perform various
+-- validity checks on it.
+checkPromotedDataConName ::
+ RnTyKiEnv ->
+ -- | The type that the 'Name' belongs to. This will always be an 'HsTyVar'
+ -- (for 'Prefix' names) or an 'HsOpTy' (for 'Infix' names).
+ HsType GhcPs ->
+ -- | Whether the type is written 'Prefix' or 'Infix'.
+ LexicalFixity ->
+ -- | Whether the name was written with an explicit promotion tick or not.
+ PromotionFlag ->
+ -- | The name to check.
+ Name ->
+ TcM ()
+checkPromotedDataConName env ty fixity ip name
+ = do when (isDataConName name && not (isKindName name)) $
+ -- Any use of a promoted data constructor name (that is not
+ -- specifically exempted by isKindName) is illegal without the use
+ -- of DataKinds. See Note [Checking for DataKinds] in
+ -- GHC.Tc.Validity.
+ checkDataKinds env ty
+ when (isDataConName name && not (isPromoted ip)) $
+ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor fixity name)
+
warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
=> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll doc (L loc tvb) used_names =
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -3342,8 +3342,9 @@ mapCheck f xs
-- | Options describing how to deal with a type equality
-- in the eager unifier. See 'checkTyEqRhs'
data TyEqFlags m a
- -- | LHS is a type family application; we are not unifying.
- = TEFTyFam
+ = -- | TFTyFam: LHS is a type family application
+ -- Invariant: we are not unifying; see `notUnifying_TEFTask`
+ TEFTyFam
{ tefTyFam_occursCheck :: CheckTyEqProblem
-- ^ The 'CheckTyEqProblem' to report for occurs-check failures
-- (soluble or insoluble)
@@ -3352,7 +3353,8 @@ data TyEqFlags m a
, tef_fam_app :: TyEqFamApp m a
-- ^ How to deal with type family applications
}
- -- | LHS is a 'TyVar'.
+
+ -- | TEFTyVar: LHS is a 'TyVar'.
| TEFTyVar
-- NB: this constructor does not actually store a 'TyVar', in order to
-- support being called from 'makeTypeConcrete' (which works as if we
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -11,6 +11,11 @@ for specific guidance on migrating programs to this release.
Language
~~~~~~~~
+- Fix a bug introduced in GHC 9.10 where GHC would erroneously accept infix uses
+ of promoted data constructors without enabling :extension:`DataKinds`. As a
+ result, you may need to enable :extension:`DataKinds` in code that did not
+ previously require it.
+
Compiler
~~~~~~~~
=====================================
rts/PrimOps.cmm
=====================================
@@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
gcptr trec, outer, arg;
trec = StgTSO_trec(CurrentTSO);
- if (running_alt_code != 1) {
- // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup
- // the nested transaction.
- // See Note [catchRetry# implementation]
- outer = StgTRecHeader_enclosing_trec(trec);
- (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
- if (r != 0) {
- // Succeeded in first branch
- StgTSO_trec(CurrentTSO) = outer;
- return (ret);
- } else {
- // Did not commit: abort and restart.
- StgTSO_trec(CurrentTSO) = outer;
- jump stg_abort();
- }
- }
- else {
- // nothing to do in the rhs code of catchRetry# lhs rhs, it's already
- // using the parent transaction (not a nested one).
- // See Note [catchRetry# implementation]
- return (ret);
+ outer = StgTRecHeader_enclosing_trec(trec);
+ (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
+ if (r != 0) {
+ // Succeeded (either first branch or second branch)
+ StgTSO_trec(CurrentTSO) = outer;
+ return (ret);
+ } else {
+ // Did not commit: abort and restart.
+ StgTSO_trec(CurrentTSO) = outer;
+ jump stg_abort();
}
}
@@ -1464,26 +1453,21 @@ retry_pop_stack:
outer = StgTRecHeader_enclosing_trec(trec);
if (frame_type == CATCH_RETRY_FRAME) {
- // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME
-
+ // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
+ ASSERT(outer != NO_TREC);
+ // Abort the transaction attempting the current branch
+ ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+ ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
- // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested
- // transaction. See Note [catchRetry# implementation]
-
- // check that we have a parent transaction
- ASSERT(outer != NO_TREC);
-
- // Abort the nested transaction
- ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
- ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
-
- // As we are retrying in the lhs code, we must now try the rhs code
- StgTSO_trec(CurrentTSO) = outer;
+ // Retry in the first branch: try the alternative
+ ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
+ StgTSO_trec(CurrentTSO) = trec;
StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
R1 = StgCatchRetryFrame_alt_code(frame);
jump stg_ap_v_fast [R1];
} else {
- // Retry in the rhs code: propagate the retry
+ // Retry in the alternative code: propagate the retry
+ StgTSO_trec(CurrentTSO) = outer;
Sp = Sp + SIZEOF_StgCatchRetryFrame;
goto retry_pop_stack;
}
=====================================
rts/RaiseAsync.c
=====================================
@@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
}
case CATCH_STM_FRAME:
- // CATCH_STM frame within an atomically block: abort the
+ case CATCH_RETRY_FRAME:
+ // CATCH frames within an atomically block: abort the
// inner transaction and continue. Eventually we will
// hit the outer transaction that will get frozen (see
// above).
@@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
{
StgTRecHeader *trec = tso -> trec;
StgTRecHeader *outer = trec -> enclosing_trec;
- debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
+ debugTraceCap(DEBUG_stm, cap,
+ "found atomically block delivering async exception");
stmAbortTransaction(cap, trec);
stmFreeAbortedTRec(cap, trec);
tso -> trec = outer;
break;
};
- case CATCH_RETRY_FRAME:
- // CATCH_RETY frame within an atomically block: if we're executing
- // the lhs code, abort the inner transaction and continue; if we're
- // executing thr rhs, continue (no nested transaction to abort. See
- // Note [catchRetry# implementation]). Eventually we will hit the
- // outer transaction that will get frozen (see above).
- //
- // As for the CATCH_STM_FRAME case above, we do not care
- // whether the transaction is valid or not because its
- // possible validity cannot have caused the exception
- // and will not be visible after the abort.
- {
- if (!((StgCatchRetryFrame *)frame) -> running_alt_code) {
- debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)");
- StgTRecHeader *trec = tso -> trec;
- StgTRecHeader *outer = trec -> enclosing_trec;
- stmAbortTransaction(cap, trec);
- stmFreeAbortedTRec(cap, trec);
- tso -> trec = outer;
- }
- else
- {
- debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)");
- }
- break;
- };
-
default:
// see Note [Update async masking state on unwind] in Schedule.c
if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {
=====================================
rts/STM.c
=====================================
@@ -1505,30 +1505,3 @@ void stmWriteTVar(Capability *cap,
}
/*......................................................................*/
-
-
-
-/*
-
-Note [catchRetry# implementation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-catchRetry# creates a nested transaction for its lhs:
-- if the lhs transaction succeeds:
- - the lhs transaction is committed
- - its read-variables are merged with those of the parent transaction
- - the rhs code is ignored
-- if the lhs transaction retries:
- - the lhs transaction is aborted
- - its read-variables are merged with those of the parent transaction
- - the rhs code is executed directly in the parent transaction (see #26028).
-
-So note that:
-- lhs code uses a nested transaction
-- rhs code doesn't use a nested transaction
-
-We have to take which case we're in into account (using the running_alt_code
-field of the catchRetry frame) in catchRetry's entry code, in retry#
-implementation, and also when an async exception is received (to cleanup the
-right number of transactions).
-
-*/
=====================================
testsuite/tests/lib/stm/T26028.hs deleted
=====================================
@@ -1,23 +0,0 @@
-module Main where
-
-import GHC.Conc
-
-forever :: IO String
-forever = delay 10 >> forever
-
-terminates :: IO String
-terminates = delay 1 >> pure "terminates"
-
-delay s = threadDelay (1000000 * s)
-
-async :: IO a -> IO (STM a)
-async a = do
- var <- atomically (newTVar Nothing)
- forkIO (a >>= atomically . writeTVar var . Just)
- pure (readTVar var >>= maybe retry pure)
-
-main :: IO ()
-main = do
- x <- mapM async $ terminates : replicate 50000 forever
- r <- atomically (foldr1 orElse x)
- print r
=====================================
testsuite/tests/lib/stm/T26028.stdout deleted
=====================================
@@ -1 +0,0 @@
-"terminates"
=====================================
testsuite/tests/lib/stm/all.T deleted
=====================================
@@ -1 +0,0 @@
-test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])
=====================================
testsuite/tests/typecheck/should_compile/T26346.hs
=====================================
@@ -0,0 +1,103 @@
+{-# LANGUAGE GHC2024 #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T26346 (warble) where
+
+import Data.Kind (Type)
+import Data.Type.Equality ((:~:)(..))
+
+type Nat :: Type
+data Nat = Z | S Nat
+
+type SNat :: Nat -> Type
+data SNat n where
+ SZ :: SNat Z
+ SS :: SNat n -> SNat (S n)
+
+type NatPlus :: Nat -> Nat -> Nat
+type family NatPlus a b where
+ NatPlus Z b = b
+ NatPlus (S a) b = S (NatPlus a b)
+
+sNatPlus ::
+ forall (a :: Nat) (b :: Nat).
+ SNat a ->
+ SNat b ->
+ SNat (NatPlus a b)
+sNatPlus SZ b = b
+sNatPlus (SS a) b = SS (sNatPlus a b)
+
+data Bin
+ = Zero
+ | Even Bin
+ | Odd Bin
+
+type SBin :: Bin -> Type
+data SBin b where
+ SZero :: SBin Zero
+ SEven :: SBin n -> SBin (Even n)
+ SOdd :: SBin n -> SBin (Odd n)
+
+type Incr :: Bin -> Bin
+type family Incr b where
+ Incr Zero = Odd Zero -- 0 + 1 = (2*0) + 1
+ Incr (Even n) = Odd n -- 2n + 1
+ Incr (Odd n) = Even (Incr n) -- (2n + 1) + 1 = 2*(n + 1)
+
+type BinToNat :: Bin -> Nat
+type family BinToNat b where
+ BinToNat Zero = Z
+ BinToNat (Even n) = NatPlus (BinToNat n) (BinToNat n)
+ BinToNat (Odd n) = S (NatPlus (BinToNat n) (BinToNat n))
+
+sBinToNat ::
+ forall (b :: Bin).
+ SBin b ->
+ SNat (BinToNat b)
+sBinToNat SZero = SZ
+sBinToNat (SEven n) = sNatPlus (sBinToNat n) (sBinToNat n)
+sBinToNat (SOdd n) = SS (sNatPlus (sBinToNat n) (sBinToNat n))
+
+warble ::
+ forall (b :: Bin).
+ SBin b ->
+ BinToNat (Incr b) :~: S (BinToNat b)
+warble SZero = Refl
+warble (SEven {}) = Refl
+warble (SOdd sb) | Refl <- warble sb
+ , Refl <- plusComm sbn (SS sbn)
+ = Refl
+ where
+ sbn = sBinToNat sb
+
+ plus0R ::
+ forall (n :: Nat).
+ SNat n ->
+ NatPlus n Z :~: n
+ plus0R SZ = Refl
+ plus0R (SS sn)
+ | Refl <- plus0R sn
+ = Refl
+
+ plusSnR ::
+ forall (n :: Nat) (m :: Nat).
+ SNat n ->
+ SNat m ->
+ NatPlus n (S m) :~: S (NatPlus n m)
+ plusSnR SZ _ = Refl
+ plusSnR (SS sn) sm
+ | Refl <- plusSnR sn sm
+ = Refl
+
+ plusComm ::
+ forall (n :: Nat) (m :: Nat).
+ SNat n ->
+ SNat m ->
+ NatPlus n m :~: NatPlus m n
+ plusComm SZ sm
+ | Refl <- plus0R sm
+ = Refl
+ plusComm (SS sn) sm
+ | Refl <- plusComm sn sm
+ , Refl <- plusSnR sm sn
+ = Refl
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -945,3 +945,4 @@ test('T25992', normal, compile, [''])
test('T14010', normal, compile, [''])
test('T26256a', normal, compile, [''])
test('T25992a', normal, compile, [''])
+test('T26346', normal, compile, [''])
=====================================
testsuite/tests/typecheck/should_fail/T26318.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE NoDataKinds #-}
+module T26318 where
+
+class C1 l
+instance C1 (x : xs)
+
+class C2 l
+instance C2 (x ': xs)
+
+class C3 l
+instance C3 ((:) x xs)
+
+class C4 l
+instance C4 ('(:) x xs)
=====================================
testsuite/tests/typecheck/should_fail/T26318.stderr
=====================================
@@ -0,0 +1,20 @@
+T26318.hs:6:16: error: [GHC-68567]
+ Illegal type: ‘x : xs’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
+T26318.hs:9:16: error: [GHC-68567]
+ Illegal type: ‘x ': xs’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
+T26318.hs:12:14: error: [GHC-68567]
+ Illegal type: ‘(:)’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
+T26318.hs:15:14: error: [GHC-68567]
+ Illegal type: ‘'(:)’
+ Suggested fix:
+ Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
+
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -741,3 +741,4 @@ test('T25325', normal, compile_fail, [''])
test('T25004', normal, compile_fail, [''])
test('T25004k', normal, compile_fail, [''])
test('T26004', normal, compile_fail, [''])
+test('T26318', normal, compile_fail, [''])
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1105,6 +1105,20 @@ class DyLD {
if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) {
this.rts_init();
delete this.rts_init;
+
+ // At this point the RTS symbols in linear memory are fixed
+ // and constructors are run, especially the one in JSFFI.c
+ // that does GHC RTS initialization for any code that links
+ // JSFFI.o. Luckily no Haskell computation or gc has taken
+ // place yet, so we must set keepCAFs=1 right now! Otherwise,
+ // any BCO created by later TH splice or ghci expression may
+ // refer to any CAF that's not reachable from GC roots (here
+ // our only entry point is defaultServer) and the CAF could
+ // have been GC'ed! (#26106)
+ //
+ // We call it here instead of in RTS C code, since we only
+ // want keepCAFs=1 for ghci, not user code.
+ this.exportFuncs.setKeepCAFs();
}
init();
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f24f9356b276205622cf05a46c81a7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f24f9356b276205622cf05a46c81a7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0