[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Move the `Text.Read` implementation into `base`
by Marge Bot (＠marge-bot) 12 May '26
by Marge Bot (＠marge-bot) 12 May '26
12 May '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8f2d501e by Wolfgang Jeltsch at 2026-05-12T05:27:43-04:00
Move the `Text.Read` implementation into `base`
- - - - -
1435c8ea by Vladislav Zavialov at 2026-05-12T05:27:44-04:00
EPA: Use AnnParen for tuples and sums
Summary of changes
* Do not use AnnParen in XListTy, replace it with EpToken "[" and "]"
* Specialise AnnParen to tuple/sums by dropping the AnnParensSquare
and keeping only AnnParens and AnnParensHash
* Use AnnParen in XExplicitTuple
* Use AnnParen in XExplicitTupleTy
* Use AnnParen in XTuplePat
* Use AnnParen in XExplicitSum (via AnnExplicitSum)
* Use AnnParen in XSumPat (via EpAnnSumPat)
This is a refactoring with no user-facing changes.
- - - - -
58771f54 by Duncan Coutts at 2026-05-12T05:27:45-04:00
Add minimal dlltool support to ghc-toolchain
The dlltool is a tool that can create dll import libraries from .def
files. These .def files list the exported symbols of dlls. Its somewhat
like gnu linker scripts, but more limited.
We will need dlltool to build the rts and ghc-internal libraries as DLLs
on Windows. The rts and ghc-internal libraries have a recursive
dependency on each other. Import libraries can be used to resolve
recursive dependencies between dlls. We will use an import library for
the rts when linking the ghc-internal library.
- - - - -
fd9ee45f by Duncan Coutts at 2026-05-12T05:27:45-04:00
Add minimal dlltool support into ./configure
Find dlltool, and hopefully support finding it within the bundled llvm
toolchain on windows.
- - - - -
99fd8a50 by Duncan Coutts at 2026-05-12T05:27:45-04:00
Update the default host and target files for dlltool support
- - - - -
d2581cff by Duncan Coutts at 2026-05-12T05:27:45-04:00
Add dlltool as a hadrian builder
Optional except on windows.
- - - - -
fb1a1a67 by Duncan Coutts at 2026-05-12T05:27:45-04:00
Update and generate libHSghc-internal.def from .def.in file
The only symbol that the rts imports from the ghc-internal package now
is init_ghc_hs_iface. So the rts only needs an import lib that defines
that one symbol.
Also, remove the libHSghc-prim.def because it is redundant. The rts no
longer imports anything from ghc-prim.
Keep libHSffi.def for now. We may yet need it once it is clear how
libffi is going to be built/used for ghc.
- - - - -
1374bc2b by Duncan Coutts at 2026-05-12T05:27:45-04:00
Add rule to build libHSghc-internal.dll.a and link into the rts
On windows only, with dynamic linking.
This is needed because on windows, all symbols in dlls must be resolved.
No dangling symbols allowed. References to external symbols must be
explicit. We resolve this with an import library. We create an import
library for ghc-internal, a .dll.a file. This is a static archive
containing .o files that define the symbols we need, and crucially have
".idata" sections that specifies the symbols the dll imports and from
where.
Note that we do not install this libHSghc-internal.dll.a, and it does
not need to list all the symbols exported by that package. We create a
special purpose import lib and only use it when linking the rts dll, so
it only has to list the symbols that the rts uses from ghc-internal
(which is exactly one symbol: init_ghc_hs_iface).
- - - - -
2282fa36 by Alice Rixte at 2026-05-12T05:27:53-04:00
Script for downloading and copying `base-exports` file
- - - - -
43 changed files:
- + changelog.d/ghc-api-epa-parens
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/cfg/default.host.target.in
- hadrian/cfg/default.target.in
- hadrian/src/Builder.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Rts.hs
- libraries/base/src/Data/Functor/Classes.hs
- libraries/base/src/Data/Functor/Compose.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/Text/Read.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs
- − libraries/ghc-internal/src/GHC/Internal/Text/Read.hs
- m4/find_llvm_prog.m4
- m4/fp_setup_windows_toolchain.m4
- m4/ghc_toolchain.m4
- m4/prep_target_file.m4
- rts/.gitignore
- + rts/win32/libHSghc-internal.def.in
- testsuite/tests/ghc-api/T25121_status.stdout
- + testsuite/tests/interface-stability/.gitignore
- testsuite/tests/interface-stability/README.mkd
- + testsuite/tests/interface-stability/download-base-exports.sh
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/th/T24111.stdout
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T21130.stderr
- utils/check-exact/ExactPrint.hs
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/272272d6e7c67e0012b95786362112…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/272272d6e7c67e0012b95786362112…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Move the `Text.Read` implementation into `base`
by Marge Bot (＠marge-bot) 12 May '26
by Marge Bot (＠marge-bot) 12 May '26
12 May '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fafc4d02 by Wolfgang Jeltsch at 2026-05-11T21:23:57-04:00
Move the `Text.Read` implementation into `base`
- - - - -
e56a6eb3 by Vladislav Zavialov at 2026-05-11T21:23:58-04:00
EPA: Use AnnParen for tuples and sums
Summary of changes
* Do not use AnnParen in XListTy, replace it with EpToken "[" and "]"
* Specialise AnnParen to tuple/sums by dropping the AnnParensSquare
and keeping only AnnParens and AnnParensHash
* Use AnnParen in XExplicitTuple
* Use AnnParen in XExplicitTupleTy
* Use AnnParen in XTuplePat
* Use AnnParen in XExplicitSum (via AnnExplicitSum)
* Use AnnParen in XSumPat (via EpAnnSumPat)
This is a refactoring with no user-facing changes.
- - - - -
268c1448 by Duncan Coutts at 2026-05-11T21:23:59-04:00
Add minimal dlltool support to ghc-toolchain
The dlltool is a tool that can create dll import libraries from .def
files. These .def files list the exported symbols of dlls. Its somewhat
like gnu linker scripts, but more limited.
We will need dlltool to build the rts and ghc-internal libraries as DLLs
on Windows. The rts and ghc-internal libraries have a recursive
dependency on each other. Import libraries can be used to resolve
recursive dependencies between dlls. We will use an import library for
the rts when linking the ghc-internal library.
- - - - -
ed76a32e by Duncan Coutts at 2026-05-11T21:23:59-04:00
Add minimal dlltool support into ./configure
Find dlltool, and hopefully support finding it within the bundled llvm
toolchain on windows.
- - - - -
48078a38 by Duncan Coutts at 2026-05-11T21:23:59-04:00
Update the default host and target files for dlltool support
- - - - -
ef5271fd by Duncan Coutts at 2026-05-11T21:23:59-04:00
Add dlltool as a hadrian builder
Optional except on windows.
- - - - -
303515c2 by Duncan Coutts at 2026-05-11T21:23:59-04:00
Update and generate libHSghc-internal.def from .def.in file
The only symbol that the rts imports from the ghc-internal package now
is init_ghc_hs_iface. So the rts only needs an import lib that defines
that one symbol.
Also, remove the libHSghc-prim.def because it is redundant. The rts no
longer imports anything from ghc-prim.
Keep libHSffi.def for now. We may yet need it once it is clear how
libffi is going to be built/used for ghc.
- - - - -
5db35660 by Duncan Coutts at 2026-05-11T21:23:59-04:00
Add rule to build libHSghc-internal.dll.a and link into the rts
On windows only, with dynamic linking.
This is needed because on windows, all symbols in dlls must be resolved.
No dangling symbols allowed. References to external symbols must be
explicit. We resolve this with an import library. We create an import
library for ghc-internal, a .dll.a file. This is a static archive
containing .o files that define the symbols we need, and crucially have
".idata" sections that specifies the symbols the dll imports and from
where.
Note that we do not install this libHSghc-internal.dll.a, and it does
not need to list all the symbols exported by that package. We create a
special purpose import lib and only use it when linking the rts dll, so
it only has to list the symbols that the rts uses from ghc-internal
(which is exactly one symbol: init_ghc_hs_iface).
- - - - -
272272d6 by Alice Rixte at 2026-05-11T21:24:08-04:00
Script for downloading and copying `base-exports` file
- - - - -
43 changed files:
- + changelog.d/ghc-api-epa-parens
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/cfg/default.host.target.in
- hadrian/cfg/default.target.in
- hadrian/src/Builder.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Rts.hs
- libraries/base/src/Data/Functor/Classes.hs
- libraries/base/src/Data/Functor/Compose.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/Text/Read.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs
- − libraries/ghc-internal/src/GHC/Internal/Text/Read.hs
- m4/find_llvm_prog.m4
- m4/fp_setup_windows_toolchain.m4
- m4/ghc_toolchain.m4
- m4/prep_target_file.m4
- rts/.gitignore
- + rts/win32/libHSghc-internal.def.in
- testsuite/tests/ghc-api/T25121_status.stdout
- + testsuite/tests/interface-stability/.gitignore
- testsuite/tests/interface-stability/README.mkd
- + testsuite/tests/interface-stability/download-base-exports.sh
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/th/T24111.stdout
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T21130.stderr
- utils/check-exact/ExactPrint.hs
- utils/ghc-toolchain/exe/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d8a6ac65f96d50882bda17ea0378eb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d8a6ac65f96d50882bda17ea0378eb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Move the `Text.Read` implementation into `base`
by Marge Bot (＠marge-bot) 11 May '26
by Marge Bot (＠marge-bot) 11 May '26
11 May '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e55d1e73 by Wolfgang Jeltsch at 2026-05-11T12:23:14-04:00
Move the `Text.Read` implementation into `base`
- - - - -
f127d6b8 by Vladislav Zavialov at 2026-05-11T12:23:15-04:00
EPA: Use AnnParen for tuples and sums
Summary of changes
* Do not use AnnParen in XListTy, replace it with EpToken "[" and "]"
* Specialise AnnParen to tuple/sums by dropping the AnnParensSquare
and keeping only AnnParens and AnnParensHash
* Use AnnParen in XExplicitTuple
* Use AnnParen in XExplicitTupleTy
* Use AnnParen in XTuplePat
* Use AnnParen in XExplicitSum (via AnnExplicitSum)
* Use AnnParen in XSumPat (via EpAnnSumPat)
This is a refactoring with no user-facing changes.
- - - - -
d8a6ac65 by Alice Rixte at 2026-05-11T12:23:23-04:00
Script for downloading and copying `base-exports` file
- - - - -
27 changed files:
- + changelog.d/ghc-api-epa-parens
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- libraries/base/src/Data/Functor/Classes.hs
- libraries/base/src/Data/Functor/Compose.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/Text/Read.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs
- − libraries/ghc-internal/src/GHC/Internal/Text/Read.hs
- testsuite/tests/ghc-api/T25121_status.stdout
- + testsuite/tests/interface-stability/.gitignore
- testsuite/tests/interface-stability/README.mkd
- + testsuite/tests/interface-stability/download-base-exports.sh
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/th/T24111.stdout
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T21130.stderr
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
changelog.d/ghc-api-epa-parens
=====================================
@@ -0,0 +1,12 @@
+section: ghc-lib
+synopsis: Use ``AnnParen`` for tuples and sums
+issues: #26969
+mrs: !15836
+
+description: {
+Do not use ``AnnParen`` in ``XListTy``, replacing it with ``EpToken "["`` and ``"]"``,
+and specialise it to tuples/sums by dropping the ``AnnParensSquare`` constructor,
+keeping only ``AnnParens`` and ``AnnParensHash``. Use ``AnnParen`` in ``XExplicitTuple``,
+``XExplicitTupleTy``, ``XTuplePat``, ``XExplicitSum`` (via ``AnnExplicitSum``), and
+``XSumPat`` (via ``EpAnnSumPat``).
+}
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -221,7 +221,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
NoBlankEpAnnotations -> parens (case ap of
(AnnParens o c) -> text "AnnParens" $$ vcat [showAstData' o, showAstData' c]
(AnnParensHash o c) -> text "AnnParensHash" $$ vcat [showAstData' o, showAstData' c]
- (AnnParensSquare o c) -> text "AnnParensSquare" $$ vcat [showAstData' o, showAstData' c]
)
annClassDecl :: AnnClassDecl -> SDoc
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -264,7 +264,7 @@ type instance XPar GhcPs = (EpToken "(", EpToken ")")
type instance XPar GhcRn = NoExtField
type instance XPar GhcTc = NoExtField
-type instance XExplicitTuple GhcPs = (EpaLocation, EpaLocation)
+type instance XExplicitTuple GhcPs = AnnParen
type instance XExplicitTuple GhcRn = NoExtField
type instance XExplicitTuple GhcTc = NoExtField
@@ -554,14 +554,13 @@ mkHsVarWithUserRdr rdr n = HsVar noExtField $
data AnnExplicitSum
= AnnExplicitSum {
- aesOpen :: EpaLocation,
+ aesParens :: AnnParen,
aesBarsBefore :: [EpToken "|"],
- aesBarsAfter :: [EpToken "|"],
- aesClose :: EpaLocation
+ aesBarsAfter :: [EpToken "|"]
} deriving Data
instance NoAnn AnnExplicitSum where
- noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn
+ noAnn = AnnExplicitSum noAnn noAnn noAnn
data AnnFieldLabel
= AnnFieldLabel {
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -113,7 +113,7 @@ type instance XListPat GhcRn = NoExtField
type instance XListPat GhcTc = Type
-- List element type, for use in hsPatType.
-type instance XTuplePat GhcPs = (EpaLocation, EpaLocation)
+type instance XTuplePat GhcPs = AnnParen
type instance XTuplePat GhcRn = NoExtField
type instance XTuplePat GhcTc = [Type]
@@ -263,13 +263,13 @@ discarded inside tcMatchPats, where we know if visible pattern retained or erase
-- API Annotations types
data EpAnnSumPat = EpAnnSumPat
- { sumPatParens :: (EpaLocation, EpaLocation)
+ { sumPatParens :: AnnParen
, sumPatVbarsBefore :: [EpToken "|"]
, sumPatVbarsAfter :: [EpToken "|"]
} deriving Data
instance NoAnn EpAnnSumPat where
- noAnn = EpAnnSumPat (noAnn, noAnn) [] []
+ noAnn = EpAnnSumPat noAnn [] []
-- ---------------------------------------------------------------------
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -445,7 +445,7 @@ type instance XQualTy (GhcPass _) = NoExtField
type instance XTyVar (GhcPass _) = EpToken "'"
type instance XAppTy (GhcPass _) = NoExtField
type instance XFunTy (GhcPass _) = NoExtField
-type instance XListTy (GhcPass _) = AnnParen
+type instance XListTy (GhcPass _) = (EpToken "[", EpToken "]")
type instance XTupleTy (GhcPass _) = AnnParen
type instance XSumTy (GhcPass _) = AnnParen
type instance XOpTy (GhcPass _) = NoExtField
@@ -470,7 +470,7 @@ type instance XExplicitListTy GhcPs = (EpToken "'", EpToken "[", EpToken "]")
type instance XExplicitListTy GhcRn = NoExtField
type instance XExplicitListTy GhcTc = Kind
-type instance XExplicitTupleTy GhcPs = (EpToken "'", EpToken "(", EpToken ")")
+type instance XExplicitTupleTy GhcPs = (EpToken "'", AnnParen)
type instance XExplicitTupleTy GhcRn = NoExtField
type instance XExplicitTupleTy GhcTc = [Kind]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2398,14 +2398,14 @@ atype :: { LHsType GhcPs }
| '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (epTok $1, epTok $3) $2) }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE '(' ')' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
- ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $3) IsPromoted []) }}
+ ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1, AnnParens (epTok $2) (epTok $3)) IsPromoted []) }}
| SIMPLEQUOTE gen_qcon {% amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted $2) }
| SIMPLEQUOTE sysdcon_nolist {% do { requireLTPuns PEP_QuoteDisambiguation $1 (reLoc $>)
; amsA' (sLL $1 $> $ HsTyVar (epTok $1) IsPromoted (L (getLoc $2) $ nameRdrName (dataConName (unLoc $2)))) }}
| SIMPLEQUOTE '(' ktype ',' comma_types1 ')'
{% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; h <- addTrailingCommaA $3 (epTok $4)
- ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1,epTok $2,epTok $6) IsPromoted (h : $5)) }}
+ ; amsA' (sLL $1 $> $ HsExplicitTupleTy (epTok $1, AnnParens (epTok $2) (epTok $6)) IsPromoted (h : $5)) }}
| '[' ']' {% withCombinedComments $1 $> (mkListSyntaxTy0 (epTok $1) (epTok $2)) }
| SIMPLEQUOTE '[' comma_types0 ']' {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>
; amsA' (sLL $1 $> $ HsExplicitListTy (epTok $1, epTok $2, epTok $4) IsPromoted $3) }}
@@ -3221,7 +3221,7 @@ aexp2 :: { ECP }
| '(' tup_exprs ')' { ECP $
$2 >>= \ $2 ->
mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2
- (glR $1,glR $3)}
+ (AnnParens (epTok $1) (epTok $3))}
| '(' orpats(exp2) ')' {% do
{ pat <- hintOrPats (sL1a $2 (OrPat NoExtField (unLoc $2)))
@@ -3237,11 +3237,11 @@ aexp2 :: { ECP }
| '(#' texp '#)' { ECP $
unECP $2 >>= \ $2 ->
mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])
- (glR $1,glR $3) }
+ (AnnParensHash (epTok $1) (epTok $3)) }
| '(#' tup_exprs '#)' { ECP $
$2 >>= \ $2 ->
mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2
- (glR $1,glR $3) }
+ (AnnParensHash (epTok $1) (epTok $3)) }
| '[' list ']' { ECP $ $2 (comb2 $1 $>) (glR $1,glR $3) }
| '_' { ECP $ mkHsWildCardPV (getLoc $1) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -552,12 +552,11 @@ data AnnListBrackets
-- Annotations for parenthesised elements, such as tuples, lists
-- ---------------------------------------------------------------------
--- | exact print annotation for an item having surrounding "brackets", such as
--- tuples or lists
+-- | exact print annotation for an item having parentheses, with or without
+-- the hash symbol, e.g. tuples, unboxed tuples, unboxed sums
data AnnParen
= AnnParens (EpToken "(") (EpToken ")") -- ^ '(', ')'
| AnnParensHash (EpToken "(#") (EpToken "#)") -- ^ '(#', '#)'
- | AnnParensSquare (EpToken "[") (EpToken "]") -- ^ '[', ']'
deriving Data
-- ---------------------------------------------------------------------
@@ -1219,7 +1218,6 @@ instance (Outputable e)
instance Outputable AnnParen where
ppr (AnnParens o c) = text "AnnParens" <+> ppr o <+> ppr c
ppr (AnnParensHash o c) = text "AnnParensHash" <+> ppr o <+> ppr c
- ppr (AnnParensSquare o c) = text "AnnParensSquare" <+> ppr o <+> ppr c
instance Outputable AnnListItem where
ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1228,17 +1228,11 @@ checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =
-- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure
-- downstream.
-- This converts them just like when they are parsed as types in the punned case.
- check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (q,o,c) _ ts))
- = punsAllowed >>= \case
- True -> unprocessed
- False -> do
- let
- (op, cp) = case q of
- EpTok ql -> ([EpTok ql], [c])
- _ -> ([o], [c])
- mkCTuple (oparens ++ op, cp ++ cparens, cs) ts
+ check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (_, AnnParens o c) NotPromoted ts))
+ = mkCTuple (oparens ++ [o], c : cparens, cs) ts
+
check (opi,cpi,csi) (L _lp1 (HsParTy (o,c) ty))
- -- to be sure HsParTy doesn't get into the way
+ -- to be sure HsParTy doesn't get in the way
= check (o:opi, c:cpi, csi) ty
-- No need for anns, returning original
@@ -1269,11 +1263,10 @@ checkContextExpr orig_expr@(L (EpAnn l _ cs) _) =
where
check :: ([EpToken "("],[EpToken ")"],EpAnnComments)
-> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs])
- check (oparens,cparens,cs) (L _ (ExplicitTuple (ap_open, ap_close) tup_args boxity))
+ check (oparens,cparens,cs) (L _ (ExplicitTuple (AnnParens open_tok close_tok) tup_args Boxed))
-- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be a context
- | isBoxed boxity
- , Just es <- tupArgsPresent_maybe tup_args
- = mkCTuple (oparens ++ [EpTok ap_open], EpTok ap_close : cparens, cs) es
+ | Just es <- tupArgsPresent_maybe tup_args
+ = mkCTuple (oparens ++ [open_tok], close_tok : cparens, cs) es
check (opi, cpi, csi) (L _ (HsPar (open_tok, close_tok) expr))
= check (opi ++ [open_tok], close_tok : cpi, csi) expr
check (oparens,cparens,cs) (L _ (HsVar _ (L (EpAnn _ (NameAnnOnly (NameParens open closed) []) _) name)))
@@ -1861,7 +1854,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
mkHsBangPatPV :: SrcSpan -> LocatedA b -> EpToken "!" -> PV (LocatedA b)
-- | Disambiguate tuple sections and unboxed sums
mkSumOrTuplePV
- :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> (EpaLocation, EpaLocation) -> PV (LocatedA b)
+ :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> AnnParen -> PV (LocatedA b)
-- | Disambiguate "type t" (embedded type)
mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate modifiers (%a)
@@ -3694,7 +3687,7 @@ hintBangPat span e = do
addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e
mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)
- -> (EpaLocation, EpaLocation)
+ -> AnnParen
-> PV (LHsExpr GhcPs)
-- Tuple
@@ -3709,15 +3702,15 @@ mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do
-- Sum
-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
-- return $ L l (ExplicitSum noExtField alt arity e)
-mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) (o, c) = do
- let an = AnnExplicitSum o barsp barsa c
+mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) anns = do
+ let an = AnnExplicitSum anns barsp barsa
!cs <- getCommentsFor (locA l)
return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e)
mkSumOrTupleExpr l Boxed a@Sum{} _ =
addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a
mkSumOrTuplePat
- :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> (EpaLocation, EpaLocation)
+ :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> AnnParen
-> PV (LocatedA (PatBuilder GhcPs))
-- Tuple
@@ -3843,7 +3836,7 @@ mkTupleSyntaxTy parOpen args parClose =
HsExplicitTupleTy annsKeyword NotPromoted args
annParen = AnnParens parOpen parClose
- annsKeyword = (NoEpTok, parOpen, parClose)
+ annsKeyword = (NoEpTok, annParen)
-- | Decide whether to parse tuple con syntax @(,)@ in a type as a
-- type or data constructor, based on the extension @ListTuplePuns@.
@@ -3895,7 +3888,7 @@ mkListSyntaxTy1 brkOpen t brkClose =
HsExplicitListTy annsKeyword NotPromoted [t]
annsKeyword = (NoEpTok, brkOpen, brkClose)
- annParen = AnnParensSquare brkOpen brkClose
+ annParen = (brkOpen, brkClose)
parseError :: HsExpr GhcPs
parseError = HsHole HoleError
=====================================
libraries/base/src/Data/Functor/Classes.hs
=====================================
@@ -85,7 +85,7 @@ import GHC.Internal.Read (expectP, list, paren, readField)
import GHC.Internal.Show (appPrec)
import GHC.Internal.Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec, pfail)
-import GHC.Internal.Text.Read (Read(..), parens, prec, step, reset)
+import Text.Read (Read(..), parens, prec, step, reset)
import GHC.Internal.Text.Read.Lex (Lexeme(..))
import GHC.Internal.Text.Show (showListWith)
import Prelude
=====================================
libraries/base/src/Data/Functor/Compose.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Internal.Data.Foldable (Foldable(..))
import GHC.Internal.Data.Monoid (Sum(..), All(..), Any(..), Product(..))
import GHC.Internal.Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
-import GHC.Internal.Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)
+import Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)
import Prelude
infixr 9 `Compose`
=====================================
libraries/base/src/Prelude.hs
=====================================
@@ -179,7 +179,7 @@ import GHC.Internal.Data.Tuple
import GHC.Internal.Base hiding ( foldr, mapM, sequence )
import GHC.Internal.Classes
import GHC.Internal.Err
-import GHC.Internal.Text.Read
+import Text.Read
import GHC.Internal.Enum
import GHC.Internal.Num
import GHC.Internal.Prim (seq)
=====================================
libraries/base/src/Text/Read.hs
=====================================
@@ -39,5 +39,84 @@ module Text.Read
readMaybe
) where
-import GHC.Internal.Text.Read
+import GHC.Err (errorWithoutStackTrace)
+import GHC.Read
+ (
+ ReadS,
+ Read (readsPrec, readList, readPrec, readListPrec),
+ lex,
+ readParen,
+ readListDefault,
+ lexP,
+ parens,
+ readListPrecDefault
+ )
+import Control.Monad (return)
+import Data.Function (id)
+import Data.Maybe (Maybe (Nothing, Just))
+import Data.Either (Either (Left, Right), either)
+import Data.String (String)
+import Text.Read.Lex (Lexeme (Char, String, Punc, Ident, Symbol, Number, EOF))
+import Text.ParserCombinators.ReadP (skipSpaces)
import Text.ParserCombinators.ReadPrec
+
+-- $setup
+-- >>> import Prelude
+
+------------------------------------------------------------------------
+-- utility functions
+
+-- | equivalent to 'readsPrec' with a precedence of 0.
+reads :: Read a => ReadS a
+reads = readsPrec minPrec
+
+-- | Parse a string using the 'Read' instance.
+-- Succeeds if there is exactly one valid result.
+-- A 'Left' value indicates a parse error.
+--
+-- >>> readEither "123" :: Either String Int
+-- Right 123
+--
+-- >>> readEither "hello" :: Either String Int
+-- Left "Prelude.read: no parse"
+--
+-- @since base-4.6.0.0
+readEither :: Read a => String -> Either String a
+readEither s =
+ case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
+ [x] -> Right x
+ [] -> Left "Prelude.read: no parse"
+ _ -> Left "Prelude.read: ambiguous parse"
+ where
+ read' =
+ do x <- readPrec
+ lift skipSpaces
+ return x
+
+-- | Parse a string using the 'Read' instance.
+-- Succeeds if there is exactly one valid result.
+--
+-- >>> readMaybe "123" :: Maybe Int
+-- Just 123
+--
+-- >>> readMaybe "hello" :: Maybe Int
+-- Nothing
+--
+-- @since base-4.6.0.0
+readMaybe :: Read a => String -> Maybe a
+readMaybe s = case readEither s of
+ Left _ -> Nothing
+ Right a -> Just a
+
+-- | The 'read' function reads input from a string, which must be
+-- completely consumed by the input process. 'read' fails with an 'error' if the
+-- parse is unsuccessful, and it is therefore discouraged from being used in
+-- real applications. Use 'readMaybe' or 'readEither' for safe alternatives.
+--
+-- >>> read "123" :: Int
+-- 123
+--
+-- >>> read "hello" :: Int
+-- *** Exception: Prelude.read: no parse
+read :: Read a => String -> a
+read s = either errorWithoutStackTrace id (readEither s)
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -329,7 +329,6 @@ Library
GHC.Internal.System.Posix.Types
GHC.Internal.Text.ParserCombinators.ReadP
GHC.Internal.Text.ParserCombinators.ReadPrec
- GHC.Internal.Text.Read
GHC.Internal.Text.Read.Lex
GHC.Internal.Text.Show
GHC.Internal.Type.Reflection
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs
=====================================
@@ -46,7 +46,7 @@ import GHC.Internal.IO.Encoding.Types
import qualified GHC.Internal.IO.Encoding.Iconv as Iconv
#else
import qualified GHC.Internal.IO.Encoding.CodePage as CodePage
-import GHC.Internal.Text.Read (reads)
+import GHC.Internal.Read (readsPrec)
#endif
import qualified GHC.Internal.IO.Encoding.Latin1 as Latin1
import qualified GHC.Internal.IO.Encoding.UTF8 as UTF8
@@ -319,7 +319,8 @@ mkTextEncoding' cfm enc =
_ | isAscii -> return (Latin1.mkAscii cfm)
_ | isLatin1 -> return (Latin1.mkLatin1_checked cfm)
#if defined(mingw32_HOST_OS)
- 'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp
+ 'C':'P':n | [(cp,"")] <- readsPrec 0 n -> return $ CodePage.mkCodePageEncoding cfm cp
+ -- 'readsPrec 0' is the same as 'reads', but 'reads' is only defined in @base@.
_ -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm)
#else
-- Otherwise, handle other encoding needs via iconv.
=====================================
libraries/ghc-internal/src/GHC/Internal/Text/Read.hs deleted
=====================================
@@ -1,115 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Internal.Text.Read
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries(a)haskell.org
--- Stability : provisional
--- Portability : non-portable (uses Text.ParserCombinators.ReadP)
---
--- Converting strings to values.
---
--- The "Text.Read" library is the canonical library to import for
--- 'Read'-class facilities. For GHC only, it offers an extended and much
--- improved 'Read' class, which constitutes a proposed alternative to the
--- Haskell 2010 'Read'. In particular, writing parsers is easier, and
--- the parsers are much more efficient.
---
------------------------------------------------------------------------------
-
-module GHC.Internal.Text.Read (
- -- * The 'Read' class
- Read(..),
- ReadS,
-
- -- * Haskell 2010 functions
- reads,
- read,
- readParen,
- lex,
-
- -- * New parsing functions
- module GHC.Internal.Text.ParserCombinators.ReadPrec,
- L.Lexeme(..),
- lexP,
- parens,
- readListDefault,
- readListPrecDefault,
- readEither,
- readMaybe
-
- ) where
-
-import GHC.Internal.Base (String, id, return)
-import GHC.Internal.Err (errorWithoutStackTrace)
-import GHC.Internal.Maybe (Maybe(..))
-import GHC.Internal.Read
-import GHC.Internal.Data.Either
-import GHC.Internal.Text.ParserCombinators.ReadP as P
-import GHC.Internal.Text.ParserCombinators.ReadPrec
-import qualified GHC.Internal.Text.Read.Lex as L
-
--- $setup
--- >>> import Prelude
-
-------------------------------------------------------------------------
--- utility functions
-
--- | equivalent to 'readsPrec' with a precedence of 0.
-reads :: Read a => ReadS a
-reads = readsPrec minPrec
-
--- | Parse a string using the 'Read' instance.
--- Succeeds if there is exactly one valid result.
--- A 'Left' value indicates a parse error.
---
--- >>> readEither "123" :: Either String Int
--- Right 123
---
--- >>> readEither "hello" :: Either String Int
--- Left "Prelude.read: no parse"
---
--- @since base-4.6.0.0
-readEither :: Read a => String -> Either String a
-readEither s =
- case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
- [x] -> Right x
- [] -> Left "Prelude.read: no parse"
- _ -> Left "Prelude.read: ambiguous parse"
- where
- read' =
- do x <- readPrec
- lift P.skipSpaces
- return x
-
--- | Parse a string using the 'Read' instance.
--- Succeeds if there is exactly one valid result.
---
--- >>> readMaybe "123" :: Maybe Int
--- Just 123
---
--- >>> readMaybe "hello" :: Maybe Int
--- Nothing
---
--- @since base-4.6.0.0
-readMaybe :: Read a => String -> Maybe a
-readMaybe s = case readEither s of
- Left _ -> Nothing
- Right a -> Just a
-
--- | The 'read' function reads input from a string, which must be
--- completely consumed by the input process. 'read' fails with an 'error' if the
--- parse is unsuccessful, and it is therefore discouraged from being used in
--- real applications. Use 'readMaybe' or 'readEither' for safe alternatives.
---
--- >>> read "123" :: Int
--- 123
---
--- >>> read "hello" :: Int
--- *** Exception: Prelude.read: no parse
-read :: Read a => String -> a
-read s = either errorWithoutStackTrace id (readEither s)
=====================================
testsuite/tests/ghc-api/T25121_status.stdout
=====================================
@@ -18,8 +18,8 @@ X(ExplicitList) mismatch
>>> AnnList ()
<<< ((EpToken "'"),(EpToken "["),(EpToken "]"))
X(ExplicitTuple) mismatch
- >>> ((EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment]),(EpaLocation' [GenLocated (EpaLocation' NoComments) EpaComment]))
- <<< ((EpToken "'"),(EpToken "("),(EpToken ")"))
+ >>> AnnParen
+ <<< ((EpToken "'"),AnnParen)
X(Hole) match = HoleKind
Extension fields @GhcRn
=====================================
testsuite/tests/interface-stability/.gitignore
=====================================
@@ -0,0 +1 @@
+download-base-exports
=====================================
testsuite/tests/interface-stability/README.mkd
=====================================
@@ -1,6 +1,6 @@
# Interface stability testing
-The tests in this directory verify that the interfaces of exposed by GHC's
+The tests in this directory verify that the interfaces exposed by GHC's
core libraries do not inadvertently change. They use the `utils/dump-decls`
utility to dump all exported declarations of all exposed modules for the
following packages:
@@ -27,7 +27,9 @@ The `base-exports` test in particular has rather platform-dependent output.
Consequently, updating its output can be a bit tricky. There are two ways by
which one can do this:
- * Extrapolation: The various platforms' `base-exports.stdout` files are
+#### Extrapolation
+
+The various platforms' `base-exports.stdout` files are
similar enough that one can often apply the same patch of one file to the
others. For instance:
```
@@ -40,8 +42,44 @@ which one can do this:
In the case of conflicts, increasing the fuzz factor (using `-F`) can be
quite effective.
- * Using CI: Each CI job produces a tarball, `unexpected-test-output.tar.gz`,
+#### Using CI
+
+Each CI job produces a tarball, `unexpected-test-output.tar.gz`,
which contains the output produced by the job's failing tests. Simply
- download this tarball and extracting the appropriate `base-exports.stdout-*`
+ download this tarball and extract the appropriate `base-exports.stdout-*`
files into this directory.
+Doing this by hand is of course very annoying. To make things faster, use the script in this folder called `download.base-exports.sh` :
+
+* Running for the first time
+ 1. Find the URL for downloading unexpected-test-output.tar.gz. To do so
+ * Go to the CI job page you want to download
+ * Click on "Browse"
+ * Find unexpected-test-output.tar.gz
+ * Right-click the download link then "Copy link" (Firefox)
+ 2. The URL should look like this :
+ `https://gitlab.haskell.org/ghc/ghc/-/jobs/2503744/artifacts/file/unexpected-test-output.tar.gz`
+ * the prefix is : `https://gitlab.haskell.org/ghc/ghc/-/jobs/`
+ * the job ID is : `2503744`
+ * and the suffix : `/artifacts/file/unexpected-test-output.tar.gz`
+ 3. The script prompts you with URL prefix and suffix.
+ 4. It will save a file to remember this, so you only need to do this once.
+ 5. If you need to change the URL, just edit the file `download-base-exports/url-unexpected-test-output` directly.
+
+* Downloading the artifacts
+ 1. Find all the job IDs you want to download. For this, just go to the jobs
+ page `https://gitlab.haskell.org/<YOUR-FORK>/ghc/-/jobs`
+ 2. Make sure you get all the artifacts. You need 3 of them.
+ To get all 3 CI jobs, the label `javascript` must be on the MR.
+ If you don't have the rights for adding these labels, ask.
+ 1. The `x86` CI job for darwin or linux : `base-exports.stdout`
+ 2. The `windows` job : `base-exports.stdout-mingw32`
+ 3. The `javascript` CI job :
+ `base-exports.stdout-javascript-unknown-ghcjs`
+ 3. Run the script with all the job IDs :
+ `./download-base-exports.sh 2502789 2502792 2502793`
+
+ Using a range downloads more artifacts than necessary, but is a
+ no-brainer:
+
+ `./download-base-exports.sh {2502789..2502795}`
=====================================
testsuite/tests/interface-stability/download-base-exports.sh
=====================================
@@ -0,0 +1,55 @@
+#!/usr/bin/env bash
+
+# See the README file in this folder for usage
+
+jobIDs=("$@")
+
+BASE_DIR_NAME=download-base-exports
+DL_DIR_NAME=dl
+BASE_DIR="$(dirname "$0")/$BASE_DIR_NAME"
+DL_DIR=$BASE_DIR/$DL_DIR_NAME
+URL_FILE="$BASE_DIR/url-unexpected-test-output"
+
+DEFAULT_PREFIX="https://gitlab.haskell.org/ghc/ghc/-/jobs/"
+DEFAULT_POSTFIX="/artifacts/raw/unexpected-test-output.tar.gz"
+
+mkdir -p "$BASE_DIR"
+
+# URL configuration for finding unexpected-test-output.tar.gz
+
+if [[ ! -f "$URL_FILE" ]]; then
+ echo "No URL for unexpected-test-output.tar.gz was found"
+
+ read -p "Enter job URL prefix [${DEFAULT_PREFIX}]: " inputPrefix
+ read -p "Enter job URL postfix [${DEFAULT_POSTFIX}]: " inputPostfix
+
+ urlPrefix="${inputPrefix:-$DEFAULT_PREFIX}"
+ urlPostfix="${inputPostfix:-$DEFAULT_POSTFIX}"
+
+ {
+ echo "urlPrefix=$urlPrefix"
+ echo "urlPostfix=$urlPostfix"
+ } > "$URL_FILE"
+else
+ source "$URL_FILE"
+fi
+
+mkdir -p $DL_DIR
+
+echo "urlPrefix: $urlPrefix"
+echo "jobIDs: $jobIDs"
+echo "urlPostfix: $urlPostfix"
+echo ""
+echo "Downloading unexpected-test-output.tar.gz for each job ..."
+
+# Download and copy base-exports* files
+
+for jobID in "${jobIDs[@]}"; do
+ unexpectedOutputUrl="$urlPrefix$jobID$urlPostfix"
+
+ wget -O "$DL_DIR/job$jobID.tar.gz" $unexpectedOutputUrl
+
+ mkdir -p "$DL_DIR/job$jobID"
+ tar -xzf "$DL_DIR/job$jobID.tar.gz" -C "$DL_DIR/job$jobID"
+ cp "$DL_DIR/job$jobID"/unexpected-test-output/testsuite/tests/interface-stability/base-exports* "$BASE_DIR/.."
+done
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -274,7 +274,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { DumpParsedAst.hs:9:16 }))
(EpTok
@@ -656,7 +656,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { DumpParsedAst.hs:10:27 }))
(EpTok
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -602,7 +602,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { DumpRenamedAst.hs:12:27 }))
(EpTok
@@ -710,7 +710,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { DumpRenamedAst.hs:11:16 }))
(EpTok
@@ -1930,7 +1930,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { DumpRenamedAst.hs:31:12 }))
(EpTok
@@ -1995,7 +1995,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { DumpRenamedAst.hs:32:10 }))
(EpTok
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -728,7 +728,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { KindSigs.hs:19:12 }))
(EpTok
@@ -1424,13 +1424,14 @@
(EpaComments
[]))
(HsExplicitTupleTy
- ((,,)
+ ((,)
(EpTok
(EpaSpan { KindSigs.hs:28:16 }))
- (EpTok
- (EpaSpan { KindSigs.hs:28:17 }))
- (EpTok
- (EpaSpan { KindSigs.hs:28:44 })))
+ (AnnParens
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:17 }))
+ (EpTok
+ (EpaSpan { KindSigs.hs:28:44 }))))
(IsPromoted)
[(L
(EpAnn
@@ -1508,7 +1509,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { KindSigs.hs:28:34 }))
(EpTok
=====================================
testsuite/tests/parser/should_compile/T20452.stderr
=====================================
@@ -458,7 +458,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { T20452.hs:8:57 }))
(EpTok
@@ -705,7 +705,7 @@
(EpaComments
[]))
(HsListTy
- (AnnParensSquare
+ ((,)
(EpTok
(EpaSpan { T20452.hs:9:57 }))
(EpTok
=====================================
testsuite/tests/th/T24111.stdout
=====================================
@@ -3,6 +3,6 @@ pattern (:+_0) :: GHC.Internal.Types.Int ->
(GHC.Internal.Types.Int, GHC.Internal.Types.Int)
pattern x_1 :+_0 y_2 = (x_1, y_2)
pattern A_0 :: GHC.Internal.Types.Int -> GHC.Internal.Base.String
-pattern A_0 n_1 <- (GHC.Internal.Text.Read.read -> n_1) where
+pattern A_0 n_1 <- (Text.Read.read -> n_1) where
A_0 0 = "hi"
A_0 1 = "bye"
=====================================
testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
=====================================
@@ -11,14 +11,13 @@ subsumption_sort_hole_fits.hs:2:5: warning: [GHC-88464] [-Wtyped-holes (in -Wdef
words :: String -> [String]
(imported from ‘Prelude’
(and originally defined in ‘GHC.Internal.Data.OldList’))
- read :: forall a. Read a => String -> a
- with read @[String]
- (imported from ‘Prelude’
- (and originally defined in ‘GHC.Internal.Text.Read’))
repeat :: forall a. a -> [a]
with repeat @String
(imported from ‘Prelude’
(and originally defined in ‘GHC.Internal.List’))
+ read :: forall a. Read a => String -> a
+ with read @[String]
+ (imported from ‘Prelude’ (and originally defined in ‘Text.Read’))
mempty :: forall a. Monoid a => a
with mempty @(String -> [String])
(imported from ‘Prelude’
=====================================
testsuite/tests/typecheck/should_fail/T21130.stderr
=====================================
@@ -6,6 +6,9 @@ T21130.hs:10:6: error: [GHC-88464]
In an equation for ‘x’: x = (_ f) :: Int
• Relevant bindings include x :: Int (bound at T21130.hs:10:1)
Valid hole fits include
+ read :: forall a. Read a => String -> a
+ with read @Int
+ (imported from ‘Prelude’ (and originally defined in ‘Text.Read’))
head :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> a
with head @Int
(imported from ‘Prelude’
@@ -14,10 +17,6 @@ T21130.hs:10:6: error: [GHC-88464]
with last @Int
(imported from ‘Prelude’
(and originally defined in ‘GHC.Internal.List’))
- read :: forall a. Read a => String -> a
- with read @Int
- (imported from ‘Prelude’
- (and originally defined in ‘GHC.Internal.Text.Read’))
T21130.hs:10:8: error: [GHC-39999]
• Ambiguous type variable ‘t0’ arising from a use of ‘f’
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -858,9 +858,6 @@ markParenO (AnnParens o c) = do
markParenO (AnnParensHash o c) = do
o' <- markEpToken o
return (AnnParensHash o' c)
-markParenO (AnnParensSquare o c) = do
- o' <- markEpToken o
- return (AnnParensSquare o' c)
markParenC :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen
markParenC (AnnParens o c) = do
@@ -869,9 +866,6 @@ markParenC (AnnParens o c) = do
markParenC (AnnParensHash o c) = do
c' <- markEpToken c
return (AnnParensHash o c')
-markParenC (AnnParensSquare o c) = do
- c' <- markEpToken c
- return (AnnParensSquare o c')
-- ---------------------------------------------------------------------
-- Bare bones Optics
@@ -1015,15 +1009,14 @@ lsnd k parent = fmap (\new -> (fst parent, new))
-- -------------------------------------
-- data AnnExplicitSum
-- = AnnExplicitSum {
--- aesOpen :: EpaLocation,
+-- aesParens :: AnnParen,
-- aesBarsBefore :: [EpToken "|"],
--- aesBarsAfter :: [EpToken "|"],
--- aesClose :: EpaLocation
+-- aesBarsAfter :: [EpToken "|"]
-- } deriving Data
-laesOpen :: Lens AnnExplicitSum EpaLocation
-laesOpen k parent = fmap (\new -> parent { aesOpen = new })
- (k (aesOpen parent))
+laesParens :: Lens AnnExplicitSum AnnParen
+laesParens k parent = fmap (\new -> parent { aesParens = new })
+ (k (aesParens parent))
laesBarsBefore :: Lens AnnExplicitSum [EpToken "|"]
laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new })
@@ -1033,10 +1026,6 @@ laesBarsAfter :: Lens AnnExplicitSum [EpToken "|"]
laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new })
(k (aesBarsAfter parent))
-laesClose :: Lens AnnExplicitSum EpaLocation
-laesClose k parent = fmap (\new -> parent { aesClose = new })
- (k (aesClose parent))
-
-- -------------------------------------
-- data AnnFieldLabel
-- = AnnFieldLabel {
@@ -1183,12 +1172,12 @@ lga_sep k parent = fmap (\new -> parent { ga_sep = new })
-- ---------------------------------------------------------------------
-- data EpAnnSumPat = EpAnnSumPat
--- { sumPatParens :: (EpaLocation, EpaLocation)
+-- { sumPatParens :: AnnParen
-- , sumPatVbarsBefore :: [EpToken "|"]
-- , sumPatVbarsAfter :: [EpToken "|"]
-- } deriving Data
-lsumPatParens :: Lens EpAnnSumPat (EpaLocation, EpaLocation)
+lsumPatParens :: Lens EpAnnSumPat AnnParen
lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new })
(k (sumPatParens parent))
@@ -2940,23 +2929,21 @@ instance ExactPrint (HsExpr GhcPs) where
expr' <- markAnnotated expr
return (SectionR an op' expr')
- exact (ExplicitTuple (o,c) args b) = do
- o0 <- if b == Boxed then printStringAtAA o "("
- else printStringAtAA o "(#"
+ exact (ExplicitTuple an args b) = do
+ an0 <- markOpeningParen an
args' <- mapM markAnnotated args
- c0 <- if b == Boxed then printStringAtAA c ")"
- else printStringAtAA c "#)"
+ an1 <- markClosingParen an0
debugM $ "ExplicitTuple done"
- return (ExplicitTuple (o0,c0) args' b)
+ return (ExplicitTuple an1 args' b)
exact (ExplicitSum an alt arity expr) = do
- an0 <- markLensFun an laesOpen (\loc -> printStringAtAA loc "(#")
+ an0 <- markLensFun an laesParens markOpeningParen
an1 <- markLensFun an0 laesBarsBefore (\locs -> mapM markEpToken locs)
expr' <- markAnnotated expr
an2 <- markLensFun an1 laesBarsAfter (\locs -> mapM markEpToken locs)
- an3 <- markLensFun an2 laesClose (\loc -> printStringAtAA loc "#)")
+ an3 <- markLensFun an2 laesParens markClosingParen
return (ExplicitSum an3 alt arity expr')
exact (HsCase an e alts) = do
@@ -3970,11 +3957,11 @@ instance ExactPrint (HsType GhcPs) where
(mult', ty1') <- markModifiedFunArrOf mult (markAnnotated ty1)
ty2' <- markAnnotated ty2
return (HsFunTy an mult' ty1' ty2')
- exact (HsListTy an tys) = do
- an0 <- markOpeningParen an
- tys' <- markAnnotated tys
- an1 <- markClosingParen an0
- return (HsListTy an1 tys')
+ exact (HsListTy (o,c) t) = do
+ o' <- markEpToken o
+ t' <- markAnnotated t
+ c' <- markEpToken c
+ return (HsListTy (o',c') t')
exact (HsTupleTy an con tys) = do
an0 <- markOpeningParen an
tys' <- markAnnotated tys
@@ -4026,14 +4013,14 @@ instance ExactPrint (HsType GhcPs) where
tys' <- markAnnotated tys
c' <- markEpToken c
return (HsExplicitListTy (sq',o',c') prom tys')
- exact (HsExplicitTupleTy (sq, o, c) prom tys) = do
+ exact (HsExplicitTupleTy (sq, an) prom tys) = do
sq' <- if (isPromoted prom)
then markEpToken sq
else return sq
- o' <- markEpToken o
+ an0 <- markOpeningParen an
tys' <- markAnnotated tys
- c' <- markEpToken c
- return (HsExplicitTupleTy (sq', o', c') prom tys')
+ an1 <- markClosingParen an0
+ return (HsExplicitTupleTy (sq', an1) prom tys')
exact (HsTyLit an lit) = do
lit' <- withPpr lit
return (HsTyLit an lit')
@@ -4713,22 +4700,18 @@ instance ExactPrint (Pat GhcPs) where
(an', pats') <- markAnnList' an (markAnnotated pats)
return (ListPat an' pats')
- exact (TuplePat (o,c) pats boxity) = do
- o0 <- case boxity of
- Boxed -> printStringAtAA o "("
- Unboxed -> printStringAtAA o "(#"
+ exact (TuplePat an pats boxity) = do
+ an0 <- markOpeningParen an
pats' <- markAnnotated pats
- c0 <- case boxity of
- Boxed -> printStringAtAA c ")"
- Unboxed -> printStringAtAA c "#)"
- return (TuplePat (o0,c0) pats' boxity)
+ an1 <- markClosingParen an0
+ return (TuplePat an1 pats' boxity)
exact (SumPat an pat alt arity) = do
- an0 <- markLensFun an (lsumPatParens . lfst) (\loc -> printStringAtAA loc "(#")
+ an0 <- markLensFun an lsumPatParens markOpeningParen
an1 <- markLensFun an0 lsumPatVbarsBefore (\locs -> mapM markEpToken locs)
pat' <- markAnnotated pat
an2 <- markLensFun an1 lsumPatVbarsAfter (\locs -> mapM markEpToken locs)
- an3 <- markLensFun an2 (lsumPatParens . lsnd) (\loc -> printStringAtAA loc "#)")
+ an3 <- markLensFun an2 lsumPatParens markClosingParen
return (SumPat an3 pat' alt arity)
exact (OrPat an pats) = do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ede968b68d4d509194460f07b80ef8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ede968b68d4d509194460f07b80ef8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
11 May '26
Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC
Commits:
6558f6c0 by Rodrigo Mesquita at 2026-05-11T16:31:36+01:00
tweaks
- - - - -
4 changed files:
- compiler/GHC/Builtin/WiredIn/Prim.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Tc/Module.hs
Changes:
=====================================
compiler/GHC/Builtin/WiredIn/Prim.hs
=====================================
@@ -879,7 +879,7 @@ generator never has to manipulate a value of type 'a :: TYPE rr'.
* error :: forall (rr::RuntimeRep) (a::TYPE rr). String -> a
Code generator never has to manipulate the return value.
-* unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair:
+* unsafeCoerce#, defined in Desugar.mkUnsafeCoercePrimPair:
Always inlined to be a no-op
unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -599,6 +599,8 @@ even if we need pure access; note that wiring-in an Id requires all
entities used in its definition *also* to be wired in, transitively
and recursively. This can be a huge pain. The little trick
documented here allows us to have the best of both worlds.
+(This has been improved with the new known-occ/keys work.
+ See Note [Overview of known entities] in GHC.Builtin.)
Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the
details.
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -616,7 +616,7 @@ dsLookupKnownOccId uniq = tyThingId <$> dsLookupKnownOccThing uniq
--------------------------------------
-- Lookups for known-key things
-dsLookupKnownKeyName :: KnownKey -> DsM Name
+dsLookupKnownKeyName :: HasDebugCallStack => KnownKey -> DsM Name
dsLookupKnownKeyName uniq
= do { rebindable_src <- dsGetKnownKeySource
; dsToIfL $
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2566,7 +2566,7 @@ tcGhciStmts stmts
-- We use Any rather than a dummy type such as () because of
-- the rules of unsafeCoerce#; see Unsafe/Coerce.hs for the details.
- ; AnId unsafe_coerce_id <- tcLookupKnownKeyGlobal unsafeCoercePrimIdKey
+ ; unsafe_coerce_id <- tcLookupKnownKeyId unsafeCoercePrimIdKey
-- We use unsafeCoerce# here because of (U11) in
-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6558f6c055728d16a246cca8b2b1671…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6558f6c055728d16a246cca8b2b1671…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/T27202] 4 commits: Fix regression T27202: `:load` and `:add` work in GHCi
by Hannes Siebenhandl (＠fendor) 11 May '26
by Hannes Siebenhandl (＠fendor) 11 May '26
11 May '26
Hannes Siebenhandl pushed to branch wip/fendor/T27202 at Glasgow Haskell Compiler / GHC
Commits:
f3653943 by fendor at 2026-05-08T14:48:57+02:00
Fix regression T27202: `:load` and `:add` work in GHCi
To fix the regression there are conceptually two major things that we
fix:
* We don't remove the `importDirs` from `interactive-session`
* When `:add`ing a module, we don't try to find them via PackageImports
* The PackageImport is wrong as we can't know the package-name at
this stage in ghc/UI.hs
What does it mean to not remove the `importDirs` from
`interactive-session`?
It means that, given some initial `DynFlags`, we will use those
`importDirs` in `interactive-session`.
The initial `DynFlags`, however, depend on how you initialise the GHC
session.
For a simple session, initialised by
ghc -isrc -this-unit-id main
It is simple, just use the `DynFlags` given on the cli.
Thus, `main` and `interactive-session` will have the same `DynFlags`,
except for the `homeUnitId` and `interactive-session` depends on `main`
by construction of the GHCi session.
What about a multiple home unit session, though?
ghc -unit @unit1 -unit @unit2
What are the `DynFlags` in this cli invocation? It shouldn't be either
`@unti1` nor `@unit2`, as the order shouldn't matter or any other
implicit condition.
For consistency, we decide that the initial `DynFlags` are the top
`DynFlags` on the cli, ignoring `-unit` flags.
Thus, in this example, there are no `importsDirs` regardless of what we
might find in `@unit1` and `@unit2`.
But in this invocation:
ghc -isrc -unit @unit1 -unit @unit2
The `interactive-session` will have the `importsDirs` `src`.
Note, `-isrc` will be inherited in `@unit1` and `@unit2`, so you need to
explicitly use `-i` to clear the `importsDirs`, in order to avoid
accidentally adding `src` as an import directory to all other home
units.
This fix has been made possible by the improvements introduced in
!15888, which avoids ambiguity when a home unit shares the `importsDirs`
with the `interactive-session`, on top of being much faster for multiple
home units.
Adds regression tests for T27202 for `:load`ing and `:add`ing modules
that are located in import directories.
- - - - -
8993f040 by fendor at 2026-05-11T16:41:07+02:00
Add test for package db stacks
- - - - -
c84f6279 by fendor at 2026-05-11T16:41:07+02:00
Regression test for package stacks
- - - - -
a8fda4d1 by fendor at 2026-05-11T17:14:51+02:00
Respect the package db stacks
- - - - -
66 changed files:
- + changelog.d/T27202
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- testsuite/tests/driver/fat-iface/fat014.stdout
- + testsuite/tests/ghci/prog-mhu006/Makefile
- + testsuite/tests/ghci/prog-mhu006/a/A.hs
- + testsuite/tests/ghci/prog-mhu006/all.T
- + testsuite/tests/ghci/prog-mhu006/b/B.hs
- + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.script
- + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.stdout
- + testsuite/tests/ghci/prog-mhu006/unitA
- + testsuite/tests/ghci/prog-mhu006/unitB
- testsuite/tests/ghci/prog018/prog018.stdout
- testsuite/tests/ghci/prog020/Makefile
- testsuite/tests/ghci/prog020/all.T
- testsuite/tests/ghci/prog020/ghci.prog020.script → testsuite/tests/ghci/prog020/ghci.prog020a.script
- testsuite/tests/ghci/prog020/ghci.prog020.stderr → testsuite/tests/ghci/prog020/ghci.prog020a.stderr
- testsuite/tests/ghci/prog020/ghci.prog020.stdout → testsuite/tests/ghci/prog020/ghci.prog020a.stdout
- + testsuite/tests/ghci/prog020/ghci.prog020b.script
- + testsuite/tests/ghci/prog020/ghci.prog020b.stderr
- + testsuite/tests/ghci/prog020/ghci.prog020b.stdout
- + testsuite/tests/ghci/prog023/Makefile
- + testsuite/tests/ghci/prog023/all.T
- + testsuite/tests/ghci/prog023/prog023a.script
- + testsuite/tests/ghci/prog023/prog023a.stdout
- + testsuite/tests/ghci/prog023/prog023b.script
- + testsuite/tests/ghci/prog023/prog023b.stdout
- + testsuite/tests/ghci/prog023/src/A.hs
- + testsuite/tests/ghci/prog024/Makefile
- + testsuite/tests/ghci/prog024/all.T
- + testsuite/tests/ghci/prog024/prog024a.script
- + testsuite/tests/ghci/prog024/prog024a.stdout
- + testsuite/tests/ghci/prog024/prog024b.script
- + testsuite/tests/ghci/prog024/prog024b.stdout
- + testsuite/tests/ghci/prog024/prog024c.script
- + testsuite/tests/ghci/prog024/prog024c.stderr
- + testsuite/tests/ghci/prog024/prog024c.stdout
- + testsuite/tests/ghci/prog024/prog024d.script
- + testsuite/tests/ghci/prog024/prog024d.stderr
- + testsuite/tests/ghci/prog024/prog024d.stdout
- + testsuite/tests/ghci/prog024/prog024e.script
- + testsuite/tests/ghci/prog024/prog024e.stdout
- + testsuite/tests/ghci/prog024/prog024f.script
- + testsuite/tests/ghci/prog024/prog024f.stdout
- + testsuite/tests/ghci/prog024/src/A.hs
- + testsuite/tests/ghci/prog024/src/B.hs
- + testsuite/tests/ghci/prog025/Makefile
- + testsuite/tests/ghci/prog025/a/A.hs
- + testsuite/tests/ghci/prog025/all.T
- + testsuite/tests/ghci/prog025/prog025a.script
- + testsuite/tests/ghci/prog025/prog025a.stdout
- + testsuite/tests/ghci/prog025/prog025b.script
- + testsuite/tests/ghci/prog025/prog025b.stdout
- + testsuite/tests/ghci/prog025/testpkg/Test.hs
- + testsuite/tests/ghci/prog025/testpkg/testpkg-0.1.0.0.pkg
- + testsuite/tests/ghci/prog025/testpkg/testpkg-0.2.0.0.pkg
- + testsuite/tests/ghci/prog025/unitA
- testsuite/tests/ghci/scripts/T13997.stdout
- testsuite/tests/ghci/scripts/T1914.stdout
- testsuite/tests/ghci/scripts/T20217.stdout
- testsuite/tests/ghci/scripts/T8042.stdout
- testsuite/tests/ghci/scripts/T8042recomp.stdout
- testsuite/tests/ghci/should_run/T10920.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7a69fb26d39bf8c0b3daef2a080e7f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7a69fb26d39bf8c0b3daef2a080e7f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-reinstallable-base2] 3 commits: drop unused
by Rodrigo Mesquita (＠alt-romes) 11 May '26
by Rodrigo Mesquita (＠alt-romes) 11 May '26
11 May '26
Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC
Commits:
3684a107 by Rodrigo Mesquita at 2026-05-11T13:49:39+01:00
drop unused
- - - - -
2ae79b84 by Rodrigo Mesquita at 2026-05-11T15:30:44+01:00
fix callstack error
Fixes
- - - - -
df000ae1 by Rodrigo Mesquita at 2026-05-11T15:31:21+01:00
Reapply "unsafeCoercePrimName"
This reverts commit 95664bfbe31baca788611380776de0c9c4d060b5.
- - - - -
7 changed files:
- compiler/GHC/Builtin/KnownKeys.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- libraries/base/src/GHC/Essentials.hs
- libraries/ghc-internal/src/GHC/Internal/Classes/IP.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/KnownKeys.hs
=====================================
@@ -271,6 +271,9 @@ knownKeyTable
, (mkDataOcc ":$$:", typeErrorVAppendDataConKey)
, (mkDataOcc "ShowType", typeErrorShowTypeDataConKey)
+ -- Unsafe coercion proofs
+ , (mkVarOcc "unsafeCoerce#", unsafeCoercePrimIdKey)
+
-- Plugins
, (mkTcOcc "Plugin", pluginTyConKey)
, (mkTcOcc "FrontendPlugin", frontendPluginTyConKey)
@@ -368,8 +371,6 @@ knownKeyTable
basicKnownKeyNames :: [Name] -- See Note [Known-key names]
basicKnownKeyNames
= [
- -- Unsafe coercion proofs
- unsafeCoercePrimName
]
@@ -416,25 +417,10 @@ bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key
-- End of ghc-bignum
---------------------------------
-
--- Class Typeable, and functions for constructing `Typeable` dictionaries
-starKindRepName, starArrStarKindRepName,
- starArrStarArrStarKindRepName, constraintKindRepName :: Name
--- This is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)
--- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable.
-starKindRepName = varQual gHC_TYPES (fsLit "krepStar") starKindRepKey
-starArrStarKindRepName = varQual gHC_TYPES (fsLit "krepStarArr") starArrStarKindRepKey
-starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krepStarArrStarArr") starArrStarArrStarKindRepKey
-constraintKindRepName = varQual gHC_TYPES (fsLit "krepConstraint") constraintKindRepKey
-
-- WithDict
withDictClassName :: Name
withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey
--- Unsafe coercion proofs
-unsafeCoercePrimName:: Name
-unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey
-
genericClassKeys :: [KnownKey]
genericClassKeys = [genClassKey, gen1ClassKey]
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -86,7 +86,6 @@ import GHC.Types.SourceFile
import GHC.Types.TypeEnv
import GHC.Types.Name
import GHC.Types.Name.Set
-import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.HpcInfo
@@ -99,6 +98,7 @@ import Data.List (partition)
import Data.IORef
import GHC.Iface.Make (mkRecompUsageInfo)
import GHC.Runtime.Interpreter (interpreterProfiled)
+import GHC.Types.Unique.FM
{-
************************************************************************
@@ -684,13 +684,14 @@ patchMagicDefns pairs
-- optimization: check whether we're in a magic module before looking
-- at all the ids
= do { this_mod <- getModule
+ ; magicDefnModules <- mkMagicDefnModules
; if this_mod `elemModuleSet` magicDefnModules
then traverse patchMagicDefn pairs
else return pairs }
patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr)
patchMagicDefn orig_pair@(orig_id, orig_rhs)
- | Just mk_magic_pair <- lookupNameEnv magicDefnsEnv (getName orig_id)
+ | Just mk_magic_pair <- lookupUFM magicDefnsEnv (getUnique orig_id)
= do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs
-- Patching should not change the Name or the type of the Id
@@ -701,22 +702,25 @@ patchMagicDefn orig_pair@(orig_id, orig_rhs)
| otherwise
= return orig_pair
-magicDefns :: [(Name, Id -> CoreExpr -- old Id and RHS
+magicDefns :: [(KnownKey, Id -> CoreExpr -- old Id and RHS
-> DsM (Id, CoreExpr) -- new Id and RHS
)]
-magicDefns = [ (unsafeCoercePrimName, mkUnsafeCoercePrimPair) ]
+magicDefns = [ (unsafeCoercePrimIdKey, mkUnsafeCoercePrimPair) ]
-magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr))
-magicDefnsEnv = mkNameEnv magicDefns
+magicDefnsEnv :: UniqFM KnownKey (Id -> CoreExpr -> DsM (Id, CoreExpr))
+magicDefnsEnv = listToUFM magicDefns
-magicDefnModules :: ModuleSet
-magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns
+mkMagicDefnModules :: DsM ModuleSet
+mkMagicDefnModules = do
+ mods <- mapM (fmap nameModule . dsLookupKnownKeyName . fst) magicDefns
+ pure $ mkModuleSet mods
mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr)
-- See Note [Wiring in unsafeCoerce#] for the defn we are creating here
mkUnsafeCoercePrimPair _old_id old_expr
= do { unsafe_equality_proof_id <- dsLookupKnownKeyId unsafeEqualityProofIdKey
; unsafe_equality_tc <- dsLookupKnownKeyTyCon unsafeEqualityTyConKey
+ ; unsafeCoercePrimName <- dsLookupKnownKeyName unsafeCoercePrimIdKey
; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2566,7 +2566,7 @@ tcGhciStmts stmts
-- We use Any rather than a dummy type such as () because of
-- the rules of unsafeCoerce#; see Unsafe/Coerce.hs for the details.
- ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName
+ ; AnId unsafe_coerce_id <- tcLookupKnownKeyGlobal unsafeCoercePrimIdKey
-- We use unsafeCoerce# here because of (U11) in
-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
=====================================
compiler/GHC/Tc/Utils/Concrete.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Tc.Utils.Concrete
import GHC.Prelude
-import GHC.Builtin.KnownKeys ( unsafeCoercePrimName )
+import GHC.Builtin.KnownKeys ( unsafeCoercePrimIdKey )
import GHC.Builtin.WiredIn.Types
import GHC.Core.Coercion
@@ -45,6 +45,7 @@ import GHC.Utils.Outputable
import GHC.Data.FastString ( FastString, fsLit )
import Control.Monad ( void )
+import GHC.Types.Name (hasKnownKey)
{- Note [Concrete overview]
@@ -857,7 +858,7 @@ idConcreteTvs id
-- in the correct information in the desugarer).
-- So, for the time being, we manually inspect the type of the original,
-- unpatched Id to retrieve which of its outer forall-d tyvars should be concrete.
- | idName id == unsafeCoercePrimName
+ | id `hasKnownKey`unsafeCoercePrimIdKey
, (a_rep:_b_rep:a:_b:_, _) <- tcSplitForAllTyVars $ idType id
-- NB: only check the argument representation, not the result representation.
-- This is because the following is OK:
@@ -866,7 +867,7 @@ idConcreteTvs id
-- unsafeCoerceWordRep = unsafeCoerce#
= mkNameEnv
[(tyVarName a_rep, ConcreteFRR $ FixedRuntimeRepOrigin (mkTyVarTy a)
- $ FRRRepPolyId unsafeCoercePrimName RepPolyFunction
+ $ FRRRepPolyId (idName id) RepPolyFunction
$ mkArgPos 1 Top)]
| otherwise
=====================================
libraries/base/src/GHC/Essentials.hs
=====================================
@@ -161,7 +161,7 @@ module GHC.Essentials
, CS.unpackAppendCStringUtf8#, CS.cstringLength#
, eqString, inline
- , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof
+ , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof, unsafeCoerce#
-- Typeable and type representations
, SomeTypeRep( SomeTypeRep ), TR.Module( Module )
=====================================
libraries/ghc-internal/src/GHC/Internal/Classes/IP.hs
=====================================
@@ -7,7 +7,7 @@
-- LANGUAGE pragmas: see Note [IP: implicit parameter class]
{-# OPTIONS_HADDOCK not-home #-}
-{-# OPTIONS_GHC -fdefine-known-key-names -}
+{-# OPTIONS_GHC -fdefines-known-key-names #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Internal.Classes.IP
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Types.hs
=====================================
@@ -53,6 +53,7 @@ import cycle,
-}
import GHC.Internal.Classes ( Eq( (==) ), (&&) )
+import GHC.Internal.Classes.IP as Rebindable
import GHC.Internal.Types
default ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50ba27b54ab9efc70036655157d9cb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50ba27b54ab9efc70036655157d9cb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26989] Major refactor of the Simplifier
by Simon Peyton Jones (＠simonpj) 11 May '26
by Simon Peyton Jones (＠simonpj) 11 May '26
11 May '26
Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC
Commits:
4e4f6b5c by Simon Peyton Jones at 2026-05-11T14:57:48+01:00
Major refactor of the Simplifier
The main payload of this patch is to refactor the Simplifer to avoid
repeated simplification when using Plan (AFTER) for rule rewrites.
The need for this was shown up by #26989.
See Note [Avoid repeated simplification] in GHC.Core.Opt.Simplify.Iteration.
Related refactoring:
* Refactor the two fields `sc_dup` and `sc_env` in `ApplyToVal` into one, `sc_env`.
Reason: the envt is irrelevant in the "simplified" case, so the data type describes
the possiblitiies much more accurately now.
* Some refactoring in `knownCon` to split off `wrapDataConFloats`.
* Refactor `lookupRule` and its auxiliary functions to return `RuleMatch`,
a new data type. See Note [data RuleMatch] in GHC.Core. Ditto for BuiltinRule.
This RuleMatch returns fragments of the target in rm_args and rm_floats,
leaving `rm_rhs` to be the stuff from the RULE itself.
Doing this has routine consequences in GHC.Core.Opt.ConstantFold. Many changes
there but all routine.
* When doing occurrence analysis on RULEs, make the occ-info on the rule
binders relate just to the RHS, not the LHS. See (OUR1) in
Note Note [OccInfo in unfoldings and rules]
This means that Lint must not complain about the fact that the patterns
in the RULE mentions binders that are marked dead.
See Note [Dead occurrences] in GHC.Core.Lint.
I changed the Core pretty-printer so that it didn't suppress dead binders,
else I can't see those binders in RULEs. That led to quite a lot of testsuite wibbles.
* Refactor FloatBinds, so that it is used both by
`exprIsConApp_mabye` and by `lookupRule`
* Move the definition of FloatBinds out of GHc.Core.Make, into GHC.Core.
* Add FloatTick as an extra constructor.
* Refactor `lookupRule` to use `FloatBinds` instead of `BindWrapper`.
This refactor just shares more code.
(Rename GHC.Core.Opt.FloatOut.FloatBinds to FloatLets, to avoid gratuitious
name clash with GHC.Core.FloatBinds.)
Corecion optimisation
* In simpleOpt, when composing coercions, call new function `optTransCo`.
This is much lighter weight than full blown coercion optimisation.
* Make `GHC.Core.Opt.Arity.pushCoValArg` and `pushCoTyArg` return the
coercionLKind of the coercion. This saves recomputing that coercionLKind
at the key call sites in GHC.Core.Opt.Simplify.Iteration.pushCast.
* Rename `addCoerce` in GHC.Core.Simplify.Iteration to become `pushCast`.
* In the `ApplyToVal` case of `pushCast` we had a very unsavoury call to `simplArg`.
I eliminated it by adding a field `sc_cast` to `ApplyToVal` that records any
pending casts. Much nicer now. See Note [The sc_cast field of ApplyToVal].
* Don't optimise coercions if the type-substitution is empty.
See Note [Optimising coercions] in GHC.Core.Opt.Simplify.Iteration.
The fix for #26838 is dramatic. For the test in perf/compiler/T26839 we have
Compiler allocs: Before: 7,363M
After: 688M
Compile time goes down generally. Here are compiler-alloc changes
over 0.5%:
CoOpt_Read(normal) 729,184,920 -0.7%
CoOpt_Singletons(normal) 666,916,960 -4.6% GOOD
LargeRecord(normal) 1,227,056,876 +1.1%
T12227(normal) 256,827,604 -4.6% GOOD
T12425(optasm) 76,879,410 -0.8%
T12545(normal) 787,826,918 -10.8% GOOD
T12707(normal) 775,186,464 -0.9%
T13253(normal) 318,599,596 -0.8%
T14766(normal) 685,857,320 -1.0%
T15304(normal) 1,123,333,422 -2.2%
T15630(normal) 123,142,330 -2.6%
T15630a(normal) 123,092,100 -2.6%
T15703(normal) 299,751,682 -2.9% GOOD
T17516(normal) 964,072,280 +1.0%
T18223(normal) 367,016,820 -6.2% GOOD
T18730(optasm) 130,643,770 -3.3% GOOD
T20261(normal) 535,608,584 -0.7%
T21839c(normal) 340,340,436 -0.9%
T24984(normal) 85,568,392 -1.9%
T3064(normal) 174,631,992 -1.2%
T3294(normal) 1,215,886,432 -0.7%
T5030(normal) 141,449,704 -17.2% GOOD
T5321Fun(normal) 258,484,744 -1.9%
T8095(normal) 770,532,232 -2.7%
T9630(normal) 858,423,408 -14.5% GOOD
T9872c(normal) 1,591,709,448 +0.7%
info_table_map_perf(normal) 19,700,614,458 -1.3%
geo. mean -0.7%
minimum -17.2%
maximum +1.1%
Metric Decrease:
CoOpt_Singletons
T12227
T12545
T15703
T18223
T18730
T21839c
T5030
T9630
- - - - -
54 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/List/SetOps.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/codeGen/should_compile/T25177.stderr
- testsuite/tests/deSugar/should_compile/T13208.stdout
- testsuite/tests/linters/notes.stdout
- testsuite/tests/numeric/should_compile/T15547.stderr
- testsuite/tests/numeric/should_compile/T20347.stderr
- testsuite/tests/numeric/should_compile/T20374.stderr
- testsuite/tests/numeric/should_compile/T20376.stderr
- + testsuite/tests/perf/compiler/T26989.hs
- + testsuite/tests/perf/compiler/T26989a.hs
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/printer/T18052a.stderr
- testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr
- testsuite/tests/simplCore/should_compile/RewriteHigherOrderPatterns.stderr
- testsuite/tests/simplCore/should_compile/T15205.stderr
- testsuite/tests/simplCore/should_compile/T18668.stderr
- testsuite/tests/simplCore/should_compile/T19246.stderr
- testsuite/tests/simplCore/should_compile/T19599.stderr
- testsuite/tests/simplCore/should_compile/T19599a.stderr
- testsuite/tests/simplCore/should_compile/T21917.stderr
- testsuite/tests/simplCore/should_compile/T23074.stderr
- testsuite/tests/simplCore/should_compile/T24359a.stderr
- testsuite/tests/simplCore/should_compile/T25160.stderr
- testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64
- testsuite/tests/simplCore/should_compile/T26051.stderr
- testsuite/tests/simplCore/should_compile/T26116.stderr
- testsuite/tests/simplCore/should_compile/T8331.stderr
- testsuite/tests/simplCore/should_compile/T8848a.stderr
- testsuite/tests/simplCore/should_compile/spec004.stderr
- testsuite/tests/typecheck/should_compile/T13032.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e4f6b5ced8e47066709153f2fc51e1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e4f6b5ced8e47066709153f2fc51e1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][ghc-9.12] 2 commits: QuickLook: do a shape test before unifying
by Magnus (＠MangoIV) 11 May '26
by Magnus (＠MangoIV) 11 May '26
11 May '26
Magnus pushed to branch ghc-9.12 at Glasgow Haskell Compiler / GHC
Commits:
3f46addc by sheaf at 2026-05-11T12:15:06+02:00
QuickLook: do a shape test before unifying
This commit ensures we do a shape test before unifying. This ensures
we don't try to unify a TyVarTv with a non-tyvar, e.g.
alpha[tyv] := Int
On the way, we refactor simpleUnifyCheck:
1. Move the checkTopShape check into simpleUnifyCheck
2. Refactors simpleUnifyCheck to return a value of the new type
SimpleUnifyResult type. Now, simpleUnifyCheck returns "can unify",
"cannot unify" or "dunno" (with "cannot unify" being the new result
it can return). Now:
- touchabilityTest is included; it it fails we return "cannot unify"
- checkTopShape now returns "cannot unify" instead of "dunno" upon failure
3. Move the call to simpleUnifyCheck out of checkTouchableTyVarEq.
After that, checkTouchableTyVarEq becames a simple call to
checkTyEqRhs, so we inline it.
This allows the logic in canEqCanLHSFinish_try_unification to be simplified.
In particular, we now avoid calling 'checkTopShape' twice.
Two further changes suggested by Simon were also implemented:
- In canEqCanLHSFinish, if checkTyEqRhs returns PuFail with
'do_not_prevent_rewriting', we now **continue with this constraint**.
This allows us to use the constraint for rewriting.
- checkTyEqRhs now has a top-level check to avoid flattening a tyfam app
in a top-level equality of the form alpha ~ F tys, as this is
going around in circles. This simplifies the implementation without
any change in behaviour.
Fixes #25950
Fixes #26030
(cherry picked from commit 67a177b412a4d2517e89ba48e3e22e43c84bff07)
- - - - -
5846d4f9 by sheaf at 2026-05-11T12:15:06+02:00
Add regression test for #27149
This is the same bug as #26030, but another regression test ensures that
this bug is fixed and stays fixed.
- - - - -
12 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Unify.hs
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T23154.stderr
- testsuite/tests/rep-poly/T23903.stderr
- testsuite/tests/simplCore/should_compile/simpl017.stderr
- + testsuite/tests/typecheck/should_compile/T26030.hs
- + testsuite/tests/typecheck/should_compile/T27149.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -2038,22 +2038,22 @@ qlUnify ty1 ty2
= go_flexi1 kappa ty2
go_flexi1 kappa ty2 -- ty2 is zonked
- | -- See Note [QuickLook unification] (UQL1)
- simpleUnifyCheck UC_QuickLook kappa ty2
- , checkTopShape (metaTyVarInfo kappa) ty2
- -- NB: don't forget to do a shape check, as we might be dealing
- -- with an ordinary metavariable (and not a quick-look instantiation variable).
- -- (Forgetting this led to #25950.)
- = do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
- -- unifyKind: see (UQL2) in Note [QuickLook unification]
- -- and (MIV2) in Note [Monomorphise instantiation variables]
- ; let ty2' = mkCastTy ty2 co
- ; traceTc "qlUnify:update" $
- ppr kappa <+> text ":=" <+> ppr ty2
- ; liftZonkM $ writeMetaTyVar kappa ty2' }
-
- | otherwise
- = return () -- Occurs-check or forall-bound variable
+ = do { cur_lvl <- getTcLevel
+ -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
+ -- Here we are in the TcM monad, which does not track enclosing
+ -- Given equalities; so for quick-look unification we conservatively
+ -- treat /any/ level outside this one as untouchable. Hence cur_lvl.
+ ; case simpleUnifyCheck UC_QuickLook cur_lvl kappa ty2 of
+ SUC_CanUnify ->
+ do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
+ -- unifyKind: see (UQL2) in Note [QuickLook unification]
+ -- and (MIV2) in Note [Monomorphise instantiation variables]
+ ; let ty2' = mkCastTy ty2 co
+ ; traceTc "qlUnify:update" $
+ ppr kappa <+> text ":=" <+> ppr ty2
+ ; liftZonkM $ writeMetaTyVar kappa ty2' }
+ _ -> return () -- e.g. occurs-check or forall-bound variable
+ }
where
kappa_kind = tyVarKind kappa
ty2_kind = typeKind ty2
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -1,4 +1,6 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Solver.Equality(
@@ -1884,83 +1886,104 @@ canEqCanLHSFinish ev eq_rel swapped lhs rhs
-----------------------
canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
-- Try unification; for Wanted, Nominal equalities with a meta-tyvar on the LHS
- | isWanted ev -- See Note [Do not unify Givens]
- , NomEq <- eq_rel -- See Note [Do not unify representational equalities]
- , TyVarLHS tv <- lhs
- = do { given_eq_lvl <- getInnermostGivenEqLevel
- ; if not (touchabilityAndShapeTest given_eq_lvl tv rhs)
- then if | Just can_rhs <- canTyFamEqLHS_maybe rhs
- -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs
- -- See Note [Orienting TyVarLHS/TyFamLHS]
-
- | otherwise
- -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
- else
-
- -- We have a touchable unification variable on the left
- do { check_result <- checkTouchableTyVarEq ev tv rhs
- ; case check_result of {
- PuFail reason
+ | isWanted ev -- See Note [Do not unify Givens]
+ , NomEq <- eq_rel -- See Note [Do not unify representational equalities]
+ , TyVarLHS lhs_tv <- lhs
+ = do { given_eq_lvl <- getInnermostGivenEqLevel
+ ; case simpleUnifyCheck UC_Solver given_eq_lvl lhs_tv rhs of
+ SUC_CanUnify ->
+ unify lhs_tv (mkReflRedn Nominal rhs)
+ SUC_CannotUnify
| Just can_rhs <- canTyFamEqLHS_maybe rhs
- -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs
- -- Swap back: see Note [Orienting TyVarLHS/TyFamLHS]
-
- | reason `cterHasOnlyProblems` do_not_prevent_rewriting
- -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
-
+ -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS]
| otherwise
- -> tryIrredInstead reason ev eq_rel swapped lhs rhs ;
-
- PuOK _ rhs_redn ->
-
- -- Success: we can solve by unification
- do { -- In the common case where rhs_redn is Refl, we don't need to rewrite
- -- the evidence, even if swapped=IsSwapped. Suppose the original was
- -- [W] co : Int ~ alpha
- -- We unify alpha := Int, and set co := <Int>. No need to
- -- swap to co = sym co'
- -- co' = <Int>
- new_ev <- if isReflCo (reductionCoercion rhs_redn)
- then return ev
- else rewriteEqEvidence emptyRewriterSet ev swapped
- (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn
-
- ; let tv_ty = mkTyVarTy tv
- final_rhs = reductionReducedType rhs_redn
-
- ; traceTcS "Sneaky unification:" $
- vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs,
- text "Coercion:" <+> pprEq tv_ty final_rhs,
- text "Left Kind is:" <+> ppr (typeKind tv_ty),
- text "Right Kind is:" <+> ppr (typeKind final_rhs) ]
-
- -- Update the unification variable itself
- ; unifyTyVar tv final_rhs
-
- -- Provide Refl evidence for the constraint
- -- Ignore 'swapped' because it's Refl!
- ; setEvBindIfWanted new_ev EvCanonical $
- evCoercion (mkNomReflCo final_rhs)
-
- -- Kick out any constraints that can now be rewritten
- ; kickOutAfterUnification [tv]
-
- ; return (Stop new_ev (text "Solved by unification")) }}}}
-
+ -> finish_no_unify
+ SUC_NotSure ->
+ -- We have a touchable unification variable on the left,
+ -- and the top-shape check succeeded. These are both guaranteed
+ -- by the fact that simpleUnifyCheck did not return SUC_CannotUnify.
+ do { let flags = unifyingLHSMetaTyVar_TEFTask ev lhs_tv
+ ; check_result <- wrapTcS (checkTyEqRhs flags rhs)
+ ; case check_result of
+ PuOK cts rhs_redn ->
+ do { emitWork cts
+ ; unify lhs_tv rhs_redn }
+ PuFail reason
+ | Just can_rhs <- canTyFamEqLHS_maybe rhs
+ -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS]
+ | reason `cterHasOnlyProblems` do_not_prevent_rewriting
+ ->
+ -- ContinueWith, to allow using this constraint for
+ -- rewriting (e.g. alpha[2] ~ beta[3]).
+ do { let role = eqRelRole eq_rel
+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+ (mkReflRedn role (canEqLHSType lhs))
+ (mkReflRedn role rhs)
+ ; continueWith $ Right $
+ EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
+ , eq_lhs = lhs , eq_rhs = rhs }
+ }
+ | otherwise
+ -> try_irred reason
+ }
+ }
-- Otherwise unification is off the table
| otherwise
- = canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
+ = finish_no_unify
where
- -- Some problems prevent /unification/ but not /rewriting/
- -- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3]
- -- we can't unify (skolem-escape); but it /is/ canonical,
- -- and hence we /can/ use it for rewriting
- -- Concrete-ness: alpha[conc] ~ b[sk]
- -- We can use it to rewrite; we still have to solve the original
- do_not_prevent_rewriting :: CheckTyEqResult
- do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<>
- cteProblem cteConcrete
+ -- We can't unify, but this equality can go in the inert set
+ -- and be used to rewrite other constraints.
+ finish_no_unify =
+ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
+
+ -- We can't unify, and this equality should not be used to rewrite
+ -- other constraints (e.g. because it has an occurs check).
+ -- So add it to the inert Irreds.
+ try_irred reason =
+ tryIrredInstead reason ev eq_rel swapped lhs rhs
+
+ -- We can't unify as-is, and want to flip the equality around.
+ -- Example: alpha ~ F tys, flip it around to become the canonical
+ -- equality f tys ~ alpha.
+ swap_and_finish tv can_rhs =
+ swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs
+
+ -- We can unify; go ahead and do so.
+ unify tv rhs_redn =
+
+ do { -- In the common case where rhs_redn is Refl, we don't need to rewrite
+ -- the evidence, even if swapped=IsSwapped. Suppose the original was
+ -- [W] co : Int ~ alpha
+ -- We unify alpha := Int, and set co := <Int>. No need to
+ -- swap to co = sym co'
+ -- co' = <Int>
+ new_ev <- if isReflCo (reductionCoercion rhs_redn)
+ then return ev
+ else rewriteEqEvidence emptyRewriterSet ev swapped
+ (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn
+
+ ; let tv_ty = mkTyVarTy tv
+ final_rhs = reductionReducedType rhs_redn
+
+ ; traceTcS "Sneaky unification:" $
+ vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs,
+ text "Coercion:" <+> pprEq tv_ty final_rhs,
+ text "Left Kind is:" <+> ppr (typeKind tv_ty),
+ text "Right Kind is:" <+> ppr (typeKind final_rhs) ]
+
+ -- Update the unification variable itself
+ ; unifyTyVar tv final_rhs
+
+ -- Provide Refl evidence for the constraint
+ -- Ignore 'swapped' because it's Refl!
+ ; setEvBindIfWanted new_ev EvCanonical $
+ evCoercion (mkNomReflCo final_rhs)
+
+ -- Kick out any constraints that can now be rewritten
+ ; kickOutAfterUnification [tv]
+
+ ; return (Stop new_ev (text "Solved by unification")) }
---------------------------
-- Unification is off the table
@@ -1987,6 +2010,17 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
-- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs
-- | otherwise
+ | reason `cterHasOnlyProblems` do_not_prevent_rewriting
+ -> do { let role = eqRelRole eq_rel
+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+ (mkReflRedn role (canEqLHSType lhs))
+ (mkReflRedn role rhs)
+ ; continueWith $ Right $
+ EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
+ , eq_lhs = lhs , eq_rhs = rhs }
+ }
+
+ | otherwise
-> tryIrredInstead reason ev eq_rel swapped lhs rhs
PuOK _ rhs_redn
@@ -2003,6 +2037,18 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
, eq_lhs = lhs
, eq_rhs = reductionReducedType rhs_redn } } }
+-- | Some problems prevent /unification/ but not /rewriting/:
+--
+-- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3]
+-- we can't unify (skolem-escape); but it /is/ canonical,
+-- and hence we /can/ use it for rewriting
+--
+-- Concrete-ness: alpha[conc] ~ b[sk]
+-- We can use it to rewrite; we still have to solve the original
+do_not_prevent_rewriting :: CheckTyEqResult
+do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<>
+ cteProblem cteConcrete
+
----------------------
swapAndFinish :: CtEvidence -> EqRel -> SwapFlag
-> TcType -> CanEqLHS -- ty ~ F tys
@@ -2308,8 +2354,9 @@ and we turn this into
[W] Arg alpha ~ cbv1
[W] Res alpha ~ cbv2
-where cbv1 and cbv2 are fresh TauTvs. This is actually done by `break_wanted`
-in `GHC.Tc.Solver.Monad.checkTouchableTyVarEq`.
+where cbv1 and cbv2 are fresh TauTvs. This is actually done within checkTyEqRhs,
+called within canEqCanLHSFinish_try_unification, which will use the BreakWanted
+FamAppBreaker.
Why TauTvs? See [Why TauTvs] below.
@@ -2318,7 +2365,7 @@ directly instead of calling wrapUnifierTcS. (Otherwise, we'd end up
unifying cbv1 and cbv2 immediately, achieving nothing.) Next, we
unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This
unification happens immediately following a successful call to
-checkTouchableTyVarEq, in canEqCanLHSFinish_try_unification.
+checkTyEqRhs, in canEqCanLHSFinish_try_unification.
Now, we're here (including further context from our original example,
from the top of the Note):
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -122,7 +122,7 @@ module GHC.Tc.Solver.Monad (
pprEq,
-- Enforcing invariants for type equalities
- checkTypeEq, checkTouchableTyVarEq
+ checkTypeEq
) where
import GHC.Prelude
@@ -2169,129 +2169,36 @@ wrapUnifierX ev role do_unifications
************************************************************************
-}
-checkTouchableTyVarEq
- :: CtEvidence
- -> TcTyVar -- A touchable meta-tyvar
- -> TcType -- The RHS
- -> TcS (PuResult () Reduction)
--- Used for Nominal, Wanted equalities, with a touchable meta-tyvar on LHS
--- If checkTouchableTyVarEq tv ty = PuOK cts redn
--- then we can unify
--- tv := ty |> redn
--- with extra wanteds 'cts'
--- If it returns (PuFail reason) we can't unify, and the reason explains why.
-checkTouchableTyVarEq ev lhs_tv rhs
- | simpleUnifyCheck UC_Solver lhs_tv rhs -- An (optional) short-cut
- = do { traceTcS "checkTouchableTyVarEq: simple-check wins" (ppr lhs_tv $$ ppr rhs)
- ; return (pure (mkReflRedn Nominal rhs)) }
-
- | otherwise
- = do { traceTcS "checkTouchableTyVarEq {" (ppr lhs_tv $$ ppr rhs)
- ; check_result <- wrapTcS (check_rhs rhs)
- ; traceTcS "checkTouchableTyVarEq }" (ppr lhs_tv $$ ppr check_result)
- ; case check_result of
- PuFail reason -> return (PuFail reason)
- PuOK cts redn -> do { emitWork cts
- ; return (pure redn) } }
-
- where
- (lhs_tv_info, lhs_tv_lvl) = case tcTyVarDetails lhs_tv of
- MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl)
- _ -> pprPanic "checkTouchableTyVarEq" (ppr lhs_tv)
- -- lhs_tv should be a meta-tyvar
-
- is_concrete_lhs_tv = isConcreteInfo lhs_tv_info
-
- check_rhs rhs
- -- Crucial special case for alpha ~ F tys
- -- We don't want to flatten that (F tys)!
- | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs
- = if is_concrete_lhs_tv
- then failCheckWith (cteProblem cteConcrete)
- else recurseIntoTyConApp arg_flags tc tys
- | otherwise
- = checkTyEqRhs flags rhs
-
- flags = TEF { tef_foralls = False -- isRuntimeUnkSkol lhs_tv
- , tef_fam_app = mkTEFA_Break ev NomEq break_wanted
- , tef_unifying = Unifying lhs_tv_info lhs_tv_lvl (LC_Promote False)
- , tef_lhs = TyVarLHS lhs_tv
- , tef_occurs = cteInsolubleOccurs }
-
- arg_flags = famAppArgFlags flags
-
- break_wanted :: FamAppBreaker Ct
- break_wanted fam_app
- -- Occurs check or skolem escape; so flatten
- = do { let fam_app_kind = typeKind fam_app
- ; reason <- checkPromoteFreeVars cteInsolubleOccurs
- lhs_tv lhs_tv_lvl (tyCoVarsOfType fam_app_kind)
- ; if not (cterHasNoProblem reason) -- Failed to promote free vars
- then failCheckWith reason
- else
- do { new_tv_ty <-
- case lhs_tv_info of
- ConcreteTv conc_info ->
- -- Make a concrete tyvar if lhs_tv is concrete
- -- e.g. alpha[2,conc] ~ Maybe (F beta[4])
- -- We want to flatten to
- -- alpha[2,conc] ~ Maybe gamma[2,conc]
- -- gamma[2,conc] ~ F beta[4]
- TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind
- _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind
-
- ; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty
- ; hole <- TcM.newVanillaCoercionHole pty
- ; let new_ev = CtWanted { ctev_pred = pty
- , ctev_dest = HoleDest hole
- , ctev_loc = cb_loc
- , ctev_rewriters = ctEvRewriters ev }
- ; return (PuOK (singleCt (mkNonCanonical new_ev))
- (mkReduction (HoleCo hole) new_tv_ty)) } }
-
- -- See Detail (7) of the Note
- cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
-
-------------------------
checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType
-> TcS (PuResult () Reduction)
-- Used for general CanEqLHSs, ones that do
-- not have a touchable type variable on the LHS (i.e. not unifying)
-checkTypeEq ev eq_rel lhs rhs
- | isGiven ev
- = do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs
- , text "rhs:" <+> ppr rhs ])
- ; check_result <- wrapTcS (check_given_rhs rhs)
- ; traceTcS "checkTypeEq }" (ppr check_result)
- ; case check_result of
- PuFail reason -> return (PuFail reason)
- PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs
- ; emitWork new_givens
- ; updInertSet (addCycleBreakerBindings prs)
- ; return (pure redn) } }
-
- | otherwise -- Wanted
- = do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs)
- ; case check_result of
- PuFail reason -> return (PuFail reason)
- PuOK cts redn -> do { emitWork cts
- ; return (pure redn) } }
+checkTypeEq ev eq_rel lhs rhs =
+ case ev of
+ CtGiven {} ->
+ do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs
+ , text "rhs:" <+> ppr rhs ])
+ ; check_result <- wrapTcS (checkTyEqRhs given_flags rhs)
+ ; traceTcS "checkTypeEq }" (ppr check_result)
+ ; case check_result of
+ PuFail reason -> return (PuFail reason)
+ PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs
+ ; emitWork new_givens
+ ; updInertSet (addCycleBreakerBindings prs)
+ ; return (pure redn) } }
+ CtWanted {} ->
+ do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs)
+ ; case check_result of
+ PuFail reason -> return (PuFail reason)
+ PuOK cts redn -> do { emitWork cts
+ ; return (pure redn) } }
where
- check_given_rhs :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction)
- check_given_rhs rhs
- -- See Note [Special case for top-level of Given equality]
- | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs
- = recurseIntoTyConApp arg_flags tc tys
- | otherwise
- = checkTyEqRhs given_flags rhs
-
- arg_flags = famAppArgFlags given_flags
given_flags :: TyEqFlags (TcTyVar,TcType)
given_flags = TEF { tef_lhs = lhs
, tef_foralls = False
, tef_unifying = NotUnifying
- , tef_fam_app = mkTEFA_Break ev eq_rel break_given
+ , tef_fam_app = mkTEFA_Break ev eq_rel BreakGiven
, tef_occurs = occ_prob }
-- TEFA_Break used for: [G] a ~ Maybe (F a)
-- or [W] F a ~ Maybe (F a)
@@ -2308,13 +2215,6 @@ checkTypeEq ev eq_rel lhs rhs
NomEq -> cteInsolubleOccurs
ReprEq -> cteSolubleOccurs
- break_given :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction)
- break_given fam_app
- = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app)
- ; return (PuOK (unitBag (new_tv, fam_app))
- (mkReflRedn Nominal (mkTyVarTy new_tv))) }
- -- Why reflexive? See Detail (4) of the Note
-
---------------------------
mk_new_given :: (TcTyVar, TcType) -> TcS Ct
mk_new_given (new_tv, fam_app)
@@ -2327,20 +2227,6 @@ checkTypeEq ev eq_rel lhs rhs
-- See Detail (7) of the Note
cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
-mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp a
-mkTEFA_Break ev eq_rel breaker
- | NomEq <- eq_rel
- , not cycle_breaker_origin
- = TEFA_Break breaker
- | otherwise
- = TEFA_Recurse
- where
- -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles]
- -- in GHC.Tc.Solver.Equality
- cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of
- CycleBreakerOrigin {} -> True
- _ -> False
-
-------------------------
-- | Fill in CycleBreakerTvs with the variables they stand for.
-- See Note [Type equality cycles] in GHC.Tc.Solver.Equality
@@ -2357,31 +2243,6 @@ restoreTyVarCycles is
(a ~R# b a) is soluble if b later turns out to be Identity
So we treat this as a "soluble occurs check".
-Note [Special case for top-level of Given equality]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We take care when examining
- [G] F ty ~ G (...(F ty)...)
-where both sides are TyFamLHSs. We don't want to flatten that RHS to
- [G] F ty ~ cbv
- [G] G (...(F ty)...) ~ cbv
-Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a
-canonical constraint
- [G] G (...(F ty)...) ~ F ty
-That tents to rewrite a big type to smaller one. This happens in T15703,
-where we had:
- [G] Pure g ~ From1 (To1 (Pure g))
-Making a loop breaker and rewriting left to right just makes much bigger
-types than swapping it over.
-
-(We might hope to have swapped it over before getting to checkTypeEq,
-but better safe than sorry.)
-
-NB: We never see a TyVarLHS here, such as
- [G] a ~ F tys here
-because we'd have swapped it to
- [G] F tys ~ a
-in canEqCanLHS2, before getting to checkTypeEq.
-
Note [Don't cycle-break Wanteds when not unifying]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consdier
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -257,10 +257,10 @@ We thus perform an occurs-check. There is, of course, some subtlety:
* For type variables, the occurs-check looks deeply including kinds of
type variables. This is because a CEqCan over a meta-variable is
- also used to inform unification, in
- GHC.Tc.Solver.Monad.checkTouchableTyVarEq. If the LHS appears
- anywhere in the RHS, at all, unification will create an infinite
- structure which is bad.
+ also used to inform unification, via `checkTyEqRhs`, called in
+ `canEqCanLHSFinish_try_unification`.
+ If the LHS appears anywhere in the RHS, at all, unification will create
+ an infinite structure, which is bad.
* For type family applications, the occurs-check is shallow; it looks
only in places where we might rewrite. (Specifically, it does not
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -1,3 +1,6 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecursiveDo #-}
@@ -25,7 +28,7 @@ module GHC.Tc.Utils.Unify (
-- Various unifications
unifyType, unifyKind, unifyInvisibleType, unifyExpectedType,
unifyExprType, unifyTypeAndEmit, promoteTcType,
- swapOverTyVars, touchabilityAndShapeTest, checkTopShape, lhsPriority,
+ swapOverTyVars, touchabilityTest, checkTopShape, lhsPriority,
UnifyEnv(..), updUEnvLoc, setUEnvRole,
uType,
@@ -39,11 +42,12 @@ module GHC.Tc.Utils.Unify (
matchExpectedFunKind,
matchActualFunTy, matchActualFunTys,
- checkTyEqRhs, recurseIntoTyConApp,
+ checkTyEqRhs, recurseIntoTyConApp, recurseIntoFamTyConApp,
PuResult(..), failCheckWith, okCheckRefl, mapCheck,
- TyEqFlags(..), TyEqFamApp(..), AreUnifying(..), LevelCheck(..), FamAppBreaker,
- famAppArgFlags, checkPromoteFreeVars,
- simpleUnifyCheck, UnifyCheckCaller(..),
+ TyEqFlags(..), TyEqFamApp(..), AreUnifying(..), LevelCheck(..), FamAppBreaker(..),
+ famAppArgFlags, checkPromoteFreeVars,
+ notUnifying_TEFTask, unifyingLHSMetaTyVar_TEFTask, mkTEFA_Break,
+ simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..),
fillInferResult,
) where
@@ -60,7 +64,8 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.CtLoc( CtLoc, mkKindEqLoc, adjustCtLoc )
+import GHC.Tc.Types.CtLoc( CtLoc, mkKindEqLoc, adjustCtLoc
+ , ctLocOrigin, updateCtLocOrigin )
import GHC.Tc.Types.Origin
import GHC.Tc.Zonk.TcType
@@ -71,6 +76,7 @@ import GHC.Core.TyCo.Ppr( debugPprType {- pprTyVar -} )
import GHC.Core.TyCon
import GHC.Core.Coercion
import GHC.Core.Multiplicity
+import GHC.Core.Predicate ( EqRel(..) )
import GHC.Core.Reduction
import qualified GHC.LanguageExtensions as LangExt
@@ -96,6 +102,7 @@ import GHC.Data.FastString( fsLit )
import Control.Monad
import Data.Monoid as DM ( Any(..) )
import qualified Data.Semigroup as S ( (<>) )
+import Data.Traversable ( for )
{- *********************************************************************
* *
@@ -2477,10 +2484,9 @@ uUnfilledVar2 :: UnifyEnv -- Precondition: u_role==Nominal
uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2
= do { cur_lvl <- getTcLevel
-- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
- -- Here we don't know about given equalities here; so we treat
+ -- Here we don't know about given equalities; so we treat
-- /any/ level outside this one as untouchable. Hence cur_lvl.
- ; if not (touchabilityAndShapeTest cur_lvl tv1 ty2
- && simpleUnifyCheck UC_OnTheFly tv1 ty2)
+ ; if simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2 /= SUC_CanUnify
then not_ok_so_defer cur_lvl
else
do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs
@@ -2525,8 +2531,8 @@ uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2
do { traceTc "uUnfilledVar2 not ok" $
vcat [ text "tv1:" <+> ppr tv1
, text "ty2:" <+> ppr ty2
- , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly tv1 ty2)
- , text "touchability:" <+> ppr (touchabilityAndShapeTest cur_lvl tv1 ty2)]
+ , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2)
+ ]
-- Occurs check or an untouchable: just defer
-- NB: occurs check isn't necessarily fatal:
-- eg tv1 occurred in type family parameter
@@ -2585,9 +2591,8 @@ lhsPriority tv
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Question: given a homogeneous equality (alpha ~# ty), when is it OK to
unify alpha := ty?
-
-This note only applied to /homogeneous/ equalities, in which both
-sides have the same kind.
+(This note only applies to /homogeneous/ equalities, in which both
+sides have the same kind.)
There are five reasons not to unify:
@@ -2681,7 +2686,7 @@ Needless to say, all there are wrinkles:
* In the constraint solver, we track where Given equalities occur
and use that to guard unification in
- GHC.Tc.Utils.Unify.touchabilityAndShapeTest. More details in
+ GHC.Tc.Utils.Unify.touchabilityTest. More details in
Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
Historical note: in the olden days (pre 2021) the constraint solver
@@ -2922,12 +2927,34 @@ data UnifyCheckCaller
= UC_OnTheFly -- Called from the on-the-fly unifier
| UC_QuickLook -- Called from Quick Look
| UC_Solver -- Called from constraint solver
- | UC_Defaulting -- Called when doing top-level defaulting
-simpleUnifyCheck :: UnifyCheckCaller -> TcTyVar -> TcType -> Bool
--- simpleUnifyCheck does a fast check: True <=> unification is OK
--- If it says 'False' then unification might still be OK, but
--- it'll take more work to do -- use the full checkTypeEq
+-- | The result type of 'simpleUnifyCheck'.
+data SimpleUnifyResult
+ -- | Definitely cannot unify (untouchable variable or incompatible top-shape)
+ = SUC_CannotUnify
+ -- | The variable is touchable and the top-shape test passed, but
+ -- it may or may not be OK to unify
+ | SUC_NotSure
+ -- | Definitely OK to unify
+ | SUC_CanUnify
+ deriving stock (Eq, Ord, Show)
+instance Semigroup SimpleUnifyResult where
+ no@SUC_CannotUnify <> _ = no
+ SUC_CanUnify <> r = r
+ _ <> no@SUC_CannotUnify = no
+ r <> SUC_CanUnify = r
+ ns@SUC_NotSure <> SUC_NotSure = ns
+
+instance Outputable SimpleUnifyResult where
+ ppr = \case
+ SUC_CannotUnify -> text "SUC_CannotUnify"
+ SUC_NotSure -> text "SUC_NotSure"
+ SUC_CanUnify -> text "SUC_CanUnify"
+
+simpleUnifyCheck :: UnifyCheckCaller -> TcLevel -> TcTyVar -> TcType -> SimpleUnifyResult
+-- ^ A fast check for unification. May return "not sure", in which case
+-- unification might still be OK, but it'll take more work to do
+-- (use the full 'checkTypeEq').
--
-- * Rejects if lhs_tv occurs in rhs_ty (occurs check)
-- * Rejects foralls unless
@@ -2938,9 +2965,17 @@ simpleUnifyCheck :: UnifyCheckCaller -> TcTyVar -> TcType -> Bool
-- * Does a level-check for type variables, to avoid skolem escape
--
-- This function is pretty heavily used, so it's optimised not to allocate
-simpleUnifyCheck caller lhs_tv rhs
- = go rhs
+simpleUnifyCheck caller given_eq_lvl lhs_tv rhs
+ | not $ touchabilityTest given_eq_lvl lhs_tv
+ = SUC_CannotUnify
+ | not $ checkTopShape lhs_info rhs
+ = SUC_CannotUnify
+ | rhs_is_ok rhs
+ = SUC_CanUnify
+ | otherwise
+ = SUC_NotSure
where
+ lhs_info = metaTyVarInfo lhs_tv
!(occ_in_ty, occ_in_co) = mkOccFolders lhs_tv
@@ -2960,33 +2995,32 @@ simpleUnifyCheck caller lhs_tv rhs
UC_Solver -> True
UC_QuickLook -> True
UC_OnTheFly -> False
- UC_Defaulting -> True
- go (TyVarTy tv)
+ rhs_is_ok (TyVarTy tv)
| lhs_tv == tv = False
| tcTyVarLevel tv `strictlyDeeperThan` lhs_tv_lvl = False
| lhs_tv_is_concrete, not (isConcreteTyVar tv) = False
| occ_in_ty $! (tyVarKind tv) = False
| otherwise = True
- go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})
+ rhs_is_ok (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})
| not forall_ok, isInvisibleFunArg af = False
- | otherwise = go w && go a && go r
+ | otherwise = rhs_is_ok w && rhs_is_ok a && rhs_is_ok r
- go (TyConApp tc tys)
+ rhs_is_ok (TyConApp tc tys)
| lhs_tv_is_concrete, not (isConcreteTyCon tc) = False
| not forall_ok, not (isTauTyCon tc) = False
| not fam_ok, not (isFamFreeTyCon tc) = False
- | otherwise = all go tys
+ | otherwise = all rhs_is_ok tys
- go (ForAllTy (Bndr tv _) ty)
- | forall_ok = go (tyVarKind tv) && (tv == lhs_tv || go ty)
+ rhs_is_ok (ForAllTy (Bndr tv _) ty)
+ | forall_ok = rhs_is_ok (tyVarKind tv) && (tv == lhs_tv || rhs_is_ok ty)
| otherwise = False
- go (AppTy t1 t2) = go t1 && go t2
- go (CastTy ty co) = not (occ_in_co co) && go ty
- go (CoercionTy co) = not (occ_in_co co)
- go (LitTy {}) = True
+ rhs_is_ok (AppTy t1 t2) = rhs_is_ok t1 && rhs_is_ok t2
+ rhs_is_ok (CastTy ty co) = not (occ_in_co co) && rhs_is_ok ty
+ rhs_is_ok (CoercionTy co) = not (occ_in_co co)
+ rhs_is_ok (LitTy {}) = True
mkOccFolders :: TcTyVar -> (TcType -> Bool, TcCoercion -> Bool)
@@ -3073,10 +3107,7 @@ reductionCoercion is Refl. See `canEqCanLHSFinish_no_unification`.
data PuResult a b = PuFail CheckTyEqResult
| PuOK (Bag a) b
-
-instance Functor (PuResult a) where
- fmap _ (PuFail prob) = PuFail prob
- fmap f (PuOK cts x) = PuOK cts (f x)
+ deriving stock (Functor, Foldable, Traversable)
instance Applicative (PuResult a) where
pure x = PuOK emptyBag x
@@ -3192,15 +3223,147 @@ famAppArgFlags flags@(TEF { tef_unifying = unifying })
| not deeply = Unifying info lvl LC_Check
zap_promotion unifying = unifying
-type FamAppBreaker a = TcType -> TcM (PuResult a Reduction)
- -- Given a family-application ty, return a Reduction :: ty ~ cvb
- -- where 'cbv' is a fresh loop-breaker tyvar (for Given), or
- -- just a fresh TauTv (for Wanted)
+-- | How to break a family-application cycle when checking a type equality.
+-- Given a family-application @fam_app@, return a @'Reduction' :: fam_app ~ cbv@
+-- where @cbv@ is a fresh cycle-breaker tyvar (for Given), or
+-- a fresh 'TauTv' (for Wanted).
+data FamAppBreaker a where
+ BreakGiven :: FamAppBreaker (TcTyVar, TcType)
+ BreakWanted :: CtEvidence -> TcTyVar -> FamAppBreaker Ct
+
+-- | Dispatch on a 'FamAppBreaker' to break a family-application cycle.
+-- See Note [Type equality cycles] in GHC.Tc.Solver.Equality.
+famAppBreaker :: FamAppBreaker a -> TcType -> TcM (PuResult a Reduction)
+famAppBreaker BreakGiven fam_app
+ -- Why reflexive? See Detail (4) of Note [Type equality cycles] in GHC.Tc.Solver.Equality
+ = do { new_tv <- newCycleBreakerTyVar (typeKind fam_app)
+ ; return (PuOK (unitBag (new_tv, fam_app))
+ (mkReflRedn Nominal (mkTyVarTy new_tv))) }
+famAppBreaker (BreakWanted ev lhs_tv) fam_app
+ -- Occurs check or skolem escape; so flatten.
+ = do { let fam_app_kind = typeKind fam_app
+ ; reason <- checkPromoteFreeVars cteInsolubleOccurs
+ lhs_tv lhs_tv_lvl (tyCoVarsOfType fam_app_kind)
+ ; if not (cterHasNoProblem reason) -- Failed to promote free vars
+ then return $ PuFail reason
+ else
+ do { new_tv_ty <-
+ case lhs_tv_info of
+ ConcreteTv conc_info ->
+ -- Make a concrete tyvar if lhs_tv is concrete
+ -- e.g. alpha[2,conc] ~ Maybe (F beta[4])
+ -- We want to flatten to
+ -- alpha[2,conc] ~ Maybe gamma[2,conc]
+ -- gamma[2,conc] ~ F beta[4]
+ newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind
+ _ -> newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind
+ ; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty
+ ; hole <- newVanillaCoercionHole pty
+ ; let new_ev = CtWanted { ctev_pred = pty
+ , ctev_dest = HoleDest hole
+ , ctev_loc = cb_loc
+ , ctev_rewriters = ctEvRewriters ev }
+ ; return (PuOK (singleCt (mkNonCanonical new_ev))
+ (mkReduction (HoleCo hole) new_tv_ty)) } }
+ where
+ (lhs_tv_info, lhs_tv_lvl) = case tcTyVarDetails lhs_tv of
+ MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl)
+ _ -> pprPanic "famAppBreaker BreakWanted: lhs_tv is not a meta-tyvar" (ppr lhs_tv)
+ -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality
+ cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
+
+instance Outputable (FamAppBreaker a) where
+ ppr BreakGiven = text "BreakGiven"
+ ppr (BreakWanted ev tv) = parens $ text "BreakWanted" <+> ppr ev <+> ppr tv
+
+tefConcrete :: TyEqFlags a -> Bool
+tefConcrete (TEF { tef_unifying = Unifying info _ _ }) = isConcreteInfo info
+tefConcrete (TEF { tef_unifying = NotUnifying }) = False
+
+mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp a
+mkTEFA_Break ev eq_rel breaker
+ | NomEq <- eq_rel
+ , not cycle_breaker_origin
+ = TEFA_Break breaker
+ | otherwise
+ = TEFA_Recurse
+ where
+ -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles]
+ -- in GHC.Tc.Solver.Equality
+ cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of
+ CycleBreakerOrigin {} -> True
+ _ -> False
+
+notUnifying_TEFTask :: CheckTyEqProblem -> CanEqLHS -> TyEqFlags a
+-- Used for the non-unifying cases (checkTypeEq in Solver.Monad)
+notUnifying_TEFTask occ_prob lhs
+ = TEF { tef_foralls = False
+ , tef_lhs = lhs
+ , tef_unifying = NotUnifying
+ , tef_fam_app = TEFA_Recurse
+ , tef_occurs = occ_prob }
+
+unifyingLHSMetaTyVar_TEFTask :: CtEvidence -> TcTyVar -> TyEqFlags Ct
+-- Used for the unifying case (canEqCanLHSFinish_try_unification in Solver.Equality)
+unifyingLHSMetaTyVar_TEFTask ev lhs_tv
+ = TEF { tef_foralls = False
+ , tef_fam_app = mkTEFA_Break ev NomEq (BreakWanted ev lhs_tv)
+ , tef_unifying = Unifying lhs_tv_info lhs_tv_lvl (LC_Promote False)
+ , tef_lhs = TyVarLHS lhs_tv
+ , tef_occurs = cteInsolubleOccurs }
+ where
+ (lhs_tv_info, lhs_tv_lvl) = case tcTyVarDetails lhs_tv of
+ MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info, lvl)
+ _ -> pprPanic "unifyingLHSMetaTyVar_TEFTask: not a meta-tyvar" (ppr lhs_tv)
checkTyEqRhs :: forall a. TyEqFlags a
-> TcType -- Already zonked
-> TcM (PuResult a Reduction)
-checkTyEqRhs flags ty
+-- Crucial special case for a top-level equality of the form 'alpha ~ F tys'.
+-- We don't want to flatten that (F tys), as this gets us right back to where
+-- we started!
+-- See also Note [Special case for top-level of Given equality]
+checkTyEqRhs flags rhs
+ | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs
+ , not $ tefConcrete flags
+ = recurseIntoFamTyConApp flags tc tys
+ | otherwise
+ = check_ty_eq_rhs flags rhs
+
+{- Note [Special case for top-level of Given equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We take care when examining
+ [G] F ty ~ G (...(F ty)...)
+where both sides are TyFamLHSs. We don't want to flatten that RHS to
+ [G] F ty ~ cbv
+ [G] G (...(F ty)...) ~ cbv
+Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a
+canonical constraint
+ [G] G (...(F ty)...) ~ F ty
+That tends to rewrite a big type to smaller one. This happens in T15703,
+where we had:
+ [G] Pure g ~ From1 (To1 (Pure g))
+Making a loop breaker and rewriting left to right just makes much bigger
+types than swapping it over.
+
+(We might hope to have swapped it over before getting to checkTypeEq,
+but better safe than sorry.)
+
+NB: We never see a TyVarLHS here, such as
+ [G] a ~ F tys here
+because we'd have swapped it to
+ [G] F tys ~ a
+in canEqCanLHS2, before getting to checkTypeEq.
+-}
+
+recurseIntoFamTyConApp :: TyEqFlags a -> TyCon -> [TcType] -> TcM (PuResult a Reduction)
+recurseIntoFamTyConApp flags tc tys
+ = recurseIntoTyConApp (famAppArgFlags flags) tc tys
+
+check_ty_eq_rhs :: forall a. TyEqFlags a
+ -> TcType -- Already zonked
+ -> TcM (PuResult a Reduction)
+check_ty_eq_rhs flags ty
= case ty of
LitTy {} -> okCheckRefl ty
TyConApp tc tys -> checkTyConApp flags ty tc tys
@@ -3214,26 +3377,24 @@ checkTyEqRhs flags ty
, not (tef_foralls flags)
-> failCheckWith impredicativeProblem -- Not allowed (TyEq:F)
| otherwise
- -> do { w_res <- checkTyEqRhs flags w
- ; a_res <- checkTyEqRhs flags a
- ; r_res <- checkTyEqRhs flags r
+ -> do { w_res <- check_ty_eq_rhs flags w
+ ; a_res <- check_ty_eq_rhs flags a
+ ; r_res <- check_ty_eq_rhs flags r
; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) }
- AppTy fun arg -> do { fun_res <- checkTyEqRhs flags fun
- ; arg_res <- checkTyEqRhs flags arg
+ AppTy fun arg -> do { fun_res <- check_ty_eq_rhs flags fun
+ ; arg_res <- check_ty_eq_rhs flags arg
; return (mkAppRedn <$> fun_res <*> arg_res) }
- CastTy ty co -> do { ty_res <- checkTyEqRhs flags ty
+ CastTy ty co -> do { ty_res <- check_ty_eq_rhs flags ty
; co_res <- checkCo flags co
; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) }
CoercionTy co -> do { co_res <- checkCo flags co
; return (mkReflCoRedn Nominal <$> co_res) }
- ForAllTy {}
- | tef_foralls flags -> okCheckRefl ty
- | otherwise -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F)
-
+ ForAllTy {} -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F)
+{-# INLINEABLE check_ty_eq_rhs #-}
-------------------
checkCo :: TyEqFlags a -> Coercion -> TcM (PuResult a Coercion)
@@ -3388,15 +3549,14 @@ checkTyConApp flags@(TEF { tef_unifying = unifying, tef_foralls = foralls_ok })
else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys
fun_app = mkTyConApp tc fun_args
; fun_res <- checkFamApp flags fun_app tc fun_args
- ; extra_res <- mapCheck (checkTyEqRhs flags) extra_args
- ; traceTc "Over-sat" (ppr tc <+> ppr tys $$ ppr arity $$ pprPur fun_res $$ pprPur extra_res)
+ ; extra_res <- mapCheck (check_ty_eq_rhs flags) extra_args
; return (mkAppRedns <$> fun_res <*> extra_res) }
| Just ty' <- rewriterView tc_app
-- e.g. S a where type S a = F [a]
-- or type S a = Int
-- See Note [Forgetful synonyms in checkTyConApp]
- = checkTyEqRhs flags ty'
+ = check_ty_eq_rhs flags ty'
| not (isTauTyCon tc || foralls_ok)
= failCheckWith impredicativeProblem
@@ -3411,7 +3571,7 @@ checkTyConApp flags@(TEF { tef_unifying = unifying, tef_foralls = foralls_ok })
recurseIntoTyConApp :: TyEqFlags a -> TyCon -> [TcType] -> TcM (PuResult a Reduction)
recurseIntoTyConApp flags tc tys
- = do { tys_res <- mapCheck (checkTyEqRhs flags) tys
+ = do { tys_res <- mapCheck (check_ty_eq_rhs flags) tys
; return (mkTyConAppRedn Nominal tc <$> tys_res) }
-------------------
@@ -3430,16 +3590,16 @@ checkFamApp flags@(TEF { tef_unifying = unifying, tef_occurs = occ_prob
, tcEqTyConApps lhs_tc lhs_tys tc tys
-> case fam_app_flag of
TEFA_Recurse -> failCheckWith (cteProblem occ_prob)
- TEFA_Break breaker -> breaker fam_app
+ TEFA_Break breaker -> famAppBreaker breaker fam_app
_ | Unifying lhs_info _ _ <- unifying
, isConcreteInfo lhs_info
-> case fam_app_flag of
TEFA_Recurse -> failCheckWith (cteProblem cteConcrete)
- TEFA_Break breaker -> breaker fam_app
+ TEFA_Break breaker -> famAppBreaker breaker fam_app
TEFA_Recurse
- -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys
+ -> do { tys_res <- mapCheck (check_ty_eq_rhs arg_flags) tys
; traceTc "under" (ppr tc $$ pprPur tys_res $$ ppr flags)
; return (mkTyConAppRedn Nominal tc <$> tys_res) }
@@ -3448,16 +3608,16 @@ checkFamApp flags@(TEF { tef_unifying = unifying, tef_occurs = occ_prob
-- alpha[2] ~ Maybe (F beta[4]) Level-check problem: break
-- NB: in the latter case, don't promote beta[4]; hence arg_flags!
TEFA_Break breaker
- -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys
+ -> do { tys_res <- mapCheck (check_ty_eq_rhs arg_flags) tys
; case tys_res of
PuOK cts redns -> return (PuOK cts (mkTyConAppRedn Nominal tc redns))
- PuFail {} -> breaker fam_app }
+ PuFail {} -> famAppBreaker breaker fam_app }
where
arg_flags = famAppArgFlags flags
-------------------
checkTyVar :: forall a. TyEqFlags a -> TcTyVar -> TcM (PuResult a Reduction)
-checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob }) occ_tv
+checkTyVar flags@(TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob }) occ_tv
= case lhs of
TyFamLHS {} -> success -- Nothing to do if the LHS is a type-family
TyVarLHS lhs_tv -> check_tv unifying lhs_tv
@@ -3491,7 +3651,7 @@ checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob
| isConcreteInfo lhs_tv_info
, not (isConcreteTyVar occ_tv)
= if can_make_concrete occ_tv
- then promote lhs_tv lhs_tv_info lhs_tv_lvl
+ then promote lhs_tv_info lhs_tv_lvl
else failCheckWith (cteProblem cteConcrete)
| lvl_occ `strictlyDeeperThan` lhs_tv_lvl
@@ -3500,7 +3660,7 @@ checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob
LC_Check -> failCheckWith (cteProblem cteSkolemEscape)
LC_Promote {}
| isSkolemTyVar occ_tv -> failCheckWith (cteProblem cteSkolemEscape)
- | otherwise -> promote lhs_tv lhs_tv_info lhs_tv_lvl
+ | otherwise -> promote lhs_tv_info lhs_tv_lvl
| otherwise
= simple_occurs_check lhs_tv
@@ -3525,7 +3685,7 @@ checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob
---------------------
-- occ_tv is definitely a MetaTyVar
- promote lhs_tv lhs_tv_info lhs_tv_lvl
+ promote lhs_tv_info lhs_tv_lvl
| MetaTv { mtv_info = info_occ, mtv_tclvl = lvl_occ } <- tcTyVarDetails occ_tv
= do { let new_info | isConcreteInfo lhs_tv_info = lhs_tv_info
| otherwise = info_occ
@@ -3534,12 +3694,23 @@ checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob
-- c[tau,2] ~ p[tau,3]: want to clone p:=p'[tau,2]
-- Check the kind of occ_tv
- ; reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfType (tyVarKind occ_tv))
-
- ; if cterHasNoProblem reason -- Successfully promoted
- then do { new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv
- ; okCheckRefl new_tv_ty }
- else failCheckWith reason }
+ --
+ -- This is important for several reasons:
+ --
+ -- 1. To ensure there is no occurs check or skolem-escape
+ -- in the kind of occ_tv.
+ -- 2. If the LHS is a concrete type variable and the RHS is an
+ -- unfilled meta-tyvar, we need to ensure that the kind of
+ -- 'occ_tv' is concrete. Test cases: T23051, T23176.
+ ; let occ_kind = tyVarKind occ_tv
+ ; kind_result <- check_ty_eq_rhs flags occ_kind
+ ; for kind_result $ \ kind_redn ->
+ do { let kind_co = reductionCoercion kind_redn
+ new_kind = reductionReducedType kind_redn
+ occ_tv' = setTyVarKind occ_tv new_kind
+ ; new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv'
+ ; return $ mkGReflLeftRedn Nominal new_tv_ty (mkSymCo kind_co)
+ } }
| otherwise = pprPanic "promote" (ppr occ_tv)
@@ -3591,16 +3762,15 @@ promote_meta_tyvar info dest_lvl occ_tv
-------------------------
-touchabilityAndShapeTest :: TcLevel -> TcTyVar -> TcType -> Bool
--- This is the key test for untouchability:
+touchabilityTest :: TcLevel -> TcTyVar -> Bool
+-- ^ This is the key test for untouchability:
-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify
-- and Note [Solve by unification] in GHC.Tc.Solver.Equality
--- True <=> touchability and shape are OK
-touchabilityAndShapeTest given_eq_lvl tv rhs
- | MetaTv { mtv_info = info, mtv_tclvl = tv_lvl } <- tcTyVarDetails tv
- , tv_lvl `deeperThanOrSame` given_eq_lvl
- , checkTopShape info rhs
- = True
+--
+-- @True@ <=> the variable is touchable
+touchabilityTest given_eq_lvl tv
+ | MetaTv { mtv_tclvl = tv_lvl } <- tcTyVarDetails tv
+ = tv_lvl `deeperThanOrSame` given_eq_lvl
| otherwise
= False
=====================================
testsuite/tests/rep-poly/T19709b.stderr
=====================================
@@ -1,10 +1,9 @@
-
T19709b.hs:11:15: error: [GHC-55287]
• The argument ‘(error @Any "e2")’ of ‘levfun’
does not have a fixed runtime representation.
Its type is:
- a1 :: TYPE r0
- Cannot unify ‘Any’ with the type variable ‘r0’
+ a0 :: TYPE c0
+ Cannot unify ‘Any’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
• In the first argument of ‘levfun’, namely ‘(error @Any "e2")’
In the first argument of ‘seq’, namely ‘levfun (error @Any "e2")’
=====================================
testsuite/tests/rep-poly/T23154.stderr
=====================================
@@ -8,3 +8,8 @@ T23154.hs:7:1: error: [GHC-52083]
The first pattern in the equation for ‘f’
cannot be assigned a fixed runtime representation, not even by defaulting.
Suggested fix: Add a type signature.
+
+T23154.hs:7:1: error: [GHC-52083]
+ The first pattern in the equation for ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
=====================================
testsuite/tests/rep-poly/T23903.stderr
=====================================
@@ -1,10 +1,9 @@
-
T23903.hs:21:1: error: [GHC-55287]
• The first pattern in the equation for ‘f’
does not have a fixed runtime representation.
Its type is:
- t0 :: TYPE cx0
- Cannot unify ‘Rep a’ with the type variable ‘cx0’
+ Unbox a :: TYPE c0
+ Cannot unify ‘Rep a’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
• The equation for ‘f’ has one visible argument,
but its type ‘a #-> ()’ has none
=====================================
testsuite/tests/simplCore/should_compile/simpl017.stderr
=====================================
@@ -1,20 +1,25 @@
-simpl017.hs:55:12: error: [GHC-46956]
- • Couldn't match type ‘v0’ with ‘v’
- Expected: [E m i] -> E' v m a
- Actual: [E m i] -> E' v0 m a
- because type variable ‘v’ would escape its scope
- This (rigid, skolem) type variable is bound by
- a type expected by the context:
- forall v. [E m i] -> E' v m a
- at simpl017.hs:55:12
- • In the first argument of ‘return’, namely ‘f’
- In a stmt of a 'do' block: return f
+simpl017.hs:55:5: error: [GHC-83865]
+ • Couldn't match type: [E m i] -> E' v0 m a
+ with: forall v. [E m i] -> E' v m a
+ Expected: m (forall v. [E m i] -> E' v m a)
+ Actual: m ([E m i] -> E' v0 m a)
+ • In a stmt of a 'do' block: return f
In the first argument of ‘E’, namely
‘(do let ix :: [E m i] -> m i
ix [i] = runE i
{-# INLINE f #-}
....
return f)’
+ In the expression:
+ E (do let ix :: [E m i] -> m i
+ ix [i] = runE i
+ {-# INLINE f #-}
+ ....
+ return f)
• Relevant bindings include
f :: [E m i] -> E' v0 m a (bound at simpl017.hs:54:9)
+ ix :: [E m i] -> m i (bound at simpl017.hs:52:9)
+ a :: arr i a (bound at simpl017.hs:50:11)
+ liftArray :: arr i a -> E m (forall v. [E m i] -> E' v m a)
+ (bound at simpl017.hs:50:1)
=====================================
testsuite/tests/typecheck/should_compile/T26030.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+
+-- This program was rejected by GHC 9.12 due to a bug with
+-- unification in QuickLook.
+module T26030 where
+
+import Data.Kind
+
+type S :: Type -> Type
+data S a where
+ S1 :: S Bool
+ S2 :: S Char
+
+type F :: Type -> Type
+type family F a where
+ F Bool = Bool
+ F Char = Char
+
+foo :: forall a. S a -> IO (F a)
+foo sa1 = do
+ () <- return ()
+ case sa1 of
+ S1 -> return $ False
+ S2 -> return 'x'
=====================================
testsuite/tests/typecheck/should_compile/T27149.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE TypeFamilies #-}
+module T27149 where
+
+import Data.Kind (Type)
+
+type T :: Type -> Type
+data T a where
+ MkT :: T Bool
+
+type F :: Type -> Type
+type family F a where
+ F Bool = Int
+
+f :: IO (T a) -> (Bool -> Int) -> IO (F a)
+f mt g = do
+ t <- mt
+ case t of
+ MkT -> return $ g True
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -889,6 +889,8 @@ test('T21909', normal, compile, [''])
test('T21909b', normal, compile, [''])
test('T21443', normal, compile, [''])
test('T22194', normal, compile, [''])
+test('T26030', normal, compile, [''])
+test('T27149', normal, compile, [''])
test('QualifiedRecordUpdate',
[ extra_files(['QualifiedRecordUpdate_aux.hs']) ]
, multimod_compile, ['QualifiedRecordUpdate', '-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97981d8bc1596b9e06d10c5938d13c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97981d8bc1596b9e06d10c5938d13c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/aarch64-longjump] driver: enable -finter-module-far-jumps by default
by Magnus (＠MangoIV) 11 May '26
by Magnus (＠MangoIV) 11 May '26
11 May '26
Magnus pushed to branch wip/mangoiv/aarch64-longjump at Glasgow Haskell Compiler / GHC
Commits:
7ce931f5 by mangoiv at 2026-05-11T14:38:03+02:00
driver: enable -finter-module-far-jumps by default
this fixes a compatibility bug with certain binutils/gcc versions where
we were seeing jump offset overflow errors.
This commit can probably reverted if we stop supporting the problematic
binutils/gcc verions (2.44 and 14.2, respectively)
Reolves #26994
- - - - -
3 changed files:
- + changelog.d/inter-module-far-jumps-aarch64-default
- compiler/GHC/Driver/DynFlags.hs
- docs/users_guide/using-optimisation.rst
Changes:
=====================================
changelog.d/inter-module-far-jumps-aarch64-default
=====================================
@@ -0,0 +1,5 @@
+section: driver
+synopsis: enable -finter-module-far-jumps by default on aarch64-linux
+issues: #26994
+mrs: !16016
+description: Some binutils and gcc versions lead to jump offset erros on aarch64-linux profiled/dynamic ways. To mitigate this bug, we enable inter-module-far-jumps by default on this platform.
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -1233,6 +1233,13 @@ defaultFlags settings
Opt_SpecialiseIncoherents,
Opt_WriteSelfRecompInfo
]
+ {- note(mangoiv):
+ - on aarch64 profiled-dynamic, we are seeing jump offset overflow
+ - errors on certain binutils versions. This can probably be deactivated
+ - if we stop supporting binutils 2.44 / GCC 14.2
+ - https://gitlab.haskell.org/ghc/ghc/-/issues/26994 -}
+ ++ [ Opt_InterModuleFarJumps | platformArch platform == ArchAArch64
+ , platformOS platform == OSLinux ]
++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
-- The default -O0 options
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -732,7 +732,7 @@ as such you shouldn't need to set any of them explicitly. A flag
:reverse: -fno-inter-module-far-jumps
:category:
- :default: Off
+ :default: on if the target is AArch64-Linux, off on all others
This flag forces GHC to use far jumps instead of near jumps for all jumps
which cross module boundries. This removes the need for jump islands/linker
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ce931f5b0d7dfcb441ae4a096c5e1e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ce931f5b0d7dfcb441ae4a096c5e1e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-reinstallable-base2] Fix krep stuff
by Simon Peyton Jones (＠simonpj) 11 May '26
by Simon Peyton Jones (＠simonpj) 11 May '26
11 May '26
Simon Peyton Jones pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC
Commits:
50ba27b5 by Simon Peyton Jones at 2026-05-11T13:24:29+01:00
Fix krep stuff
- - - - -
9 changed files:
- compiler/GHC/Builtin.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Tc/Instance/Typeable.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Utils/Env.hs
Changes:
=====================================
compiler/GHC/Builtin.hs
=====================================
@@ -243,10 +243,10 @@ How known-occ entities work
tcLookupKnownOccTyCon :: KnownOcc -> TcM TyCon
dsLookupKnownOccTyCon :: KnownOcc -> DsM TyCon
- The first thing we do is to get the `KnownNameSource`, via `getKnownKeySource`.
+ The first thing we do is to get the `KnownEntitySource`, via `getKnownKeySource`.
There are then two cases, covered in the following sections.
-* Known-occ lookup (normal case: KNS_FromModule)
+* Known-occ lookup (normal case: KES_FromModule)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In normal client code, suppose the desugarer calls
dsLookupKnownKeyTyCon rationalTyConKey
@@ -267,7 +267,7 @@ How known-occ entities work
Now it can simply look up `rationalTyConKey` in the `eps_known_keys`. Easy!
See `GHC.Iface.Load.lookupKnownKeyThing` and `lookupKnownOccThing`.
-* Known-occ lookup (base case: KNS_InScope)
+* Known-occ lookup (base case: KES_InScope)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can't follow the above plan when compiling modules in `base` or `ghc-internal` because
GHC.Essentials has not yet been compiled! Instead, we use (roughly) whatever is in
@@ -277,7 +277,7 @@ How known-occ entities work
* We switch on -frebindable-known-names
- * That ensures that we pass `KNS_InScope gbl_rdr_env` to `lookupKnownKeyThing`
+ * That ensures that we pass `KES_InScope gbl_rdr_env` to `lookupKnownKeyThing`
* Suppose we are looking up the known-occ entity "wombat". The key function is
`lookupKnownGRE`:
@@ -366,6 +366,16 @@ Wrinkles
Alternative: export all wired-in entities from GHC.Essentials. But that
would simply bloat the interface for no good reason.
+(KN4) In a KES_InScope record we keep, for the module being compiled
+ ke_rdr_env :: GlobalRdrEnv
+ ke_gbl_type_env :: TypeEnv
+ ke_lcl_type_env :: TcTypeEnv
+ We need the latter two to support `tcLookupKnownOccId` and friends. We need both
+ the global `TypeEnv` and the local `TcTypeEnv` because during typechecking we
+ keeps types and classes in the global type envt, but `Id`s in the local type envt.
+ (Ids move to the global type env during zonking; see `zonkTopDecls`.)
+
+
Note [Recipe for adding a known-occ name]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To make `wombat` into a known-occ name, you do the following:
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -572,15 +572,16 @@ mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv
* *
********************************************************************* -}
-dsGetKnownKeySource :: DsM KnownNameSource
+dsGetKnownKeySource :: DsM KnownEntitySource
dsGetKnownKeySource
= do { rebindable_path <- goptM Opt_RebindableKnownNames
; if rebindable_path
then do { env <- getGblEnv
- ; return (KNS_InScope (ds_mod env)
- (ds_gbl_rdr_env env)
- (ds_type_env env)) }
- else return KNS_FromModule }
+ ; return (KES_InScope { ke_mod = ds_mod env
+ , ke_rdr_env = ds_gbl_rdr_env env
+ , ke_gbl_type_env = ds_type_env env
+ , ke_lcl_type_env = emptyNameEnv }) }
+ else return KES_FromModule }
--------------------------------------
-- Lookups for known-occ things
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.Iface.Load (
loadGlobalName,
-- Known-occ things
- KnownNameSource(..),
+ KnownEntitySource(..),
lookupKnownKeyThing, lookupKnownKeyName,
lookupKnownOccThing, lookupKnownOccName,
loadKnownKeyOccMaps, lookupKnownGRE,
@@ -155,24 +155,28 @@ import qualified GHC.Unit.Home.Graph as HUG
* *
********************************************************************* -}
-data KnownNameSource
- = KNS_InScope Module GlobalRdrEnv TypeEnv
- -- ^ Look up the known-occ name in this GlobalRdrEnv, which
- -- is the top-level scope of the current module.
+data KnownEntitySource -- See Note [Overview of known entities]
+ = KES_InScope { ke_mod :: Module
+ , ke_rdr_env :: GlobalRdrEnv
+ , ke_gbl_type_env :: TypeEnv
+ , ke_lcl_type_env :: TcTypeEnv }
+ -- ^ Look up the known-occ name in this GlobalRdrEnv/Type, which
+ -- reflect the top-level scope of the current module.
-- This happens when -frebindable-known-name is set, usually when
- -- we are compiling `ghc-internal` or `base`
+ -- we are compiling `ghc-internal` or `base`
+ -- Why both global and local type env? See (KN4) in Note [Overview of known entities]
- | KNS_FromModule
+ | KES_FromModule
-- ^ Look up the known-occ name in the export list of GHC.Essentials
-- This is the "normal path", and happens when -frebindable-known-names
-- is /not/ set
-instance Outputable KnownNameSource where
- ppr KNS_FromModule = text "FromModule"
- ppr (KNS_InScope _ rdr_env _) = text "InScope" <> braces (ppr rdr_env)
+instance Outputable KnownEntitySource where
+ ppr KES_FromModule = text "FromModule"
+ ppr (KES_InScope { ke_rdr_env = rdr_env }) = text "InScope" <> braces (ppr rdr_env)
lookupKnownKeyThing :: HasDebugCallStack
- => KnownKey -> KnownNameSource
+ => KnownKey -> KnownEntitySource
-> IfM lcl (MaybeErr IfaceMessage TyThing)
lookupKnownKeyThing key kk_ns
= do { mb_name <- lookupKnownKeyName key kk_ns
@@ -181,13 +185,13 @@ lookupKnownKeyThing key kk_ns
Succeeded name -> lookupKnownName kk_ns name }
lookupKnownKeyName :: HasDebugCallStack
- => KnownKey -> KnownNameSource
+ => KnownKey -> KnownEntitySource
-> IfM lcl (MaybeErr IfaceMessage Name)
-lookupKnownKeyName key KNS_FromModule
+lookupKnownKeyName key KES_FromModule
= do { (kk_map, _) <- loadKnownKeyOccMaps
; return $ lookupKnownKeysMap kk_map key }
-lookupKnownKeyName key (KNS_InScope _ gbl_rdr_env _)
+lookupKnownKeyName key (KES_InScope { ke_rdr_env = gbl_rdr_env })
-- Just gbl_rdr_env: we have -frebindable-known-names on, and
-- here is the top-level GlobalRdrEnv
-- Look up the /un-qualified/ known-key OccName in the GlobalRdrEnv
@@ -224,7 +228,7 @@ lookupKnownGRE rdr_env occ
gres = lookupGRE rdr_env (LookupOccName occ SameNameSpace)
lookupKnownOccThing :: HasDebugCallStack
- => KnownOcc -> KnownNameSource
+ => KnownOcc -> KnownEntitySource
-> IfM lcl (MaybeErr IfaceMessage TyThing)
lookupKnownOccThing occ kk_ns
= do { mb_name <- lookupKnownOccName occ kk_ns
@@ -233,15 +237,15 @@ lookupKnownOccThing occ kk_ns
Succeeded name -> lookupKnownName kk_ns name }
lookupKnownOccName :: HasDebugCallStack
- => KnownOcc -> KnownNameSource
+ => KnownOcc -> KnownEntitySource
-> IfM lcl (MaybeErr IfaceMessage Name)
-lookupKnownOccName occ KNS_FromModule
+lookupKnownOccName occ KES_FromModule
= do { (_, occ_map) <- loadKnownKeyOccMaps
; case lookupOccEnv occ_map occ of
Just name -> return (Succeeded name)
Nothing -> return (Failed (MissingKnownKey3 occ)) }
-lookupKnownOccName occ (KNS_InScope _ gbl_rdr_env _)
+lookupKnownOccName occ (KES_InScope { ke_rdr_env = gbl_rdr_env })
-- Just gbl_rdr_env: we have -frebindable-known-names on, and
-- here is the top-level GlobalRdrEnv
-- Look up the /un-qualified/ known-occ OccName in the GlobalRdrEnv
@@ -254,20 +258,22 @@ lookupKnownOccName occ (KNS_InScope _ gbl_rdr_env _)
Failed err -> return (Failed err)
lookupKnownName :: HasDebugCallStack
- => KnownNameSource -> Name
+ => KnownEntitySource -> Name
-> IfM lcl (MaybeErr IfaceMessage TyThing)
-- Go from a known Name to its TyThing
--- If we are in KNS_InScope, look up in the current module's type environment
+-- If we are in KES_InScope, look up in the current module's type environment
-- in case it is defined right here in this module rather than imported
lookupKnownName kk_ns name
= case kk_ns of
- KNS_InScope this_mod _ type_env
+ KES_InScope { ke_mod = this_mod, ke_gbl_type_env = type_env, ke_lcl_type_env = lcl_type_env }
| name_mod == this_mod
- -> case lookupTypeEnv type_env name of
- Just thing -> return (Succeeded thing)
- Nothing -> pprPanic "lookupKnownName" (ppr name $$ ppr type_env)
- -- We found the name in the GlobalRdrEnv, but it's
- -- not in the type env. That's a compiler error
+ -> case lookupNameEnv lcl_type_env name of
+ Just (ATcId { tct_id = id }) -> return (Succeeded (AnId id))
+ _ -> case lookupTypeEnv type_env name of
+ Just thing -> return (Succeeded thing)
+ Nothing -> pprPanic "lookupKnownName" (ppr name $$ ppr type_env)
+ -- We found the name in the GlobalRdrEnv, but it's
+ -- not in the type env. That's a compiler error
_ -> loadGlobalName name name_mod
where
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -983,7 +983,7 @@ mk_top_id (IfGblTopBndr gbl_name)
-- rather than the current module so we need this special case.
-- See some similar logic in `GHC.Rename.Env`.
| Just rOOT_MAIN == nameModule_maybe gbl_name
- = lookupKnownOccThing ioTyConOcc KNS_FromModule >>= \case
+ = lookupKnownOccThing ioTyConOcc KES_FromModule >>= \case
Failed err -> failIfM (pprDiagnostic err)
Succeeded ioTyThing -> do
ATyCon ioTyCon <- pure ioTyThing
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -1041,16 +1041,16 @@ rnLookupKnownOccName occ
Succeeded name -> return name }
lookup_known_occ :: HasDebugCallStack
- => KnownNameSource -> KnownOcc
+ => KnownEntitySource -> KnownOcc
-> RnM (MaybeErr IfaceMessage Name)
-lookup_known_occ KNS_FromModule occ
+lookup_known_occ KES_FromModule occ
= do { (_, occ_map) <- initIfaceTcRn loadKnownKeyOccMaps
; case lookupOccEnv occ_map occ of
Just name -> return (Succeeded name)
Nothing -> return (Failed (MissingKnownKey3 occ)) }
-lookup_known_occ (KNS_InScope _ gbl_rdr_env _) occ
- = case lookupKnownGRE gbl_rdr_env occ of
+lookup_known_occ (KES_InScope { ke_rdr_env = rdr_env }) occ
+ = case lookupKnownGRE rdr_env occ of
Succeeded gre -> do { addUsedGRE NoDeprecationWarnings gre
; let name = greName gre
; traceIf $ hang (text "lookupKnownKeyOcc NoImplicitKnownKeyNames")
=====================================
compiler/GHC/Tc/Instance/Typeable.hs
=====================================
@@ -22,7 +22,6 @@ import GHC.Tc.Utils.TcType
import GHC.Iface.Env( newGlobalBinder )
import GHC.Builtin.Modules( gHC_TYPES, gHC_PRIM )
-import GHC.Builtin.KnownKeys
import GHC.Builtin.KnownOccs
import GHC.Builtin.WiredIn.Prim ( primTyCons )
import GHC.Builtin.WiredIn.Types
@@ -645,12 +644,12 @@ liftTc = KindRepM . lift
-- | We generate `KindRep`s for a few common kinds, so that they
-- can be reused across modules.
-- These definitions are generated in `ghc-prim:GHC.Types`.
-builtInKindReps :: [(Kind, Name)]
+builtInKindReps :: [(Kind, KnownOcc)]
builtInKindReps =
- [ (star, starKindRepName)
- , (constraintKind, constraintKindRepName)
- , (mkVisFunTyMany star star, starArrStarKindRepName)
- , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName)
+ [ (star, mkVarOcc "krepStar")
+ , (constraintKind, mkVarOcc "krepConstraint")
+ , (mkVisFunTyMany star star, mkVarOcc "krepStarArr")
+ , (mkVisFunTysMany [star, star] star, mkVarOcc "krepStarArrStarArr")
]
where
star = liftedTypeKind
@@ -658,8 +657,8 @@ builtInKindReps =
initialKindRepEnv :: TcRn KindRepEnv
initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
where
- add_kind_rep acc (k,n) = do
- id <- tcLookupId n
+ add_kind_rep acc (k,occ) = do
+ id <- tcLookupKnownOccId occ
return $! extendTypeMap acc k (id, Nothing)
-- The TypeMap looks through type synonyms
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -578,7 +578,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
; return (tcg_env `addEvBinds` ev_binds) }
-- Emit Typeable bindings
- ; tcg_env <- setGblEnv tcg_env $
+ ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $
mkTypeableBinds
; traceTc "Tc9" empty
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -122,7 +122,8 @@ data TcLclCtxt
tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context
tcl_env :: TcTypeEnv -- The local type environment:
- -- Ids and TyVars defined in this module
+ -- Ids and TyVars defined in this module
+ -- They move to the TcGbl env during zonkTopDecls
}
getLclEnvThLevel :: TcLclEnv -> ThLevel
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -517,19 +517,21 @@ tcMetaTy tc_name
= do { t <- tcLookupTyCon tc_name
; return (mkTyConTy t) }
-getKnownKeySource :: TcRn KnownNameSource
+getKnownKeySource :: TcRn KnownEntitySource
-- Used by both renamer and typechecker and renamer
getKnownKeySource
= do { rebindable_path <- goptM Opt_RebindableKnownNames
; if rebindable_path
- then do { env <- getGblEnv
- ; return (KNS_InScope (tcg_mod env)
- (tcg_rdr_env env)
- (tcg_type_env env)) }
- else return KNS_FromModule }
+ then do { gbl_env <- getGblEnv
+ ; lcl_type_env <- getLclTypeEnv
+ ; return (KES_InScope { ke_mod = tcg_mod gbl_env
+ , ke_rdr_env = tcg_rdr_env gbl_env
+ , ke_gbl_type_env = tcg_type_env gbl_env
+ , ke_lcl_type_env = lcl_type_env }) }
+ else return KES_FromModule }
tcrn_wrapper :: HasDebugCallStack
- => (KnownNameSource -> IfG (MaybeErr IfaceMessage a)) -> TcRn a
+ => (KnownEntitySource -> IfG (MaybeErr IfaceMessage a)) -> TcRn a
tcrn_wrapper do_the_lookup
= do { kk_source <- getKnownKeySource
; mb_res <- initIfaceTcRn (do_the_lookup kk_source)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50ba27b54ab9efc70036655157d9cbb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50ba27b54ab9efc70036655157d9cbb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0