[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 9 commits: EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
by Alan Zimmerman (＠alanz) 19 Jun '26
by Alan Zimmerman (＠alanz) 19 Jun '26
19 Jun '26
Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
54b9a5cf by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
This is part of a refactor towards only having LocatedA / SrcSpanAnnA
It removes the stated items, but has to add back one for BooleanFormula,
LocatedBF / SrcSpanAnnBF
This commit also use the HsConDetails RecCon extension point to
capture the braces in a record constructor
- - - - -
776c88ef by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Remove LocatedC / SrcSpanAnnC
Used for contexts
- - - - -
8f1c6b2b by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Harmonise HsQual/HsQualTy TTG extension annotations
- - - - -
efbbef72 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA Remove LocatedLC / LocatedLS
LocatedLC/LocatedLS were unused
- - - - -
4e34d0c0 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Remove LocatedLW from LStmtLR
- - - - -
2d681478 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Remove LocatedLW from MatchGroup
This is the last usage of LocatedLW / SrcSpanAnnLW
- - - - -
d773b871 by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Move the 'where' annotation for PatSynBind
This allows us to move it out of the MatchGroup exact print annotation
too
- - - - -
b92ee0df by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: Replace AnnListItem with simply [TrailingAnn]
Remove the unnecessary wrapper around a single field.
- - - - -
fb1f5a2d by Alan Zimmerman at 2026-06-18T23:22:04+01:00
Keep binds and sigs together in HsValBindsLR
TBD
- - - - -
94 changed files:
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/Language/Haskell/Syntax/Type.hs
- ghc/GHCi/UI.hs
- testsuite/tests/ghc-api/T25121_status.stdout
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15279.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/typecheck/should_compile/T15242.stderr
- testsuite/tests/typecheck/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/342e27cee9a1655316dcaf2e804448…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/342e27cee9a1655316dcaf2e804448…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/epa-tidy-locatedxxx-1] EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
by Alan Zimmerman (＠alanz) 19 Jun '26
by Alan Zimmerman (＠alanz) 19 Jun '26
19 Jun '26
Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-1 at Glasgow Haskell Compiler / GHC
Commits:
54b9a5cf by Alan Zimmerman at 2026-06-18T23:22:04+01:00
EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
This is part of a refactor towards only having LocatedA / SrcSpanAnnA
It removes the stated items, but has to add back one for BooleanFormula,
LocatedBF / SrcSpanAnnBF
This commit also use the HsConDetails RecCon extension point to
capture the braces in a record constructor
- - - - -
61 changed files:
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- ghc/GHCi/UI.hs
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54b9a5cf19e79f9b089846b626a9d49…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/54b9a5cf19e79f9b089846b626a9d49…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
19 Jun '26
Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-1 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-1
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 13 commits: Desugar a `case` scrutinee only once (#27383, #20251)
by Alan Zimmerman (＠alanz) 19 Jun '26
by Alan Zimmerman (＠alanz) 19 Jun '26
19 Jun '26
Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
67d41299 by Sebastian Graf at 2026-06-18T05:18:24-04:00
Desugar a `case` scrutinee only once (#27383, #20251)
In `dsExpr` for `HsCase` we desugared the scrutinee /twice/: once to
build the Core `case` itself, and again inside `matchWrapper`, which
re-desugared the source scrutinee (via `addHsScrutTmCs`) purely to
record long-distance information for the pattern-match checker.
For a single `case` that is merely wasteful. But for nested cases it
is catastrophic. Consider
case (case (case e of ... ) of ... ) of ...
Desugaring the outer scrutinee desugars the middle `case` twice, each
of which desugars the inner `case` twice, and so on. The work doubles
at every level, so desugaring takes O(2^n) time in the nesting depth.
That is the blowup reported in #27383; it is also what makes the
machine-generated program in #20251 take an age to compile.
The fix is simple. `matchWrapper` is handed the scrutinee anyway, so
we give it the Core expression we have /already/ desugared, and record
the long-distance term constraint with `addCoreScrutTmCs` instead of
re-desugaring from source. This is just what `matchSinglePatVar`
already does for single-pattern matches.
So:
* `matchWrapper` now takes `Maybe [CoreExpr]` rather than
`Maybe [LHsExpr GhcTc]`.
* The `HsCase` equation of `dsExpr` passes the already-desugared
`core_discrim`; the arrow desugarer passes its match variables.
* `addHsScrutTmCs` had no other use, so it is gone.
Desugaring is now linear in the nesting depth. (The coverage checker
still runs `simpleOptExpr` over each scrutinee, which leaves the total
at O(n^2); that is ample.) The long-distance information itself is
unchanged: the checker sees precisely the Core that backs the
generated code.
Test: deSugar/should_compile/T27383
- - - - -
fa5defde by Rodrigo Mesquita at 2026-06-18T05:19:11-04:00
fix: Save FastStrings in the PMC
There is no point in adding the unique to the occurrence FastString we
create, since it is part of the Id anyway.
Adding it to the FastString, meant each FastString was unique
unnecessarily!
In a separate branch, running the compiler on test `InstanceMatching`
observed 30000 `FastString`s created by this code path.
Plus, `fsLit "pm"` follows the existing pattern in `mkPmId`.
- - - - -
4efb4a66 by Alan Zimmerman at 2026-06-18T14:41:14-04:00
TTG: Add extension points to HsConDetails
Extend HsConDetails as
data HsConDetails p arg rec
= PrefixCon !(XPrefixCon p) [arg] -- C @t1 @t2 p1 p2 p3
| RecCon !(XRecCon p) rec -- C { x = p1, y = p2 }
| InfixCon !(XInfixCon p) arg arg -- p1 `C` p2
| XHsConDetails !(XXHsConDetails p)
type family XPrefixCon p
type family XRecCon p
type family XInfixCon p
type family XXHsConDetails p
- - - - -
c8d27dd4 by Simon Jakobi at 2026-06-18T14:41:59-04:00
CI: quiet submodule clean output in after_script and setup
The clean and cleanup_submodules functions ran 'git submodule foreach
git clean -xdf', flooding the job log with 'Entering ...' and
'Removing ...' lines. Pass --quiet to 'git submodule' and -q to 'git
clean' to drop the success output; errors are still reported.
Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
91f24930 by Alan Zimmerman at 2026-06-18T22:20:59+01:00
EPA: remove LocatedL / SrcSpanAnnL and LocatedLI / SrcSpanAnnLI
This is part of a refactor towards only having LocatedA / SrcSpanAnnA
It removes the stated items, but has to add back one for BooleanFormula,
LocatedBF / SrcSpanAnnBF
This commit also use the HsConDetails RecCon extension point to
capture the braces in a record constructor
- - - - -
e5091eb3 by Alan Zimmerman at 2026-06-18T22:23:28+01:00
EPA: Remove LocatedC / SrcSpanAnnC
Used for contexts
- - - - -
063683fd by Alan Zimmerman at 2026-06-18T22:23:28+01:00
EPA: Harmonise HsQual/HsQualTy TTG extension annotations
- - - - -
09cebf4b by Alan Zimmerman at 2026-06-18T22:26:56+01:00
EPA Remove LocatedLC / LocatedLS
LocatedLC/LocatedLS were unused
- - - - -
32e1e58c by Alan Zimmerman at 2026-06-18T22:26:56+01:00
EPA: Remove LocatedLW from LStmtLR
- - - - -
17f74912 by Alan Zimmerman at 2026-06-18T22:26:56+01:00
EPA: Remove LocatedLW from MatchGroup
This is the last usage of LocatedLW / SrcSpanAnnLW
- - - - -
d87c5fd7 by Alan Zimmerman at 2026-06-18T22:26:56+01:00
EPA: Move the 'where' annotation for PatSynBind
This allows us to move it out of the MatchGroup exact print annotation
too
- - - - -
db6b172a by Alan Zimmerman at 2026-06-18T22:26:56+01:00
EPA: Replace AnnListItem with simply [TrailingAnn]
Remove the unnecessary wrapper around a single field.
- - - - -
342e27ce by Alan Zimmerman at 2026-06-18T22:26:56+01:00
Keep binds and sigs together in HsValBindsLR
TBD
- - - - -
113 changed files:
- .gitlab/ci.sh
- + changelog.d/fix-exponential-case-desugar-27383
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match.hs-boot
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Parser/Types.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/Language/Haskell/Syntax/Type.hs
- ghc/GHCi/UI.hs
- + testsuite/tests/deSugar/should_compile/T27383.hs
- testsuite/tests/deSugar/should_compile/all.T
- testsuite/tests/ghc-api/T25121_status.stdout
- testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T15279.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/parser/should_compile/T20718.stderr
- testsuite/tests/parser/should_compile/T20718b.stderr
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/printer/AnnotationNoListTuplePuns.stdout
- testsuite/tests/printer/Makefile
- testsuite/tests/printer/T18791.stderr
- testsuite/tests/printer/Test20297.stdout
- testsuite/tests/printer/Test24533.stdout
- testsuite/tests/typecheck/should_compile/T15242.stderr
- testsuite/tests/typecheck/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8303cbb63be13da227a7417edbea4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8303cbb63be13da227a7417edbea4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Jaro Reinders pushed to branch wip/ad-hoc-lazifier at Glasgow Haskell Compiler / GHC
Commits:
18dd2fbc by Jaro Reinders at 2026-06-18T21:03:23+02:00
Inline fromLazy#
- - - - -
6 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/Layout.hs
- compiler/GHC/StgToCmm/Prim.hs
- rts/PrimOps.cmm
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Builtin.PrimOps (
PrimOpEffect(..), primOpEffect,
- getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..),
+ getPrimOpResultKind, isComparisonPrimOp,
PrimCall(..)
) where
@@ -872,30 +872,12 @@ primOpSig op
Compare _occ ty -> ([], [ty,ty], intPrimTy)
GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty )
-data PrimOpResultInfo
- = ReturnsVoid
- | ReturnsPrim PrimRep
- | ReturnsTuple
-
--- Some PrimOps need not return a manifest primitive or algebraic value
--- (i.e. they might return a polymorphic value). These PrimOps *must*
--- be out of line, or the code generator won't work.
-
-getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-getPrimOpResultInfo op
- = case (primOpInfo op) of
- Compare _ _ -> ReturnsPrim IntRep
- GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of
- [] -> ReturnsVoid
- [rep] -> ReturnsPrim rep
- _ -> pprPanic "getPrimOpResultInfo" (ppr op)
- | isUnboxedTupleTyCon tc -> ReturnsTuple
- | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op)
- where
- tc = tyConAppTyCon ty
- -- All primops return a tycon-app result
- -- The tycon can be an unboxed tuple or sum, though,
- -- which gives rise to a ReturnAlg
+-- Will crash for primops with representation or levity polymorphic result types
+getPrimOpResultKind:: PrimOp -> Kind
+getPrimOpResultKind op
+ = case primOpInfo op of
+ Compare _ _ -> typeKind intPrimTy
+ GenPrimOp _ _ _ ty -> typeKind ty
{-
We do not currently make use of whether primops are commutable.
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -4291,12 +4291,12 @@ primop VecSqrtOp "sqrt#" GenPrimOp
{ Element-wise square root. }
with vector = FLOAT_VECTOR_TYPES
-primop LazyOp "toLazy#" GenPrimOp
+primop ToLazyOp "toLazy#" GenPrimOp
a_unlifted -> Lazy a_unlifted
{ comment }
with effect = CanFail
-primop UnlazyOp "fromLazy#" GenPrimOp
+primop FromLazyOp "fromLazy#" GenPrimOp
Lazy a_unlifted -> a_unlifted
{ comment }
with effect = CanFail
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -1183,84 +1183,6 @@ cgIdApp fun_id args = do
-- DynFlags, then passed to StgToCmmConfig for this phase.
-emitEnter :: CmmExpr -> FCode ReturnKind
-emitEnter fun = do
- { platform <- getPlatform
- ; profile <- getProfile
- ; adjustHpBackwards
- ; sequel <- getSequel
- ; updfr_off <- getUpdFrameOff
- ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
- ; case sequel of
- -- For a return, we have the option of generating a tag-test or
- -- not. If the value is tagged, we can return directly, which
- -- is quicker than entering the value. This is a code
- -- size/speed trade-off: when optimising for speed rather than
- -- size we could generate the tag test.
- --
- -- Right now, we do what the old codegen did, and omit the tag
- -- test, just generating an enter.
- Return -> do
- { let entry = entryCode platform
- $ closureInfoPtr platform align_check
- $ CmmReg (nodeReg platform)
- ; emit $ mkJump profile NativeNodeCall entry
- [cmmUntag platform fun] updfr_off
- ; return AssignedDirectly
- }
-
- -- The result will be scrutinised in the sequel. This is where
- -- we generate a tag-test to avoid entering the closure if
- -- possible.
- --
- -- The generated code will be something like this:
- --
- -- R1 = fun -- copyout
- -- if (fun & 7 != 0) goto Lret else goto Lcall
- -- Lcall:
- -- call [fun] returns to Lret
- -- Lret:
- -- fun' = R1 -- copyin
- -- ...
- --
- -- Note in particular that the label Lret is used as a
- -- destination by both the tag-test and the call. This is
- -- because Lret will necessarily be a proc-point, and we want to
- -- ensure that we generate only one proc-point for this
- -- sequence.
- --
- -- Furthermore, we tell the caller that we generated a native
- -- return continuation by returning (ReturnedTo Lret off), so
- -- that the continuation can be reused by the heap-check failure
- -- code in the enclosing case expression.
- --
- AssignTo res_regs _ -> do
- { lret <- newBlockId
- ; lcall <- newBlockId
- ; updfr_off <- getUpdFrameOff
- ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
- ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []
- ; let area = Young lret
- ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area
- [fun] updfr_off []
- -- refer to fun via nodeReg after the copyout, to avoid having
- -- both live simultaneously; this sometimes enables fun to be
- -- inlined in the RHS of the R1 assignment.
- ; let node = CmmReg $ nodeReg platform
- entry = entryCode platform (closureInfoPtr platform align_check node)
- the_call = toCall entry (Just lret) updfr_off off outArgs regs
- ; tscope <- getTickScope
- ; emit $
- copyout <*>
- mkCbranch (cmmIsTagged platform node)
- lret lcall Nothing <*>
- outOfLine lcall (the_call,tscope) <*>
- mkLabel lret tscope <*>
- copyin
- ; return (ReturnedTo lret off)
- }
- }
-
------------------------------------------------------------------------
-- Ticks
------------------------------------------------------------------------
=====================================
compiler/GHC/StgToCmm/Layout.hs
=====================================
@@ -11,6 +11,7 @@
module GHC.StgToCmm.Layout (
mkArgDescr,
emitCall, emitReturn, adjustHpBackwards,
+ emitEnter,
emitClosureProcAndInfoTable,
emitClosureAndInfoTable,
@@ -693,3 +694,81 @@ emitClosureAndInfoTable platform info_tbl conv args body
; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl)
; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
}
+
+emitEnter :: CmmExpr -> FCode ReturnKind
+emitEnter fun = do
+ { platform <- getPlatform
+ ; profile <- getProfile
+ ; adjustHpBackwards
+ ; sequel <- getSequel
+ ; updfr_off <- getUpdFrameOff
+ ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
+ ; case sequel of
+ -- For a return, we have the option of generating a tag-test or
+ -- not. If the value is tagged, we can return directly, which
+ -- is quicker than entering the value. This is a code
+ -- size/speed trade-off: when optimising for speed rather than
+ -- size we could generate the tag test.
+ --
+ -- Right now, we do what the old codegen did, and omit the tag
+ -- test, just generating an enter.
+ Return -> do
+ { let entry = entryCode platform
+ $ closureInfoPtr platform align_check
+ $ CmmReg (nodeReg platform)
+ ; emit $ mkJump profile NativeNodeCall entry
+ [cmmUntag platform fun] updfr_off
+ ; return AssignedDirectly
+ }
+
+ -- The result will be scrutinised in the sequel. This is where
+ -- we generate a tag-test to avoid entering the closure if
+ -- possible.
+ --
+ -- The generated code will be something like this:
+ --
+ -- R1 = fun -- copyout
+ -- if (fun & 7 != 0) goto Lret else goto Lcall
+ -- Lcall:
+ -- call [fun] returns to Lret
+ -- Lret:
+ -- fun' = R1 -- copyin
+ -- ...
+ --
+ -- Note in particular that the label Lret is used as a
+ -- destination by both the tag-test and the call. This is
+ -- because Lret will necessarily be a proc-point, and we want to
+ -- ensure that we generate only one proc-point for this
+ -- sequence.
+ --
+ -- Furthermore, we tell the caller that we generated a native
+ -- return continuation by returning (ReturnedTo Lret off), so
+ -- that the continuation can be reused by the heap-check failure
+ -- code in the enclosing case expression.
+ --
+ AssignTo res_regs _ -> do
+ { lret <- newBlockId
+ ; lcall <- newBlockId
+ ; updfr_off <- getUpdFrameOff
+ ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
+ ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []
+ ; let area = Young lret
+ ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area
+ [fun] updfr_off []
+ -- refer to fun via nodeReg after the copyout, to avoid having
+ -- both live simultaneously; this sometimes enables fun to be
+ -- inlined in the RHS of the R1 assignment.
+ ; let node = CmmReg $ nodeReg platform
+ entry = entryCode platform (closureInfoPtr platform align_check node)
+ the_call = toCall entry (Just lret) updfr_off off outArgs regs
+ ; tscope <- getTickScope
+ ; emit $
+ copyout <*>
+ mkCbranch (cmmIsTagged platform node)
+ lret lcall Nothing <*>
+ outOfLine lcall (the_call,tscope) <*>
+ mkLabel lret tscope <*>
+ copyin
+ ; return (ReturnedTo lret off)
+ }
+ }
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.StgToCmm.Prof ( costCentreFrom )
import GHC.Types.Basic
import GHC.Types.Literal.Floating
+import GHC.Types.RepType (kindPrimRep_maybe)
import GHC.Cmm.BlockId
import GHC.Cmm.Graph
import GHC.Stg.Syntax
@@ -858,9 +859,11 @@ emitPrimOp cfg primop =
WriteByteArrayOp_Word8AsWord64 -> \args -> inlinePrimop $ \res ->
doWriteByteArrayOp Nothing b8 res args
- -- TODO: make these inline
- LazyOp -> \args -> externalPrimop primop args
- UnlazyOp -> \args -> externalPrimop primop args
+ ToLazyOp -> \args -> externalPrimop primop args
+ FromLazyOp -> \[addr] -> inlinePrimop $ \[res] -> do
+ platform <- getPlatform
+ _ <- withSequel (AssignTo [res] False) (emitEnter addr)
+ emitAssign (CmmLocal res) (cmmUntag platform (CmmReg (CmmLocal res)))
-- Copying and setting byte arrays
CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> inlinePrimop $ \[] ->
@@ -1859,7 +1862,6 @@ emitPrimOp cfg primop =
where
profile = stgToCmmProfile cfg
platform = stgToCmmPlatform cfg
- result_info = getPrimOpResultInfo primop
opNop :: [CmmExpr] -> PrimopCmmEmit
opNop args = inlinePrimop $ \[res] -> emitAssign (CmmLocal res) arg
@@ -1913,15 +1915,10 @@ emitPrimOp cfg primop =
inlinePrimopWithReturnType f = PrimopCmmEmit
{ primopCmmInline = True
, primopCmmCode = \res_ty -> do
- regs <- case result_info of
- ReturnsVoid -> pure []
- ReturnsPrim rep
- -> do reg <- newTemp (primRepCmmType platform rep)
- pure [reg]
-
- ReturnsTuple
- -> do (regs, _hints) <- newUnboxedTupleRegs res_ty
- pure regs
+ regs <-
+ case kindPrimRep_maybe (getPrimOpResultKind primop) of
+ Nothing -> panic "Primop result kind has no runtime representation!"
+ Just reps -> mapM (newTemp . primRepCmmType platform) reps
f res_ty regs
emitReturn (map (CmmReg . CmmLocal) regs)
}
=====================================
rts/PrimOps.cmm
=====================================
@@ -121,12 +121,6 @@ stg_newByteArrayzh ( W_ n )
return (p);
}
-stg_fromLazzyzh ( P_ p )
-{
- (P_ unlifted) = call stg_ap_0_fast(p);
- return (UNTAG(unlifted));
-}
-
stg_toLazzyzh ( P_ p )
{
if (GET_INFO(p) == stg_ARR_WORDS_info) {
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18dd2fbc280789bbb86d0bf0fea3127…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18dd2fbc280789bbb86d0bf0fea3127…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/27401-2] 3 commits: TTG: Add extension points to HsConDetails
by Rodrigo Mesquita (＠alt-romes) 19 Jun '26
by Rodrigo Mesquita (＠alt-romes) 19 Jun '26
19 Jun '26
Rodrigo Mesquita pushed to branch wip/romes/27401-2 at Glasgow Haskell Compiler / GHC
Commits:
4efb4a66 by Alan Zimmerman at 2026-06-18T14:41:14-04:00
TTG: Add extension points to HsConDetails
Extend HsConDetails as
data HsConDetails p arg rec
= PrefixCon !(XPrefixCon p) [arg] -- C @t1 @t2 p1 p2 p3
| RecCon !(XRecCon p) rec -- C { x = p1, y = p2 }
| InfixCon !(XInfixCon p) arg arg -- p1 `C` p2
| XHsConDetails !(XXHsConDetails p)
type family XPrefixCon p
type family XRecCon p
type family XInfixCon p
type family XXHsConDetails p
- - - - -
c8d27dd4 by Simon Jakobi at 2026-06-18T14:41:59-04:00
CI: quiet submodule clean output in after_script and setup
The clean and cleanup_submodules functions ran 'git submodule foreach
git clean -xdf', flooding the job log with 'Entering ...' and
'Removing ...' lines. Pass --quiet to 'git submodule' and -q to 'git
clean' to drop the success output; errors are still reported.
Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
90fbaf5c by Rodrigo Mesquita at 2026-06-18T19:56:21+01:00
perf: Share Module in Iface Symbol Table
This commit modifies the structure of the serialized `SymbolTable Name`
to then re-use and share the `Module` (both on disk and in memory) across
all `Name`s from the same module.
The new structure looks like:
<total name count>
$modules.size
for (mod, names) in $modules:
$mod
$names.size
for table_ix, occ in $names
$table_ix
$occ
i.e. we put the module just once, followed by all names in that module.
When deserializing, we deserialize the module just once, and all the
following `Name`s are constructed with a pointer to that same decoded
`Module`.
Fixes #27401
- - - - -
53 changed files:
- .gitlab/ci.sh
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Unit/Module/Env.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/Language/Haskell/Syntax/Type.hs
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3b3affb0427149846a0e979e1d751…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c3b3affb0427149846a0e979e1d751…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] CI: quiet submodule clean output in after_script and setup
by Marge Bot (＠marge-bot) 19 Jun '26
by Marge Bot (＠marge-bot) 19 Jun '26
19 Jun '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c8d27dd4 by Simon Jakobi at 2026-06-18T14:41:59-04:00
CI: quiet submodule clean output in after_script and setup
The clean and cleanup_submodules functions ran 'git submodule foreach
git clean -xdf', flooding the job log with 'Entering ...' and
'Removing ...' lines. Pass --quiet to 'git submodule' and -q to 'git
clean' to drop the success output; errors are still reported.
Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com>
- - - - -
1 changed file:
- .gitlab/ci.sh
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -441,7 +441,7 @@ function cleanup_submodules() {
# is not valid. Avoid failing in this case with the following insanity.
git submodule sync || git submodule deinit --force --all
git submodule update --init
- git submodule foreach git clean -xdf
+ git submodule --quiet foreach git clean -xdfq
else
info "Not cleaning submodules, not in a git repo"
fi;
@@ -934,8 +934,8 @@ function clean() {
# uploaded. Keep in sync with `jobArtifacts` in
# `.gitlab/generate-ci/gen_ci.hs`!
if [[ "${CI_DISPOSABLE_ENVIRONMENT:-}" != true ]]; then
- git submodule foreach --recursive git clean -xdf
- git clean -xdf \
+ git submodule --quiet foreach --recursive git clean -xdfq
+ git clean -xdfq \
--exclude=ci_timings.txt \
--exclude=ghc-*.tar.xz \
--exclude=junit.xml \
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8d27dd428e961a16fde9b2940c9e4a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8d27dd428e961a16fde9b2940c9e4a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] TTG: Add extension points to HsConDetails
by Marge Bot (＠marge-bot) 19 Jun '26
by Marge Bot (＠marge-bot) 19 Jun '26
19 Jun '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4efb4a66 by Alan Zimmerman at 2026-06-18T14:41:14-04:00
TTG: Add extension points to HsConDetails
Extend HsConDetails as
data HsConDetails p arg rec
= PrefixCon !(XPrefixCon p) [arg] -- C @t1 @t2 p1 p2 p3
| RecCon !(XRecCon p) rec -- C { x = p1, y = p2 }
| InfixCon !(XInfixCon p) arg arg -- p1 `C` p2
| XHsConDetails !(XXHsConDetails p)
type family XPrefixCon p
type family XRecCon p
type family XInfixCon p
type family XXHsConDetails p
- - - - -
49 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/Language/Haskell/Syntax/Type.hs
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/parser/should_compile/T20452.stderr
- testsuite/tests/printer/Test24533.stdout
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4efb4a66de6bc32feafdc85383488a5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4efb4a66de6bc32feafdc85383488a5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sg/first-class-strict] 2 commits: Strict: STG representation and code generation
by Sebastian Graf (＠sgraf812) 19 Jun '26
by Sebastian Graf (＠sgraf812) 19 Jun '26
19 Jun '26
Sebastian Graf pushed to branch wip/sg/first-class-strict at Glasgow Haskell Compiler / GHC
Commits:
1485c1ae by I-Al-Istannen at 2026-06-18T20:37:14+02:00
Strict: STG representation and code generation
Treats Strict a as a single unlifted heap pointer through RepType,
unarisation, STG lint, tag inference and StgToCmm: an unlifted box is already
evaluated and properly tagged, so it is returned directly unless applied as a
function. An STG Lint check flags an evaluated binder lowered to an updatable
indirection.
Co-authored-by: Sebastian Graf <sgraf1337(a)gmail.com>
- - - - -
1ca509da by Sebastian Graf at 2026-06-18T20:37:14+02:00
Strict: add a should_run test for the strict-field machinery
StrictBox exercises a strict value field built from a thunk (forced to an
evaluated, properly-tagged value), a strict field of function type that is
applied, worker/wrapper unboxing of a strict argument, and a strict field
holding another boxed value. Run with -dtag-inference-checks so that a strict
field that is not properly tagged aborts at runtime.
- - - - -
15 changed files:
- compiler/GHC/Builtin/PrimOps/Casts.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/StgToCmm/TagCheck.hs
- compiler/GHC/Types/RepType.hs
- + testsuite/tests/codeGen/should_run/StrictBox.hs
- + testsuite/tests/codeGen/should_run/StrictBox.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout
- testsuite/tests/ghci.debugger/scripts/print007.stdout
- testsuite/tests/ghci.debugger/scripts/print022.stdout
- testsuite/tests/simplStg/should_compile/T15226b.stderr
Changes:
=====================================
compiler/GHC/Builtin/PrimOps/Casts.hs
=====================================
@@ -53,6 +53,10 @@ getCasts from_rep to_rep
| -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $
to_rep == from_rep
= []
+ | from_rep == BoxedRep (Just Lifted) && to_rep == BoxedRep (Just Unlifted)
+ = []
+ | to_rep == BoxedRep (Just Lifted) && from_rep == BoxedRep (Just Unlifted)
+ = []
-- Float <-> Double
| to_rep == FloatRep =
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -101,7 +101,7 @@ import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Core.DataCon
-import GHC.Core ( AltCon(..) )
+import GHC.Core ( AltCon(..), isEvaldUnfolding )
import GHC.Core.Type
import GHC.Core.Lint ( lintMessage )
@@ -126,6 +126,7 @@ import Control.Monad
import GHC.Core.Multiplicity (scaledThing)
import GHC.Settings (Platform)
import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
+import GHC.Builtin.Types (isStrictTy)
lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
=> Platform
@@ -230,8 +231,23 @@ lint_binds_help top_lvl (binder, rhs)
-- Check binder doesn't have unlifted type or it's a join point
checkL ( isJoinId binder
|| not (isUnliftedType (idType binder))
+ || isNiceStrict -- Allow Strict bindings for now. They should be in HNF.
|| isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed
(mkUnliftedTyMsg opts binder rhs)
+ -- See Note [The Strict type] in GHC.Builtin.Types: a binder known to be
+ -- evaluated (an evald unfolding) must not be lowered to an updatable
+ -- indirection, which would turn an EPT value into a non-EPT thunk. An
+ -- evaluated indirection should have been shortened away instead.
+ when (not (isTopLevel top_lvl)) $
+ checkL (not (isEvaldUnfolding (idUnfolding binder)) || not (isUpdatableIndirection rhs))
+ (mkEvaldUpdatableMsg opts binder rhs)
+ where
+ isNiceStrict = isStrictTy (idType binder) && not (isRhsUpdatable rhs)
+ isRhsUpdatable (StgRhsClosure _ _ flag _ _ _) = isUpdatable flag
+ isRhsUpdatable (StgRhsCon {}) = False
+ -- An updatable thunk whose body is just a reference to another variable.
+ isUpdatableIndirection (StgRhsClosure _ _ flag [] (StgApp _ []) _) = isUpdatable flag
+ isUpdatableIndirection _ = False
-- | Top-level bindings can't inherit the cost centre stack from their
-- (static) allocation site.
@@ -566,3 +582,10 @@ mkUnliftedTyMsg opts binder rhs
text "has unlifted type" <+> quotes (ppr (idType binder)))
$$
(text "RHS:" <+> pprStgRhs opts rhs)
+
+mkEvaldUpdatableMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
+mkEvaldUpdatableMsg opts binder rhs
+ = (text "Let binder" <+> quotes (ppr binder) <+>
+ text "has an evaluated unfolding but an updatable indirection RHS")
+ $$
+ (text "RHS:" <+> pprStgRhs opts rhs)
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -416,7 +416,6 @@ import GHC.Builtin.PrimOps.Casts
import GHC.Platform
import Data.List (mapAccumL)
--- import GHC.Utils.Trace
--------------------------------------------------------------------------------
-- | A mapping from binders to the Ids they were expanded/renamed to.
@@ -843,7 +842,7 @@ mapSumIdBinders alt_bndr args rhs rho0
arg_slots = map primRepSlot $ concatMap stgArgRep args
-- The slots representing the field of the sum we bind.
id_slots = map primRepSlot $ fld_reps
- layout1 = layoutUbxSum arg_slots id_slots
+ layout1 = layoutUbxSum arg_slots (map (\s -> (s, True)) id_slots)
-- See Note [Casting slot arguments]
-- Most of the code here is just to make sure our binders are of the
@@ -927,7 +926,7 @@ mkUbxSum platform dc ty_args args0 us
= let
tag_slot :| sum_slots = ubxSumRepType ty_args
-- drop tag slot
- field_slots = (mapMaybe (repSlotTy . stgArgRep) args0)
+ field_slots = mapMaybe argToSlotTy args0
tag = dataConTag dc
layout' = layoutUbxSum sum_slots field_slots
@@ -970,6 +969,10 @@ mkUbxSum platform dc ty_args args0 us
, Just lit' <- castLiteralArg platform (slotPrimRep slot_ty) lit
= Just (StgLitArg lit', us, id)
castArg us slot_ty arg
+ -- A lifted pointer stored in an unlifted slot needs no conversion; both
+ -- are heap pointers.
+ | slot_ty == PtrUnliftedSlot && stgArgRepU arg == BoxedRep (Just Lifted)
+ = Nothing
-- Cast the argument to the type of the slot if required
| slotPrimRep slot_ty /= stgArgRepU arg
, (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty
@@ -985,12 +988,17 @@ mkUbxSum platform dc ty_args args0 us
tup_args = tag_arg : slot_args
in
- -- pprTrace "mkUbxSum" (
- -- text "ty_args (slots)" <+> ppr ty_args $$
- -- text "args0" <+> ppr args0 $$
- -- text "wrapper" <+>
- -- (ppr $ wrapper $ StgLit $ LitChar '_'))
(tup_args, wrapper)
+ where
+ -- The Bool says whether a lifted pointer may occupy an unlifted slot; we
+ -- conservatively allow it for any pointer. Pointer slots are handled
+ -- loosely: this is sound only because 'fitsIn' keeps the lifted and unlifted
+ -- pointer slots separate, so an unlifted argument falls back to a lifted slot
+ -- (see 'layoutUbxSum') rather than the two being merged.
+ argToSlotTy :: StgArg -> Maybe (SlotTy, Bool)
+ argToSlotTy arg = do
+ ty <- repSlotTy (stgArgRep arg)
+ return (ty, True)
-- | Return a rubbish value for the given slot type.
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -95,6 +95,7 @@ import Data.Coerce (coerce)
import qualified Data.ByteString.Char8 as BS8
import GHC.StgToCmm.Config
import GHC.Stg.EnforceEpt.TagSig (isTaggedSig)
+import GHC.Builtin.Types (isStrictTy)
-----------------------------------------------------------------------------
-- Data types and synonyms
@@ -199,9 +200,9 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg
mkLFArgument :: Id -> LambdaFormInfo
mkLFArgument id
- | isUnliftedType ty = LFUnlifted
- | mightBeFunTy ty = LFUnknown True
- | otherwise = LFUnknown False
+ | isUnliftedType ty = LFUnlifted
+ | mightBeFunTy ty = LFUnknown True
+ | otherwise = LFUnknown False
where
ty = idType id
@@ -224,7 +225,10 @@ mkLFReEntrant top fvs args arg_descr
-------------
mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
mkLFThunk thunk_ty top fvs upd_flag
- = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $
+ | isUpdatable upd_flag && isUnliftedType thunk_ty && not (isStrictTy thunk_ty)
+ = pprPanic "mkLFThunk" (ppr thunk_ty <+> ppr top <+> ppr fvs <+> ppr upd_flag)
+mkLFThunk thunk_ty top fvs upd_flag
+ = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) || (isStrictTy thunk_ty)) $
LFThunk top (null fvs)
(isUpdatable upd_flag)
NonStandardThunk
@@ -542,8 +546,12 @@ getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_in
| n_args < arity = SlowCall -- Not enough args
| otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity
-getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info
- = assert (n_args == 0) ReturnIt
+getCallMethod cfg name id LFUnlifted n_args cg_loc self_loop_info
+ -- A value of unlifted type is already evaluated, so we can just return it,
+ -- unless it is also a function (e.g. @Strict (a -> b)@) that is being
+ -- applied, in which case we must call it.
+ | n_args > 0 = getCallMethod cfg name id (LFUnknown True) n_args cg_loc self_loop_info
+ | otherwise = ReturnIt
getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info
= assert (n_args == 0) ReturnIt
@@ -552,7 +560,6 @@ getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info
getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun)
n_args _cg_loc _self_loop_info
-
| Just sig <- idTagSig_maybe id
, isTaggedSig sig -- Infered to be already evaluated by EPT analysis
, n_args == 0 -- See Note [EPT enforcement]
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -41,9 +41,10 @@ import GHC.Core
import GHC.Core.DataCon
import GHC.Types.ForeignCall
import GHC.Types.Id
+import GHC.Types.Unique ( hasKey )
import GHC.Builtin.PrimOps
import GHC.Core.TyCon
-import GHC.Core.Type ( isUnliftedType )
+import GHC.Core.Type ( isUnliftedType, splitTyConApp_maybe )
import GHC.Types.RepType ( isZeroBitTy, countConRepArgs, mightBeFunTy )
import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
import GHC.Types.Tickish
@@ -58,6 +59,8 @@ import Control.Arrow ( first )
import Data.List ( partition )
import GHC.Stg.EnforceEpt.TagSig (isTaggedSig)
import GHC.Platform.Profile (profileIsProfiling)
+import GHC.Builtin.Names (strictTyConKey, strictDataConKey)
+import GHC.Plugins (varUnique)
------------------------------------------------------------------------
-- cgExpr: the main function
@@ -1037,6 +1040,10 @@ cgConApp con mn stg_args
; emitReturn [idInfoToAmode idinfo] }
cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
+cgIdApp fun_id _
+ -- MkStrict is erased in CorePrep, so it must never reach the code generator.
+ | varUnique fun_id == strictDataConKey
+ = pprPanic "cgIdApp: MkStrict survived to StgToCmm" (ppr fun_id)
cgIdApp fun_id args = do
platform <- getPlatform
fun_info <- getCgIdInfo fun_id
@@ -1051,15 +1058,32 @@ cgIdApp fun_id args = do
case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of
-- A value in WHNF, so we can just return it.
ReturnIt
- | isZeroBitTy (idType fun_id) -> emitReturn []
- | otherwise -> emitReturn [fun]
+ | isZeroBitTy (idType fun_id) -> do
+ emitReturn []
+ | otherwise -> do
+ if strict then
+ assertTag >> emitReturn [fun]
+ else
+ emitReturn [fun]
+ where
+ tcSplitMaybe = splitTyConApp_maybe (idType fun_id)
+ strict = case tcSplitMaybe of
+ Nothing -> False
+ Just (tc, _) -> tc `hasKey` strictTyConKey
+ assertTag = whenCheckTags $ do
+ mod <- getModuleName
+ emitTagAssertionStrict (showPprUnsafe
+ (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun))
+ fun
-- A value infered to be in WHNF, so we can just return it.
-- See (EPT-codegen) in Note [EPT enforcement] in GHC.Stg.EnforceEpt
InferedReturnIt
- | isZeroBitTy (idType fun_id) -> trace >> emitReturn []
- | otherwise -> trace >> assertTag >>
- emitReturn [fun]
+ | isZeroBitTy (idType fun_id) -> do
+ trace >> emitReturn []
+ | otherwise -> do
+ trace >> assertTag >>
+ emitReturn [fun]
where
trace = do
tickyTagged
@@ -1074,12 +1098,11 @@ cgIdApp fun_id args = do
(text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun))
fun
- EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ -- Discarding arguments
+ EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ do -- Discarding arguments
emitEnter fun
SlowCall -> do -- A slow function call via the RTS apply routines
{ tickySlowCall lf_info args
- ; emitComment $ mkFastString "slowCall"
; slowCall fun args }
-- A direct function call (possibly with some left-over arguments)
=====================================
compiler/GHC/StgToCmm/TagCheck.hs
=====================================
@@ -10,7 +10,8 @@
module GHC.StgToCmm.TagCheck
( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,
- checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where
+ checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn
+ , emitTagAssertionStrict) where
#include "ClosureTypes.h"
@@ -71,6 +72,51 @@ whenCheckTags act = do
check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
when check_tags act
+emitTagAssertionStrict :: String -> CmmExpr -> FCode ()
+emitTagAssertionStrict onWhat fun = do
+ { platform <- getPlatform
+ ; lret <- newBlockId
+ ; lno_tag <- newBlockId
+ ; lbarf <- newBlockId
+ -- Check for presence of any tag.
+ ; emit $ mkCbranch (cmmIsTagged platform fun)
+ lret lno_tag (Just True)
+ -- If there is no tag check if we are dealing with an untagged object
+ ; emitLabel lno_tag
+ ; needsTaggedPointer fun lbarf lret
+
+ ; emitLabel lbarf
+ ; emitBarf ("Tag eval failed on:" ++ onWhat)
+ ; emitLabel lret
+ }
+
+-- | Jump to the first block if the argument is subject
+-- to tagging requirements. Otherwise jump to the 2nd one.
+needsTaggedPointer :: CmmExpr -> BlockId -> BlockId -> FCode ()
+needsTaggedPointer val fail lpass = do
+ profile <- getProfile
+ align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
+ let clo_ty_e = cmmGetClosureType profile align_check val
+ -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we
+ -- have to accept them not being tagged. See #21193
+ -- See Note [TagInfo of functions]
+ let targets = mkSwitchTargets
+ False
+ (INVALID_OBJECT, N_CLOSURE_TYPES)
+ (Just lpass)
+ (M.fromList [(THUNK, fail),
+ (THUNK_1_0, fail),
+ (THUNK_0_1, fail),
+ (THUNK_2_0, fail),
+ (THUNK_1_1, fail),
+ (THUNK_0_2, fail),
+ (THUNK_STATIC, fail),
+ (THUNK_SELECTOR, fail)])
+
+ emit $ mkSwitch clo_ty_e targets
+
+ emit $ mkBranch lpass
+
-- | Call barf if we failed to predict a tag correctly.
-- This is immensely useful when debugging issues in tag inference
-- as it will result in a program abort when we encounter an invalid
@@ -112,15 +158,15 @@ needsArgTag closure fail lpass = do
False
(INVALID_OBJECT, N_CLOSURE_TYPES)
(Just fail)
- (M.fromList [(PAP,lpass)
- ,(BCO,lpass)
- ,(FUN,lpass)
- ,(FUN_1_0,lpass)
- ,(FUN_0_1,lpass)
- ,(FUN_2_0,lpass)
- ,(FUN_1_1,lpass)
- ,(FUN_0_2,lpass)
- ,(FUN_STATIC,lpass)
+ (M.fromList [(PAP,lpass) -- 25
+ ,(BCO,lpass) -- 23
+ ,(FUN,lpass) -- 8
+ ,(FUN_1_0,lpass) -- 9
+ ,(FUN_0_1,lpass) -- 10
+ ,(FUN_2_0,lpass) -- 11
+ ,(FUN_1_1,lpass) -- 12
+ ,(FUN_0_2,lpass) -- 13
+ ,(FUN_STATIC,lpass) -- 14
])
emit $ mkSwitch clo_ty_e targets
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Types.RepType
import GHC.Prelude
import GHC.Types.Basic (Arity, RepArity)
+import GHC.Builtin.Names (strictTyConKey)
import GHC.Core.DataCon
import GHC.Core.Coercion
import GHC.Core.TyCon
@@ -100,6 +101,10 @@ unwrapType ty
go t | Just t' <- coreView t = go t'
go (ForAllTy _ t) = go t
go (CastTy t _) = go t
+ -- Look through Strict types
+ go (TyConApp tc [t])
+ | tyConUnique tc == strictTyConKey
+ = go t
go t = t
-- cf. GHC.Core.Coercion.unwrapNewTypeStepper
@@ -248,29 +253,46 @@ ubxSumRepType constrs0
layoutUbxSum :: HasDebugCallStack
=> SortedSlotTys -- Layout of sum. Does not include tag.
-- We assume that they are in increasing order
- -> [SlotTy] -- Slot types of things we want to map to locations in the
- -- sum layout
+ -> [(SlotTy, Bool)] -- Slot types of things we want to map to locations in
+ -- the sum layout. The Bool says whether a lifted
+ -- pointer may occupy an unlifted slot, i.e. it is
+ -- already evaluated.
-> [Int] -- Where to map 'things' in the sum layout
layoutUbxSum sum_slots0 arg_slots0 =
go arg_slots0 IS.empty
where
- go :: [SlotTy] -> IS.IntSet -> [Int]
+ go :: [(SlotTy, Bool)] -> IS.IntSet -> [Int]
go [] _
= []
go (arg : args) used
- = let slot_idx = findSlot arg 0 sum_slots0 used
- in slot_idx : go args (IS.insert slot_idx used)
-
- findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int
+ = let slot_idx
+ | Just slot_idx <- findSlot (fst arg) 0 sum_slots0 used
+ = Just slot_idx
+ -- All pointer slots hold a heap pointer, so an unlifted pointer can
+ -- occupy a lifted slot. This bridges the gap left by 'unwrapType'
+ -- looking through Strict: the sum layout may have a lifted slot
+ -- where the argument is an (unlifted) Strict box.
+ | PtrUnliftedSlot <- fst arg
+ = findSlot PtrLiftedSlot 0 sum_slots0 used
+ -- An already-evaluated lifted pointer can occupy an unlifted slot.
+ | PtrLiftedSlot <- fst arg, snd arg
+ = findSlot PtrUnliftedSlot 0 sum_slots0 used
+ | otherwise
+ = Nothing
+ in case slot_idx of
+ Just slot_idx -> slot_idx : go args (IS.insert slot_idx used)
+ Nothing -> pprPanic "layoutUbxSum" ( text "Can't find slot for arg" <+> ppr arg
+ $$ text "sum_slots:" <> ppr sum_slots0
+ $$ text "arg_slots:" <> ppr arg_slots0)
+
+ findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Maybe Int
findSlot arg slot_idx (slot : slots) useds
| not (IS.member slot_idx useds)
, Just slot == arg `fitsIn` slot
- = slot_idx
+ = Just slot_idx
| otherwise
= findSlot arg (slot_idx + 1) slots useds
- findSlot _ _ [] _
- = pprPanic "findSlot" (text "Can't find slot" $$ text "sum_slots:" <> ppr sum_slots0
- $$ text "arg_slots:" <> ppr arg_slots0 )
+ findSlot _ _ [] _ = Nothing
--------------------------------------------------------------------------------
@@ -730,10 +752,6 @@ mightBeFunTy :: Type -> Bool
-- In particular, 'isFunTy' returns @False@ for @IO ()@ as well as for all
-- type family applications.
mightBeFunTy ty
- -- GHC (currently) has no unlifted functions, so an unlifted type is
- -- definitely not a function type.
- | definitelyUnliftedType ty
- = False
| Just tc <- tyConAppTyCon_maybe (unwrap_type ty)
-- A proper datatype (such as 'Int' or 'Maybe Bool') is definitely not
-- a function type. (This does not include newtypes nor type families.)
=====================================
testsuite/tests/codeGen/should_run/StrictBox.hs
=====================================
@@ -0,0 +1,44 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | Exercises the strict-field/Strict# machinery end to end:
+--
+-- * a strict value field built from a thunk, which must be forced to a
+-- properly-tagged value (EPT) when the constructor is built;
+-- * a strict field of /function/ type, whose box is unlifted but is applied
+-- as a function (the "might be a function" call path);
+-- * worker/wrapper unboxing a strict argument through Strict#;
+-- * a strict field holding another boxed value, passed around by value.
+--
+-- Run with -dtag-inference-checks so that any strict field that is not
+-- evaluated-and-properly-tagged aborts at runtime.
+module Main (main) where
+
+-- Strict value field + strict function field
+data Box a = Box !a !(Int -> Int)
+
+{-# NOINLINE mkBox #-}
+mkBox :: Int -> Box Int
+mkBox n = Box (sum [1..n]) (\x -> x + n) -- field 1 from a thunk; field 2 a closure
+
+{-# NOINLINE useBox #-}
+useBox :: Box Int -> Int
+useBox (Box a f) = a + f 100 -- applies the strict function field
+
+-- A strict field holding another boxed value
+data Wrap = Wrap !(Box Int)
+
+{-# NOINLINE useWrap #-}
+useWrap :: Wrap -> Int
+useWrap (Wrap b) = useBox b
+
+-- Worker/wrapper unboxes the strict argument through Strict#
+{-# NOINLINE strictArg #-}
+strictArg :: Int -> Int -> Int
+strictArg !x y = x * 1000 + y
+
+main :: IO ()
+main = do
+ print (useBox (mkBox 5)) -- 15 + (100+5) = 120
+ print (strictArg (3 + 4) 9) -- 7*1000 + 9 = 7009
+ print (useWrap (Wrap (mkBox 3))) -- 6 + (100+3) = 109
+ print (map (useBox . mkBox) [1, 2, 3]) -- [102, 105, 109]
=====================================
testsuite/tests/codeGen/should_run/StrictBox.stdout
=====================================
@@ -0,0 +1,4 @@
+120
+7009
+109
+[102,105,109]
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -289,3 +289,7 @@ test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)],
# AArch64-specific runtime tests
test('aarch64-ushr-subword-run', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
test('aarch64-subword-ops', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
+
+# Strict# / strict-field machinery, with runtime tag-inference checks
+test('StrictBox', normal, compile_and_run,
+ ['-O -dtag-inference-checks -fmax-simplifier-iterations=20'])
=====================================
testsuite/tests/core-to-stg/T24124.stderr
=====================================
@@ -1,17 +1,36 @@
==================== Final STG: ====================
-T24124.MkStrictPair [InlPrag=CONLIKE]
+T24124.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE]
:: forall a b. a %1 -> b %1 -> T24124.StrictPair a b
-[GblId[DataCon],
+[GblId[DataConWrapper],
Arity=2,
Caf=NoCafRefs,
Str=<SL><SL>,
Unf=OtherCon []] =
- {} \r [eta eta]
- case eta of eta {
+ {} \r [conrep conrep]
+ case conrep of $WMkStrictPair_sat {
+ __DEFAULT ->
+ case $WMkStrictPair_sat<TagProper> of conrep_ubx {
+ __DEFAULT ->
+ case conrep of $WMkStrictPair_sat {
__DEFAULT ->
- case eta of eta { __DEFAULT -> T24124.MkStrictPair [eta eta]; };
+ case $WMkStrictPair_sat<TagProper> of conrep_ubx {
+ __DEFAULT -> T24124.MkStrictPair [conrep_ubx conrep_ubx];
};
+ };
+ };
+ };
+
+T24124.MkStrictPair [InlPrag=CONLIKE]
+ :: forall {a} {b}.
+ GHC.Internal.Types.Strict# a
+ %1 -> GHC.Internal.Types.Strict# b %1 -> T24124.StrictPair a b
+[GblId[DataCon],
+ Arity=2,
+ Caf=NoCafRefs,
+ Str=<SL><SL>,
+ Unf=OtherCon []] =
+ {} \r [eta eta] T24124.MkStrictPair [eta eta];
T24124.testFun1
:: forall a b.
@@ -20,13 +39,18 @@ T24124.testFun1
-> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
-> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld,
T24124.StrictPair a b #)
-[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] =
+[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] =
{} \r [x y void]
case x of testFun1_sat {
__DEFAULT ->
+ case y of wild {
+ __DEFAULT ->
case
- case y of y [OS=OneShot] {
- __DEFAULT -> T24124.MkStrictPair [testFun1_sat y];
+ case wild<TagProper> of testFun1_sat {
+ __DEFAULT ->
+ case testFun1_sat<TagProper> of testFun1_sat {
+ __DEFAULT -> T24124.MkStrictPair [testFun1_sat testFun1_sat];
+ };
}
of
testFun1_sat
@@ -34,11 +58,12 @@ T24124.testFun1
__DEFAULT -> GHC.Internal.Types.MkSolo# [testFun1_sat];
};
};
+ };
T24124.testFun
:: forall a b.
a -> b -> GHC.Internal.Types.IO (T24124.StrictPair a b)
-[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] =
+[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] =
{} \r [eta eta void]
T24124.testFun1 eta eta GHC.Internal.Prim.void#;
=====================================
testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout
=====================================
@@ -1,9 +1,10 @@
Packed1 12.34# 56.78# 42# 99.99#
packed1 = Packed1 12.34 56.78 42 99.99
Packed2 12.34 56.78 42 99.99
-packed2 = Packed2 12.34 56.78 42 99.99
+packed2 = Packed2 (F# 12.34) (F# 56.78) (I# 42) (F# 99.99)
Packed3 1 2 3 4 5 6 7.8 9.0
packed3 = Packed3
(GHC.Internal.Word.W8# 1) (GHC.Internal.Int.I8# 2)
(GHC.Internal.Int.I64# 3) (GHC.Internal.Word.W16# 4)
- (GHC.Internal.Word.W64# 5) (GHC.Internal.Word.W32# 6) 7.8 9.0
+ (GHC.Internal.Word.W64# 5) (GHC.Internal.Word.W32# 6) (F# 7.8)
+ (D# 9.0)
=====================================
testsuite/tests/ghci.debugger/scripts/print007.stdout
=====================================
@@ -1,6 +1,6 @@
()
-s = S2 'a' 'b'
+s = S2 'a' (GHC.Internal.Types.C# 'b')
()
-s = S2 'a' 'b'
+s = S2 'a' (GHC.Internal.Types.C# 'b')
()
s = S2 'a' 'b'
=====================================
testsuite/tests/ghci.debugger/scripts/print022.stdout
=====================================
@@ -4,5 +4,5 @@ Breakpoint 0 activated at print022.hs:11:7
Stopped in Main.f, print022.hs:11:7
_result :: p = _
x :: p = _
-x = C2 1 (W# 32) (TwoFields 'a' 3)
+x = C2 (I# 1) (W# 32) (TwoFields 'a' 3)
x :: T2
=====================================
testsuite/tests/simplStg/should_compile/T15226b.stderr
=====================================
@@ -1,12 +1,28 @@
==================== Final STG: ====================
-T15226b.Str [InlPrag=CONLIKE] :: forall a. a %1 -> T15226b.Str a
+T15226b.$WStr [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. a %1 -> T15226b.Str a
+[GblId[DataConWrapper],
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=<SL>,
+ Unf=OtherCon []] =
+ {} \r [conrep]
+ case conrep of $WStr_sat {
+ __DEFAULT ->
+ case $WStr_sat<TagProper> of conrep_ubx {
+ __DEFAULT -> T15226b.Str [conrep_ubx];
+ };
+ };
+
+T15226b.Str [InlPrag=CONLIKE]
+ :: forall {a}. GHC.Internal.Types.Strict# a %1 -> T15226b.Str a
[GblId[DataCon],
Arity=1,
Caf=NoCafRefs,
Str=<SL>,
Unf=OtherCon []] =
- {} \r [eta] case eta of eta { __DEFAULT -> T15226b.Str [eta]; };
+ {} \r [eta] T15226b.Str [eta];
T15226b.bar1
:: forall a.
@@ -20,8 +36,11 @@ T15226b.bar1
__DEFAULT ->
let {
bar1_sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a)
- [LclId, Unf=OtherCon []] =
- T15226b.Str! [bar1_sat];
+ [LclId] =
+ {bar1_sat} \u []
+ case bar1_sat<TagProper> of bar1_sat {
+ __DEFAULT -> T15226b.Str [bar1_sat];
+ };
} in GHC.Internal.Types.MkSolo# [bar1_sat];
};
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c40b14f19b8f02a50a1420a525b843…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c40b14f19b8f02a50a1420a525b843…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC
Commits:
d6f6f5c7 by Teo Camarasu at 2026-06-18T19:36:14+01:00
Make Q abstract
This patch aims to clearly demarcate the internal and external interfaces
of Q.
In the past the `Quasi` typeclass was both part of the external,
public-facing interface, and was used to give the implementation of `Q`.
Now we separate out these two distinct roles. `Quasi` continues to exist
in the public interface, but we introduce a new `MetaHandlers` type,
which is equivalent to `Dict Quasi`.
`Q a` is now defined to be `MetaHandlers -> IO a`, and, crucially,
the constructor and the new `MetaHandlers` type are not exposed from the
public interface.
This gives us the ability to vary the interface on the GHC side without
forcing a breaking change on the `template-haskell` side.
Similarly `template-haskell` has more freedom to change the `Quasi`
typeclass without needing any changes in `lib:ghc`.
Implements https://github.com/ghc-proposals/ghc-proposals/pull/70
Resolves #27341
- - - - -
9 changed files:
- + changelog.d/AbstractQ
- compiler/GHC/Data/IOEnv.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
changelog.d/AbstractQ
=====================================
@@ -0,0 +1,9 @@
+section: template-haskell
+synopsis: Hide the implementation of Q
+description: The constructor of Q is now hidden.
+ This is done to improve the stability of ``template-haskell``.
+ To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``.
+ The ``Quasi TcM`` instance is no longer exposed from the ``ghc`` API.
+ See the `GHC proposal <https://github.com/ghc-proposals/ghc-proposals/pull/700>`_ for more details.
+mrs: !15696
+issues: #27341
=====================================
compiler/GHC/Data/IOEnv.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Data.IOEnv (
IOEnvFailure(..),
-- Getting at the environment
- getEnv, setEnv, updEnv, updEnvIO,
+ getEnv, setEnv, updEnv, updEnvIO, withRunInIO,
runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,
tryM, tryAllM, tryMostM, fixM,
@@ -258,3 +258,12 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a
{-# INLINE updEnvIO #-}
updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
+
+-- | 'withRunInIO' specialised to `IOEnv`.
+-- See https://hackage.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unl… for an explanation.
+withRunInIO:: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b
+withRunInIO k = IOEnv $ \env ->
+ let
+ unlift :: forall a. IOEnv env a -> IO a
+ unlift (IOEnv m) = m env
+ in k unlift
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice(
tcTypedSplice, tcTypedBracket, tcUntypedBracket,
runAnnotation, getUntypedSpliceBody,
- runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
+ runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM,
tcTopSpliceExpr, lookupThName_maybe,
defaultRunMeta, runMeta', runRemoteModFinalizers,
finishTH, runTopSplice
@@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt
-- THSyntax gives access to internal functions and data types
import qualified GHC.Boot.TH.Syntax as TH
import qualified GHC.Boot.TH.Monad as TH
+import GHC.Boot.TH.Monad (MetaHandlers(..))
import qualified GHC.Boot.TH.Ppr as TH
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do
************************************************************************
-}
-runQuasi :: TH.Q a -> TcM a
-runQuasi act = TH.runQ act
+runQinTcM :: TH.Q a -> TcM a
+runQinTcM (TH.Q act) = withRunInIO $ \runInIO -> act (metaHandlersTcM runInIO)
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
runRemoteModFinalizers (ThModFinalizers finRefs) = do
@@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> do
qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
- runQuasi $ sequence_ qs
+ runQinTcM $ sequence_ qs
#endif
ExternalInterp ext -> withExtInterp ext $ \inst -> do
@@ -1466,70 +1467,14 @@ when showing an error message.
To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
-}
-instance TH.Quasi TcM where
- qNewName s = do { u <- newUnique
- ; let i = toInteger (getKey u)
- ; return (TH.mkNameU s i) }
+-- 'msg' is forced to ensure exceptions don't escape,
+-- see Note [Exceptions in TH]
+report :: Bool -> [Char] -> TcM ()
+report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
+report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
- -- 'msg' is forced to ensure exceptions don't escape,
- -- see Note [Exceptions in TH]
- qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg
- qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
-
- qLocation :: TcM TH.Loc
- qLocation = do { m <- getModule
- ; l <- getSrcSpanM
- ; r <- case l of
- RealSrcSpan s _ -> return s
- GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
- (pprGeneratedSrcSpanDetails)
- UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
- (ppr l)
- ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
- , TH.loc_module = moduleNameString (moduleName m)
- , TH.loc_package = unitString (moduleUnit m)
- , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
- , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
-
- qLookupName = lookupName
- qReify = reify
- qReifyFixity nm = lookupThName nm >>= reifyFixity
- qReifyType = reifyTypeOfThing
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness nm = do { nm' <- lookupThName nm
- ; dc <- tcLookupDataCon nm'
- ; let bangs = dataConImplBangs dc
- ; return (map reifyDecidedStrictness bangs) }
-
- -- For qRecover, discard error messages if
- -- the recovery action is chosen. Otherwise
- -- we'll only fail higher up.
- qRecover recover main = tryTcDiscardingErrs recover main
-
- qGetPackageRoot = do
- dflags <- getDynFlags
- return $ fromMaybe "." (workingDirectory dflags)
-
- qAddDependentFile fp = do
- ref <- fmap tcg_dependent_files getGblEnv
- dep_files <- readTcRef ref
- writeTcRef ref (fp:dep_files)
-
- qAddDependentDirectory dp = do
- ref <- fmap tcg_dependent_dirs getGblEnv
- dep_dirs <- readTcRef ref
- writeTcRef ref (dp:dep_dirs)
-
- qAddTempFile suffix = do
- dflags <- getDynFlags
- logger <- getLogger
- tmpfs <- hsc_tmpfs <$> getTopEnv
- liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
-
- qAddTopDecls thds = do
+addTopDecls :: [TH.Dec] -> TcM ()
+addTopDecls thds = do
exts <- fmap extensionFlags getDynFlags
l <- getSrcSpanM
th_origin <- getThSpliceOrigin
@@ -1557,52 +1502,13 @@ instance TH.Quasi TcM where
bindName :: RdrName -> TcM ()
bindName (Exact n)
= do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
- ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
- }
+ ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
+ }
bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name
- qAddForeignFilePath lang fp = do
- var <- fmap tcg_th_foreign_files getGblEnv
- updTcRef var ((lang, fp) :)
-
- qAddModFinalizer fin = do
- r <- liftIO $ mkRemoteRef fin
- fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
- addModFinalizerRef fref
-
- qAddCorePlugin plugin = do
- hsc_env <- getTopEnv
- let fc = hsc_FC hsc_env
- let home_unit = hsc_home_unit hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
- r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
- let err = TcRnTHError $ AddInvalidCorePlugin plugin
- case r of
- Found {} -> addErr err
- FoundMultiple {} -> addErr err
- _ -> return ()
- th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
- updTcRef th_coreplugins_var (plugin:)
-
- qGetQ :: forall a. Typeable a => TcM (Maybe a)
- qGetQ = do
- th_state_var <- fmap tcg_th_state getGblEnv
- th_state <- readTcRef th_state_var
- -- See #10596 for why we use a scoped type variable here.
- return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
-
- qPutQ x = do
- th_state_var <- fmap tcg_th_state getGblEnv
- updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
-
- qIsExtEnabled = xoptM
-
- qExtsEnabled =
- EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
-
- qPutDoc doc_loc s = do
+putDoc :: TH.DocLoc -> String -> TcM ()
+putDoc doc_loc s = do
th_doc_var <- tcg_th_docs <$> getGblEnv
resolved_doc_loc <- resolve_loc doc_loc
is_local <- checkLocalName resolved_doc_loc
@@ -1624,15 +1530,131 @@ instance TH.Quasi TcM where
checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
checkLocalName ModuleDoc = pure True
-
- qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
- qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
- qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
- qGetDoc TH.ModuleDoc = do
+getDoc :: TH.DocLoc -> TcM (Maybe String)
+getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
+getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
+getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
+getDoc TH.ModuleDoc = do
df <- getDynFlags
docs <- getGblEnv >>= extractDocs df
return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))
+getQ :: forall a. Typeable a => TcM (Maybe a)
+getQ = do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ th_state <- readTcRef th_state_var
+ -- See #10596 for why we use a scoped type variable here.
+ return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
+
+location :: TcM TH.Loc
+location = do { m <- getModule
+ ; l <- getSrcSpanM
+ ; r <- case l of
+ RealSrcSpan s _ -> return s
+ GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
+ (pprGeneratedSrcSpanDetails)
+ UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+ (ppr l)
+ ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+ , TH.loc_module = moduleNameString (moduleName m)
+ , TH.loc_package = unitString (moduleUnit m)
+ , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+ , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
+
+metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers
+metaHandlersTcM runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error.
+ , mFail = \s -> runInIO $ fail @TcM s
+ , mNewName = \s -> runInIO $ do { u <- newUnique
+ ; let i = toInteger (getKey u)
+ ; return (TH.mkNameU s i) }
+
+ , mReport = fmap runInIO . report
+
+ , mLocation = runInIO location
+
+ , mLookupName = fmap runInIO . lookupName
+ , mReify = runInIO . reify
+ , mReifyFixity = \nm -> runInIO $ lookupThName nm >>= reifyFixity
+ , mReifyType = runInIO . reifyTypeOfThing
+ , mReifyInstances = fmap runInIO . reifyInstances
+ , mReifyRoles = runInIO . reifyRoles
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = runInIO . reifyModule
+ , mReifyConStrictness = \nm -> runInIO $ do
+ { nm' <- lookupThName nm
+ ; dc <- tcLookupDataCon nm'
+ ; let bangs = dataConImplBangs dc
+ ; return (map reifyDecidedStrictness bangs) }
+
+ -- For qRecover, discard error messages if
+ -- the recovery action is chosen. Otherwise
+ -- we'll only fail higher up.
+ , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main)
+
+ , mGetPackageRoot = runInIO $ do
+ dflags <- getDynFlags
+ return $ fromMaybe "." (workingDirectory dflags)
+
+ , mAddDependentFile = \fp -> runInIO $ do
+ ref <- fmap tcg_dependent_files getGblEnv
+ dep_files <- readTcRef ref
+ writeTcRef ref (fp:dep_files)
+
+ , mAddDependentDirectory = \dp -> runInIO $ do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (dp:dep_dirs)
+
+ , mAddTempFile = \suffix -> runInIO $ do
+ dflags <- getDynFlags
+ logger <- getLogger
+ tmpfs <- hsc_tmpfs <$> getTopEnv
+ liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
+
+ , mAddTopDecls = runInIO . addTopDecls
+
+ , mAddForeignFilePath = \lang fp -> runInIO $ do
+ var <- fmap tcg_th_foreign_files getGblEnv
+ updTcRef var ((lang, fp) :)
+
+ , mAddModFinalizer = \fin -> runInIO $ do
+ r <- liftIO $ mkRemoteRef fin
+ fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
+ addModFinalizerRef fref
+
+ , mAddCorePlugin = \plugin -> runInIO $ do
+ hsc_env <- getTopEnv
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ let fopts = initFinderOpts dflags
+ r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
+ let err = TcRnTHError $ AddInvalidCorePlugin plugin
+ case r of
+ Found {} -> addErr err
+ FoundMultiple {} -> addErr err
+ _ -> return ()
+ th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+ updTcRef th_coreplugins_var (plugin:)
+
+ , mGetQ = runInIO getQ
+
+ , mPutQ = \x -> runInIO $ do
+ th_state_var <- fmap tcg_th_state getGblEnv
+ updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
+
+ , mIsExtEnabled = runInIO . xoptM
+
+ , mExtsEnabled = runInIO $
+ EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+
+ , mPutDoc = fmap runInIO . putDoc
+
+ , mGetDoc = runInIO . getDoc
+ }
+
-- | Looks up documentation for a declaration in first the current module,
-- otherwise tries to find it in another module via 'hscGetModuleInterface'.
lookupDeclDoc :: Name -> TcM (Maybe String)
@@ -1788,7 +1810,7 @@ runTH ty fhv = do
InternalInterp -> do
-- Run it in the local TcM
hv <- liftIO $ wormhole interp fhv
- r <- runQuasi (unsafeCoerce hv :: TH.Q a)
+ r <- runQinTcM (unsafeCoerce hv :: TH.Q a)
return r
#endif
@@ -1797,7 +1819,7 @@ runTH ty fhv = do
-- Remote GHCi, see Note [Remote Template Haskell] in
-- libraries/ghci/GHCi/TH.hs.
rstate <- getTHState inst
- loc <- TH.qLocation
+ loc <- location
-- run a remote TH request
r <- liftIO $
withForeignRef rstate $ \state_hv ->
@@ -1913,32 +1935,32 @@ wrapTHResult tcm = do
handleTHMessage :: THMessage a -> TcM a
handleTHMessage msg = case msg of
- NewName a -> wrapTHResult $ TH.qNewName a
- Report b str -> wrapTHResult $ TH.qReport b str
- LookupName b str -> wrapTHResult $ TH.qLookupName b str
- Reify n -> wrapTHResult $ TH.qReify n
- ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
- ReifyType n -> wrapTHResult $ TH.qReifyType n
- ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
- ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
+ NewName a -> wrapTHResult $ runQinTcM $ TH.newName a
+ Report b str -> wrapTHResult $ runQinTcM $ TH.report b str
+ LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str
+ Reify n -> wrapTHResult $ runQinTcM $ TH.reify n
+ ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n
+ ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n
+ ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts
+ ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n
ReifyAnnotations lookup tyrep ->
wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
- ReifyModule m -> wrapTHResult $ TH.qReifyModule m
- ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
- GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
- AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
- AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d
- AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
+ ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m
+ ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm
+ GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot
+ AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f
+ AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d
+ AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile s
AddModFinalizer r -> do
interp <- hscInterp <$> getTopEnv
wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
- AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
- AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
- AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
- IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
- ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
- PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
- GetDoc l -> wrapTHResult $ TH.qGetDoc l
+ AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str
+ AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs
+ AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str
+ IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext
+ ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled
+ PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s
+ GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l
FailIfErrs -> wrapTHResult failIfErrsM
_ -> panic ("handleTHMessage: unexpected message " ++ show msg)
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs)
runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
-runQuasi :: TH.Q a -> TcM a
+runQinTcM :: TH.Q a -> TcM a
runRemoteModFinalizers :: ThModFinalizers -> TcM ()
finishTH :: TcM ()
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec
withDecDoc doc dec = do
dec' <- dec
case doc_loc dec' of
- Just loc -> qAddModFinalizer $ qPutDoc loc doc
+ Just loc -> addModFinalizer $ putDoc loc doc
Nothing -> pure ()
pure dec'
where
@@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause]
-> [Maybe String] -- ^ Documentation to attach to arguments
-> Q Dec
funD_doc nm cs mfun_doc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = funD nm cs
case mfun_doc of
@@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the newtype declaration
-> Q Dec
newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeD ctxt tc tvs ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
-- ^ Documentation to attach to the data declaration
-> Q Dec
typeDataD_doc tc tvs ksig cons_with_docs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)
maybe dec (flip withDecDoc dec) mdoc
@@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
-- ^ Documentation to attach to the instance declaration
-> Q Dec
dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do
- qAddModFinalizer $ mapM_ docCons cons_with_docs
+ addModFinalizer $ mapM_ docCons cons_with_docs
let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)
derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type
-- ^ Documentation to attach to the instance declaration
-> Q Dec
newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do
- qAddModFinalizer $ docCons con_with_docs
+ addModFinalizer $ docCons con_with_docs
let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs
maybe dec (flip withDecDoc dec) mdoc
@@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat
-> [Maybe String] -- ^ Documentation to attach to the pattern arguments
-> Q Dec
patSynD_doc name args dir pat mdoc arg_docs = do
- qAddModFinalizer $ sequence_
+ addModFinalizer $ sequence_
[putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]
let dec = patSynD name args dir pat
maybe dec (flip withDecDoc dec) mdoc
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -29,13 +29,13 @@ import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.IO.Class (MonadIO (..))
-import System.IO (FilePath, hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
import qualified Data.Kind as Kind (Type)
import GHC.Types (TYPE, RuntimeRep(..))
#else
import GHC.Internal.Base (
Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String,
- flip, id, (.), (++),
+ flip, id, (.), (++), ($),
)
import GHC.Internal.Classes (not)
import GHC.Internal.Data.Data hiding (Fixity(..))
@@ -59,145 +59,150 @@ import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
import GHC.Internal.TH.Syntax
------------------------------------------------------
---
--- The Quasi class
---
------------------------------------------------------
-
-class (MonadIO m, MonadFail m) => Quasi m where
- -- | Fresh names. See 'newName'.
- qNewName :: String -> m Name
-
- ------- Error reporting and recovery -------
- -- | Report an error (True) or warning (False)
- -- ...but carry on; use 'fail' to stop. See 'report'.
- qReport :: Bool -> String -> m ()
-
- -- | See 'recover'.
- qRecover :: m a -- ^ the error handler
- -> m a -- ^ action which may fail
- -> m a -- ^ Recover from the monadic 'fail'
-
- ------- Inspect the type-checker's environment -------
- -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
- qLookupName :: Bool -> String -> m (Maybe Name)
- -- | See 'reify'.
- qReify :: Name -> m Info
- -- | See 'reifyFixity'.
- qReifyFixity :: Name -> m (Maybe Fixity)
- -- | See 'reifyType'.
- qReifyType :: Name -> m Type
- -- | Is (n tys) an instance? Returns list of matching instance Decs (with
- -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
- qReifyInstances :: Name -> [Type] -> m [Dec]
- -- | See 'reifyRoles'.
- qReifyRoles :: Name -> m [Role]
- -- | See 'reifyAnnotations'.
- qReifyAnnotations :: Data a => AnnLookup -> m [a]
- -- | See 'reifyModule'.
- qReifyModule :: Module -> m ModuleInfo
- -- | See 'reifyConStrictness'.
- qReifyConStrictness :: Name -> m [DecidedStrictness]
-
- -- | See 'location'.
- qLocation :: m Loc
-
- -- | Input/output (dangerous). See 'runIO'.
- qRunIO :: IO a -> m a
- qRunIO = liftIO
- -- | See 'getPackageRoot'.
- qGetPackageRoot :: m FilePath
-
- -- | See 'addDependentFile'.
- qAddDependentFile :: FilePath -> m ()
-
- -- | See 'addDependentDirectory'.
- qAddDependentDirectory :: FilePath -> m ()
-
- -- | See 'addTempFile'.
- qAddTempFile :: String -> m FilePath
-
- -- | See 'addTopDecls'.
- qAddTopDecls :: [Dec] -> m ()
-
- -- | See 'addForeignFilePath'.
- qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
-
- -- | See 'addModFinalizer'.
- qAddModFinalizer :: Q () -> m ()
-
- -- | See 'addCorePlugin'.
- qAddCorePlugin :: String -> m ()
-
- -- | See 'getQ'.
- qGetQ :: Typeable a => m (Maybe a)
-
- -- | See 'putQ'.
- qPutQ :: Typeable a => a -> m ()
-
- -- | See 'isExtEnabled'.
- qIsExtEnabled :: Extension -> m Bool
- -- | See 'extsEnabled'.
- qExtsEnabled :: m [Extension]
-
- -- | See 'putDoc'.
- qPutDoc :: DocLoc -> String -> m ()
- -- | See 'getDoc'.
- qGetDoc :: DocLoc -> m (Maybe String)
+-- | 'MetaHandlers' defines the interface between GHC and TH splices.
+-- This is an internal interface between two parts of the compiler,
+-- and should never be directly exposed to users.
+--
+-- It mirrors the 'Quasi' typeclass, which is part of the public facing interface of TH.
+-- With time the two interfaces may drift apart.
+--
+-- This type is defined in `ghc-internal` rather than `lib:ghc` to avoid
+-- `template-haskell` having to depend on GHC, ie, it implements dependency inversion.
+--
+-- For more information about the historical design of this interface,
+-- see: https://github.com/ghc-proposals/ghc-proposals/pull/700
+data MetaHandlers = MetaHandlers {
+ -- | We have an explicit handler for liftIO to allow users to forbid lifting into 'IO'
+ mLiftIO :: forall a. IO a -> IO a
+ , mFail :: forall a. String -> IO a
+ -- | Fresh names. See 'newName'.
+ , mNewName :: String -> IO Name
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ , mReport :: Bool -> String -> IO ()
+
+ -- | See 'recover'.
+ , mRecover :: forall a. Q a -- ^ the error handler
+ -> Q a -- ^ action which may fail
+ -> IO a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ , mLookupName :: Bool -> String -> IO (Maybe Name)
+ -- | See 'reify'.
+ , mReify :: Name -> IO Info
+ -- | See 'reifyFixity'.
+ , mReifyFixity :: Name -> IO (Maybe Fixity)
+ -- | See 'reifyType'.
+ , mReifyType :: Name -> IO Type
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ , mReifyInstances :: Name -> [Type] -> IO [Dec]
+ -- | See 'reifyRoles'.
+ , mReifyRoles :: Name -> IO [Role]
+ -- | See 'reifyAnnotations'.
+ , mReifyAnnotations :: forall a. Data a => AnnLookup -> IO [a]
+ -- | See 'reifyModule'.
+ , mReifyModule :: Module -> IO ModuleInfo
+ -- | See 'reifyConStrictness'.
+ , mReifyConStrictness :: Name -> IO [DecidedStrictness]
+
+ -- | See 'location'.
+ , mLocation :: IO Loc
+
+ -- | See 'getPackageRoot'.
+ , mGetPackageRoot :: IO FilePath
+
+ -- | See 'addDependentFile'.
+ , mAddDependentFile :: FilePath -> IO ()
+
+ -- | See 'addDependentDirectory'.
+ , mAddDependentDirectory :: FilePath -> IO ()
+
+ -- | See 'addTempFile'.
+ , mAddTempFile :: String -> IO FilePath
+
+ -- | See 'addTopDecls'.
+ , mAddTopDecls :: [Dec] -> IO ()
+
+ -- | See 'addForeignFilePath'.
+ , mAddForeignFilePath :: ForeignSrcLang -> String -> IO ()
+
+ -- | See 'addModFinalizer'.
+ , mAddModFinalizer :: Q () -> IO ()
+
+ -- | See 'addCorePlugin'.
+ , mAddCorePlugin :: String -> IO ()
+
+ -- | See 'getQ'.
+ , mGetQ :: forall a. Typeable a => IO (Maybe a)
+
+ -- | See 'putQ'.
+ , mPutQ :: forall a. Typeable a => a -> IO ()
+
+ -- | See 'isExtEnabled'.
+ , mIsExtEnabled :: Extension -> IO Bool
+ -- | See 'extsEnabled'.
+ , mExtsEnabled :: IO [Extension]
+
+ -- | See 'putDoc'.
+ , mPutDoc :: DocLoc -> String -> IO ()
+ -- | See 'getDoc'.
+ , mGetDoc :: DocLoc -> IO (Maybe String)
+ }
------------------------------------------------------
--- The IO instance of Quasi
------------------------------------------------------
+badIO :: String -> IO a
+badIO op = do { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad")
+ ; fail "Template Haskell failure" }
--- | This instance is used only when running a Q
--- computation in the IO monad, usually just to
--- print the result. There is no interesting
--- type environment, so reification isn't going to
--- work.
-instance Quasi IO where
- qNewName = newNameIO
-
- qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
- qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
-
- qLookupName _ _ = badIO "lookupName"
- qReify _ = badIO "reify"
- qReifyFixity _ = badIO "reifyFixity"
- qReifyType _ = badIO "reifyFixity"
- qReifyInstances _ _ = badIO "reifyInstances"
- qReifyRoles _ = badIO "reifyRoles"
- qReifyAnnotations _ = badIO "reifyAnnotations"
- qReifyModule _ = badIO "reifyModule"
- qReifyConStrictness _ = badIO "reifyConStrictness"
- qLocation = badIO "currentLocation"
- qRecover _ _ = badIO "recover" -- Maybe we could fix this?
- qGetPackageRoot = badIO "getProjectRoot"
- qAddDependentFile _ = badIO "addDependentFile"
- qAddTempFile _ = badIO "addTempFile"
- qAddTopDecls _ = badIO "addTopDecls"
- qAddForeignFilePath _ _ = badIO "addForeignFilePath"
- qAddModFinalizer _ = badIO "addModFinalizer"
- qAddCorePlugin _ = badIO "addCorePlugin"
- qGetQ = badIO "getQ"
- qPutQ _ = badIO "putQ"
- qIsExtEnabled _ = badIO "isExtEnabled"
- qExtsEnabled = badIO "extsEnabled"
- qPutDoc _ _ = badIO "putDoc"
- qGetDoc _ = badIO "getDoc"
- qAddDependentDirectory _ = badIO "AddDependentDirectory"
+metaHandlersIO :: MetaHandlers
+metaHandlersIO = MetaHandlers {
+ mLiftIO = id
+ , mFail = fail
+ , mNewName = newNameIO
+ , mReport = \b msg ->
+ if b then
+ hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ else
+ hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above?
+ , mLookupName = \ _ _ -> badIO "lookupName"
+ , mReify = \_ -> badIO "reify"
+ , mReifyFixity = \_ -> badIO "reifyFixity"
+ , mReifyType = \_ -> badIO "reifyFixity"
+ , mReifyInstances = \_ _ -> badIO "reifyInstances"
+ , mReifyRoles = \_ -> badIO "reifyRoles"
+ , mReifyAnnotations = \_ -> badIO "reifyAnnotations"
+ , mReifyModule = \_ -> badIO "reifyModule"
+ , mReifyConStrictness = \_ -> badIO "reifyConStrictness"
+ , mLocation = badIO "currentLocation"
+ , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this?
+ , mGetPackageRoot = badIO "getProjectRoot"
+ , mAddDependentFile = \_ -> badIO "addDependentFile"
+ , mAddTempFile = \_ -> badIO "addTempFile"
+ , mAddTopDecls = \_ -> badIO "addTopDecls"
+ , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath"
+ , mAddModFinalizer = \_ -> badIO "addModFinalizer"
+ , mAddCorePlugin = \_ -> badIO "addCorePlugin"
+ , mGetQ = badIO "getQ"
+ , mPutQ = \_ -> badIO "putQ"
+ , mIsExtEnabled = \_ -> badIO "isExtEnabled"
+ , mExtsEnabled = badIO "extsEnabled"
+ , mPutDoc = \_ _ -> badIO "putDoc"
+ , mGetDoc = \_ -> badIO "getDoc"
+ , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory"
+ }
instance Quote IO where
newName = newNameIO
+
+
newNameIO :: String -> IO Name
newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
; pure (mkNameU s n) }
-badIO :: String -> IO a
-badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
- ; fail "Template Haskell failure" }
-
-- Global variable to generate unique symbols
counter :: IORef Uniq
{-# NOINLINE counter #-}
@@ -210,46 +215,24 @@ counter = unsafePerformIO (newIORef 0)
--
-----------------------------------------------------
--- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
--- user.
---
--- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
--- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
--- itself and 'IO', neither of which have concrete implementations.'Q' plays
--- the trick of [dependency
--- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
--- providing an abstract interface for the user which is later concretely
--- fufilled by an concrete 'Quasi' instance, internal to GHC.
-newtype Q a = Q { unQ :: forall m. Quasi m => m a }
-
--- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
--- should not need this function, as the splice brackets @$( ... )@
--- are the usual way of running a 'Q' computation.
---
--- This function is primarily used in GHC internals, and for debugging
--- splices by running them in 'IO'.
---
--- Note that many functions in 'Q', such as 'reify' and other compiler
--- queries, are not supported when running 'Q' in 'IO'; these operations
--- simply fail at runtime. Indeed, the only operations guaranteed to succeed
--- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
-runQ :: Quasi m => Q a -> m a
-runQ (Q m) = m
+-- | 'Q' is the base 'Monad' for TemplateHaskell splices,
+-- similar to how 'IO' is the base 'Monad' for normal Haskell programs.
+newtype Q a = Q { unQ :: MetaHandlers -> IO a }
instance Monad Q where
- Q m >>= k = Q (m >>= \x -> unQ (k x))
+ Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h)
(>>) = (*>)
instance MonadFail Q where
- fail s = report True s >> Q (fail "Q monad failure")
+ fail s = report True s >> Q (\h -> mFail h "Q monad failure")
instance Functor Q where
- fmap f (Q x) = Q (fmap f x)
+ fmap f (Q x) = Q $ \h -> fmap f (x h)
instance Applicative Q where
- pure x = Q (pure x)
- Q f <*> Q x = Q (f <*> x)
- Q m *> Q n = Q (m *> n)
+ pure x = Q $ \_ -> pure x
+ Q f <*> Q x = Q $ \h -> (f h <*> x h)
+ Q m *> Q n = Q $ \h -> (m h *> n h)
-- | @since 2.17.0.0
instance Semigroup a => Semigroup (Q a) where
@@ -319,7 +302,7 @@ class Monad m => Quote m where
newName :: String -> m Name
instance Quote Q where
- newName s = Q (qNewName s)
+ newName s = Q $ \h -> mNewName h s
-----------------------------------------------------
--
@@ -517,35 +500,26 @@ joinCode = flip bindCode id
-- | Report an error (True) or warning (False),
-- but carry on; use 'fail' to stop.
report :: Bool -> String -> Q ()
-report b s = Q (qReport b s)
-{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
-
--- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
-reportError :: String -> Q ()
-reportError = report True
-
--- | Report a warning to the user, and carry on.
-reportWarning :: String -> Q ()
-reportWarning = report False
+report b s = Q $ \h -> mReport h b s
-- | Recover from errors raised by 'reportError' or 'fail'.
recover :: Q a -- ^ handler to invoke on failure
-> Q a -- ^ computation to run
-> Q a
-recover (Q r) (Q m) = Q (qRecover r m)
+recover rec main = Q $ \h -> mRecover h rec main
-- We don't export lookupName; the Bool isn't a great API
-- Instead we export lookupTypeName, lookupValueName
lookupName :: Bool -> String -> Q (Maybe Name)
-lookupName ns s = Q (qLookupName ns s)
+lookupName ns s = Q $ \h -> mLookupName h ns s
-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupTypeName :: String -> Q (Maybe Name)
-lookupTypeName s = Q (qLookupName True s)
+lookupTypeName s = Q $ \h -> mLookupName h True s
-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
lookupValueName :: String -> Q (Maybe Name)
-lookupValueName s = Q (qLookupName False s)
+lookupValueName s = Q $ \h -> mLookupName h False s
{-
Note [Name lookup]
@@ -620,7 +594,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName':
and to get information about @D@-the-type, use 'lookupTypeName'.
-}
reify :: Name -> Q Info
-reify v = Q (qReify v)
+reify v = Q $ \h -> mReify h v
{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
@@ -629,7 +603,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
'Nothing', so you may assume @bar@ has 'defaultFixity'.
-}
reifyFixity :: Name -> Q (Maybe Fixity)
-reifyFixity nm = Q (qReifyFixity nm)
+reifyFixity nm = Q $ \h -> mReifyFixity h nm
{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
@reifyType 'not@ returns @Bool -> Bool@, and
@@ -637,7 +611,7 @@ reifyFixity nm = Q (qReifyFixity nm)
This works even if there's no explicit signature and the type or kind is inferred.
-}
reifyType :: Name -> Q Type
-reifyType nm = Q (qReifyType nm)
+reifyType nm = Q $ \h -> mReifyType h nm
{- | Template Haskell is capable of reifying information about types and
terms defined in previous declaration groups. Top-level declaration splices break up
@@ -729,7 +703,7 @@ has some discussion around this.
-}
reifyInstances :: Name -> [Type] -> Q [InstanceDec]
-reifyInstances cls tys = Q (qReifyInstances cls tys)
+reifyInstances cls tys = Q $ \h -> mReifyInstances h cls tys
{- | @reifyRoles nm@ returns the list of roles associated with the parameters
(both visible and invisible) of
@@ -748,20 +722,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i
the role of the invisible @k@ parameter. Kind parameters are always nominal.
-}
reifyRoles :: Name -> Q [Role]
-reifyRoles nm = Q (qReifyRoles nm)
+reifyRoles nm = Q $ \h -> mReifyRoles h nm
-- | @reifyAnnotations target@ returns the list of annotations
-- associated with @target@. Only the annotations that are
-- appropriately typed is returned. So if you have @Int@ and @String@
-- annotations for the same target, you have to call this function twice.
reifyAnnotations :: Data a => AnnLookup -> Q [a]
-reifyAnnotations an = Q (qReifyAnnotations an)
+reifyAnnotations an = Q $ \h -> mReifyAnnotations h an
-- | @reifyModule mod@ looks up information about module @mod@. To
-- look up the current module, call this function with the return
-- value of 'Language.Haskell.TH.Lib.thisModule'.
reifyModule :: Module -> Q ModuleInfo
-reifyModule m = Q (qReifyModule m)
+reifyModule m = Q $ \h -> mReifyModule h m
-- | @reifyConStrictness nm@ looks up the strictness information for the fields
-- of the constructor with the name @nm@. Note that the strictness information
@@ -776,7 +750,7 @@ reifyModule m = Q (qReifyModule m)
-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
-- @-XStrictData@ language extension was enabled.
reifyConStrictness :: Name -> Q [DecidedStrictness]
-reifyConStrictness n = Q (qReifyConStrictness n)
+reifyConStrictness n = Q $ \h -> mReifyConStrictness h n
-- | Is the list of instances returned by 'reifyInstances' nonempty?
--
@@ -789,7 +763,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys
-- | The location at which this computation is spliced.
location :: Q Loc
-location = Q qLocation
+location = Q mLocation
-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
-- Take care: you are guaranteed the ordering of calls to 'runIO' within
@@ -799,7 +773,7 @@ location = Q qLocation
-- necessarily flushed when the compiler finishes running, so you should
-- flush them yourself.
runIO :: IO a -> Q a
-runIO m = Q (qRunIO m)
+runIO m = Q $ \h -> mLiftIO h m
-- | Get the package root for the current package which is being compiled.
-- This can be set explicitly with the -package-root flag but is normally
@@ -811,7 +785,7 @@ runIO m = Q (qRunIO m)
-- change directory when compiling files but instead set the -package-root flag
-- appropriately.
getPackageRoot :: Q FilePath
-getPackageRoot = Q qGetPackageRoot
+getPackageRoot = Q mGetPackageRoot
-- | Record external directories that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -830,7 +804,7 @@ getPackageRoot = Q qGetPackageRoot
-- * The state of the directory is read at the interface generation time,
-- not at the time of the function call.
addDependentDirectory :: FilePath -> Q ()
-addDependentDirectory dp = Q (qAddDependentDirectory dp)
+addDependentDirectory dp = Q $ \h -> mAddDependentDirectory h dp
-- | Record external files that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -844,17 +818,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp)
--
-- * The dependency is based on file content, not a modification time
addDependentFile :: FilePath -> Q ()
-addDependentFile fp = Q (qAddDependentFile fp)
+addDependentFile fp = Q $ \h -> mAddDependentFile h fp
-- | Obtain a temporary file path with the given suffix. The compiler will
-- delete this file after compilation.
addTempFile :: String -> Q FilePath
-addTempFile suffix = Q (qAddTempFile suffix)
+addTempFile suffix = Q $ \h -> mAddTempFile h suffix
-- | Add additional top-level declarations. The added declarations will be type
-- checked along with the current declaration group.
addTopDecls :: [Dec] -> Q ()
-addTopDecls ds = Q (qAddTopDecls ds)
+addTopDecls ds = Q $ \h -> mAddTopDecls h ds
-- | Same as 'addForeignSource', but expects to receive a path pointing to the
-- foreign file instead of a 'String' of its contents. Consider using this in
@@ -863,7 +837,7 @@ addTopDecls ds = Q (qAddTopDecls ds)
-- This is a good alternative to 'addForeignSource' when you are trying to
-- directly link in an object file.
addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
-addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
+addForeignFilePath lang fp = Q $ \h -> mAddForeignFilePath h lang fp
-- | Add a finalizer that will run in the Q monad after the current module has
-- been type checked. This only makes sense when run within a top-level splice.
@@ -872,7 +846,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
-- 'reify' is able to find the local definitions when executed inside the
-- finalizer.
addModFinalizer :: Q () -> Q ()
-addModFinalizer act = Q (qAddModFinalizer (unQ act))
+addModFinalizer act = Q $ \h -> mAddModFinalizer h act
-- | Adds a core plugin to the compilation pipeline.
--
@@ -882,7 +856,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act))
-- to tell the compiler that we needed to compile first a plugin module in the
-- current package.
addCorePlugin :: String -> Q ()
-addCorePlugin plugin = Q (qAddCorePlugin plugin)
+addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin
-- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to
-- a type-indexed finite map. That is,
@@ -896,20 +870,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin)
-- Note that the state is local to the Haskell module in which the Template
-- Haskell expression is executed.
getQ :: Typeable a => Q (Maybe a)
-getQ = Q qGetQ
+getQ = Q mGetQ
-- | Replace the state in the 'Q' monad. Note that the state is local to the
-- Haskell module in which the Template Haskell expression is executed.
putQ :: Typeable a => a -> Q ()
-putQ x = Q (qPutQ x)
+putQ x = Q $ \h -> mPutQ h x
-- | Determine whether the given language extension is enabled in the 'Q' monad.
isExtEnabled :: Extension -> Q Bool
-isExtEnabled ext = Q (qIsExtEnabled ext)
+isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext
-- | List all enabled language extensions.
extsEnabled :: Q [Extension]
-extsEnabled = Q qExtsEnabled
+extsEnabled = Q mExtsEnabled
-- | Add Haddock documentation to the specified location. This will overwrite
-- any documentation at the location if it already exists. This will reify the
@@ -928,48 +902,18 @@ extsEnabled = Q qExtsEnabled
-- Adding documentation to anything outside of the current module will cause an
-- error.
putDoc :: DocLoc -> String -> Q ()
-putDoc t s = Q (qPutDoc t s)
+putDoc t s = Q $ \h -> mPutDoc h t s
-- | Retrieves the Haddock documentation at the specified location, if one
-- exists.
-- It can be used to read documentation on things defined outside of the current
-- module, provided that those modules were compiled with the @-haddock@ flag.
getDoc :: DocLoc -> Q (Maybe String)
-getDoc n = Q (qGetDoc n)
+getDoc n = Q $ \h -> mGetDoc h n
instance MonadIO Q where
liftIO = runIO
-instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddDependentDirectory = addDependentDirectory
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
-
-
----------------------------------------------------
-- The following operations are used solely in GHC.HsToCore.Quote when
-- desugaring brackets. They are not necessary for the user, who can use
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
- TupleSections, RecordWildCards, InstanceSigs, CPP #-}
+ TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- |
@@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do
instance MonadIO GHCiQ where
liftIO m = GHCiQ $ \_ -> m
-instance TH.Quasi GHCiQ where
- qNewName str = ghcCmd (NewName str)
- qReport isError msg = ghcCmd (Report isError msg)
-
- -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
- qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do
- s <- readIORef sRef
- remoteTHCall (qsPipe s) StartRecover
- e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef
- remoteTHCall (qsPipe s) (EndRecover (isLeft e))
- case e of
- Left GHCiQException{} -> h sRef
- Right r -> return r
- qLookupName isType occ = ghcCmd (LookupName isType occ)
- qReify name = ghcCmd (Reify name)
- qReifyFixity name = ghcCmd (ReifyFixity name)
- qReifyType name = ghcCmd (ReifyType name)
- qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
- qReifyRoles name = ghcCmd (ReifyRoles name)
-
-- To reify annotations, we send GHC the AnnLookup and also the
-- TypeRep of the thing we're looking for, to avoid needing to
-- serialize irrelevant annotations.
- qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
- qReifyAnnotations lookup =
+reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
+reifyAnnotations lookup =
map (deserializeWithData . B.unpack) <$>
ghcCmd (ReifyAnnotations lookup typerep)
where typerep = typeOf (undefined :: a)
- qReifyModule m = ghcCmd (ReifyModule m)
- qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
- qLocation = fromMaybe noLoc . qsLocation <$> getState
- qGetPackageRoot = ghcCmd GetPackageRoot
- qAddDependentFile file = ghcCmd (AddDependentFile file)
- qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir)
- qAddTempFile suffix = ghcCmd (AddTempFile suffix)
- qAddTopDecls decls = ghcCmd (AddTopDecls decls)
- qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
- qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=
+runQinGHCiQ :: TH.Q a -> GHCiQ a
+runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef))
+ where
+ runInIO :: IORef QState -> GHCiQ a -> IO a
+ runInIO sRef (GHCiQ m) = m sRef
+
+metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers
+metaHandlersGHCiQ runInIO = TH.MetaHandlers {
+ mLiftIO = id
+ , mFail = runInIO . fail
+ , mNewName = \str -> runInIO $ ghcCmd (NewName str)
+ , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg)
+
+ -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
+ , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do
+ s <- readIORef sRef
+ remoteTHCall (qsPipe s) StartRecover
+ e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef
+ remoteTHCall (qsPipe s) (EndRecover (isLeft e))
+ case e of
+ Left GHCiQException{} ->
+ runGHCiQ (runQinGHCiQ h) sRef
+ Right r -> return r
+ , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ)
+ , mReify = \name ->runInIO $ ghcCmd (Reify name)
+ , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name)
+ , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name)
+ , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys)
+ , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name)
+
+ , mReifyAnnotations = runInIO . reifyAnnotations
+ , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m)
+ , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name)
+ , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState
+ , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot
+ , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file)
+ , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir)
+ , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix)
+ , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls)
+ , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp)
+ , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>=
ghcCmd . AddModFinalizer
- qAddCorePlugin str = ghcCmd (AddCorePlugin str)
- qGetQ = do
+ , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str)
+ , mGetQ = runInIO $ do
s <- getState
let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
return $ lookup (qsMap s)
- qPutQ k = GHCiQ $ \sRef ->
- modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
- qIsExtEnabled x = ghcCmd (IsExtEnabled x)
- qExtsEnabled = ghcCmd ExtsEnabled
- qPutDoc l s = ghcCmd (PutDoc l s)
- qGetDoc l = ghcCmd (GetDoc l)
+ , mPutQ = \k -> runInIO $ GHCiQ $ \sRef ->
+ modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
+ , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x)
+ , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled
+ , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s)
+ , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l)
+}
-- | The implementation of the 'StartTH' message: create
-- a new IORef QState, and return a RemoteRef to it.
@@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do
qstateref <- localRef rstate
qstate <- readIORef qstateref
qstate' <- newIORef $ qstate { qsPipe = pipe }
- _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'
+ _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate'
return ()
-- | The implementation of the 'RunTH' message
@@ -272,5 +284,5 @@ runTHQ
runTHQ pipe rstate mb_loc ghciq = do
qstateref <- localRef rstate
modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })
- r <- runGHCiQ (TH.runQ ghciq) qstateref
+ r <- runGHCiQ (runQinGHCiQ ghciq) qstateref
return $! LB.toStrict (runPut (put r))
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -5,13 +5,17 @@
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE UnboxedTuples #-}
+-- Don't warn for using 'report' from ghc-internal
+{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
module Language.Haskell.TH.Syntax (
Quote (..),
Exp (..),
Match (..),
Clause (..),
- Q (..),
+ Q,
+ -- backwards compatibility
+ Language.Haskell.TH.Syntax.unQ,
Pat (..),
Stmt (..),
Con (..),
@@ -202,11 +206,14 @@ where
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
-import GHC.Boot.TH.Monad
+import GHC.Boot.TH.Monad hiding (report)
+import qualified GHC.Boot.TH.Monad as Internal
import System.FilePath
import Data.Data hiding (Fixity(..))
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Lexeme ( startsVarSym, startsVarId )
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import System.IO (hPutStrLn, stderr)
-- This module completely re-exports 'GHC.Boot.TH.Syntax',
-- and exports additionally functions that depend on @filepath@ or @System.IO@.
@@ -499,3 +506,170 @@ reassociate the tree as necessary.
-- Subsumed by the more general 'SpecialiseEP' constructor.
pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma
pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases
+
+unQ :: Q a -> (forall m. Quasi m => m a)
+unQ m = runQ m
+
+-----------------------------------------------------
+--
+-- The Quasi class
+--
+-----------------------------------------------------
+
+class (MonadIO m, MonadFail m) => Quasi m where
+ qRunQ :: Q a -> m a
+ -- | Fresh names. See 'newName'.
+ qNewName :: String -> m Name
+ qNewName = qRunQ . newName
+
+ ------- Error reporting and recovery -------
+ -- | Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop. See 'report'.
+ qReport :: Bool -> String -> m ()
+ qReport b s = qRunQ $ report b s
+
+ -- | See 'recover'.
+ qRecover :: m a -- ^ the error handler
+ -> m a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ ------- Inspect the type-checker's environment -------
+ -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
+ qLookupName :: Bool -> String -> m (Maybe Name)
+ qLookupName ns s = qRunQ $ lookupName ns s
+ -- | See 'reify'.
+ qReify :: Name -> m Info
+ qReify v = qRunQ $ reify v
+ -- | See 'reifyFixity'.
+ qReifyFixity :: Name -> m (Maybe Fixity)
+ qReifyFixity v = qRunQ $ reifyFixity v
+ -- | See 'reifyType'.
+ qReifyType :: Name -> m Type
+ qReifyType v = qRunQ $ reifyType v
+ -- | Is (n tys) an instance? Returns list of matching instance Decs (with
+ -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
+ qReifyInstances :: Name -> [Type] -> m [Dec]
+ qReifyInstances cls tys = qRunQ $ reifyInstances cls tys
+ -- | See 'reifyRoles'.
+ qReifyRoles :: Name -> m [Role]
+ qReifyRoles nm = qRunQ $ reifyRoles nm
+ -- | See 'reifyAnnotations'.
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ qReifyAnnotations an = qRunQ $ reifyAnnotations an
+ -- | See 'reifyModule'.
+ qReifyModule :: Module -> m ModuleInfo
+ qReifyModule m = qRunQ $ reifyModule m
+ -- | See 'reifyConStrictness'.
+ qReifyConStrictness :: Name -> m [DecidedStrictness]
+ qReifyConStrictness nm = qRunQ $ qReifyConStrictness nm
+
+ -- | See 'location'.
+ qLocation :: m Loc
+ qLocation = qRunQ location
+
+ -- | Input/output (dangerous). See 'runIO'.
+ qRunIO :: IO a -> m a
+ qRunIO = liftIO
+ -- | See 'getPackageRoot'.
+ qGetPackageRoot :: m FilePath
+ qGetPackageRoot = qRunQ getPackageRoot
+
+ -- | See 'addDependentFile'.
+ qAddDependentFile :: FilePath -> m ()
+ qAddDependentFile p = qRunQ $ qAddDependentFile p
+
+ -- | See 'addDependentDirectory'.
+ qAddDependentDirectory :: FilePath -> m ()
+ qAddDependentDirectory p = qRunQ $ qAddDependentDirectory p
+
+ -- | See 'addTempFile'.
+ qAddTempFile :: String -> m FilePath
+ qAddTempFile p = qRunQ $ qAddTempFile p
+
+ -- | See 'addTopDecls'.
+ qAddTopDecls :: [Dec] -> m ()
+ qAddTopDecls decls = qRunQ $ qAddTopDecls decls
+
+ -- | See 'addForeignFilePath'.
+ qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+ qAddForeignFilePath lang fp = qRunQ $ addForeignFilePath lang fp
+
+ -- | See 'addModFinalizer'.
+ qAddModFinalizer :: Q () -> m ()
+ qAddModFinalizer fin = qRunQ $ addModFinalizer fin
+
+ -- | See 'addCorePlugin'.
+ qAddCorePlugin :: String -> m ()
+ qAddCorePlugin nm = qRunQ $ addCorePlugin nm
+
+ -- | See 'getQ'.
+ qGetQ :: Typeable a => m (Maybe a)
+ qGetQ = qRunQ getQ
+
+ -- | See 'putQ'.
+ qPutQ :: Typeable a => a -> m ()
+ qPutQ x = qRunQ $ putQ x
+
+ -- | See 'isExtEnabled'.
+ qIsExtEnabled :: Extension -> m Bool
+ qIsExtEnabled ext = qRunQ $ isExtEnabled ext
+ -- | See 'extsEnabled'.
+ qExtsEnabled :: m [Extension]
+ qExtsEnabled = qRunQ extsEnabled
+
+ -- | See 'putDoc'.
+ qPutDoc :: DocLoc -> String -> m ()
+ qPutDoc l s = qRunQ $ putDoc l s
+ -- | See 'getDoc'.
+ qGetDoc :: DocLoc -> m (Maybe String)
+ qGetDoc l = qRunQ $ getDoc l
+
+-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
+-- should not need this function, as the splice brackets @$( ... )@
+-- are the usual way of running a 'Q' computation.
+--
+-- This function is primarily used in GHC internals, and for debugging
+-- splices by running them in 'IO'.
+--
+-- Note that many functions in 'Q', such as 'reify' and other compiler
+-- queries, are not supported when running 'Q' in 'IO'; these operations
+-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
+-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
+runQ :: Quasi m => Q a -> m a
+runQ = qRunQ
+
+-----------------------------------------------------
+-- The IO instance of Quasi
+-----------------------------------------------------
+
+-- | This instance is used only when running a Q
+-- computation in the IO monad, usually just to
+-- print the result. There is no interesting
+-- type environment, so reification isn't going to
+-- work.
+instance Quasi IO where
+ qRunQ (Q m) = m metaHandlersIO
+ qNewName = newNameIO
+
+ qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+
+instance Quasi Q where
+ qRunQ = id
+ qRecover = recover
+
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report = Internal.report
+{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+
+-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -354,7 +354,6 @@ module Language.Haskell.TH where
type Pred = Type
type PredQ :: *
type PredQ = Q Pred
- type role Q nominal
type Q :: * -> *
newtype Q a = ...
type Quote :: (* -> *) -> Constraint
@@ -655,7 +654,7 @@ module Language.Haskell.TH where
roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec
ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr
runIO :: forall a. GHC.Internal.Types.IO a -> Q a
- runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a
+ runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a
safe :: Safety
sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
@@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where
data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
type Pred :: *
type Pred = Type
- type role Q nominal
type Q :: * -> *
- newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a}
+ newtype Q a = ...
type Quasi :: (* -> *) -> Constraint
class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where
+ qRunQ :: forall a. Q a -> m a
qNewName :: GHC.Internal.Base.String -> m Name
qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m ()
qRecover :: forall a. m a -> m a -> m a
@@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
qAddModFinalizer :: Q () -> m ()
qAddCorePlugin :: GHC.Internal.Base.String -> m ()
- qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
- qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
+ qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
+ qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
- {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
+ {-# MINIMAL qRunQ, qRecover #-}
type Quote :: (* -> *) -> Constraint
class GHC.Internal.Base.Monad m => Quote m where
newName :: GHC.Internal.Base.String -> m Name
@@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where
falseName :: Name
getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
getPackageRoot :: Q GHC.Internal.IO.FilePath
- getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
+ getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
get_cons_names :: Con -> [Name]
hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a
isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool
@@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where
oneName :: Name
pkgString :: PkgName -> GHC.Internal.Base.String
putDoc :: DocLoc -> GHC.Internal.Base.String -> Q ()
- putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
+ putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
recover :: forall a. Q a -> Q a -> Q a
reify :: Name -> Q Info
reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a]
@@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where
trueName :: Name
tupleDataName :: GHC.Internal.Types.Int -> Name
tupleTypeName :: GHC.Internal.Types.Int -> Name
+ unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a
unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp
unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp
unboxedSumDataName :: SumAlt -> SumArity -> Name
@@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif
instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’
instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
-instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’
instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’
+instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6f6f5c704c94d865b95cb73b2abba6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d6f6f5c704c94d865b95cb73b2abba6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0