From 393531ff00d0d487f0721c0680a67dbc1db2fa3d Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Mon, 5 Feb 2024 23:25:46 +0000
Subject: [PATCH] Specialising expressions -- at last
This MR addresses #24359, which implements the GHC proposal 493 on SPECIALISE pragmas.
* The old code path (using SpecSig and SpecPrag) still exists.
* The new code path (using SpecSigE and SpecPragE) runs alongside it.
* All SPECIALISE pragmas are routed through the new code path, except
if you give multiple type sigs, when the old code path is still used.
* Main documentation: Note [Handling new-form SPECIALISE pragmas] in
GHC.Tc.Gen.Sig`
Thanks to @sheaf for helping with this MR.
The Big Thing is to introduce
{-# SPECIALISE forall x. f @Int x True #-}
where you can give type arguments and value argument to specialise; and
you can quantify them with forall, just as in Rules.
I thought it was going to be pretty simple, but it was a Long, Long Saga.
Highlights
* Overview Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
- New data constructor `SpecSigE` in data type `L.H.S.Binds.Sig`
- New data construtor `SpecPragE` in data type `GHC.Hs.Binds.TcSpecPrag`
- Renamer: uses `checkSpecESigShape` to decide which function to assocate the
SPECIALISE pragma with
- Some of the action is in `GHC.Tc.Gen.Sig.tcSpecPrag`
- The rest is in `GHC.HsToCore.Binds.dsSpec`
* We use a new TcS mode, TcSFullySolve, when simplifying the Wanteds
that arise from the specialise expression. The mechanism is explained
in Note [TcSFullySolve] in GHC.Tc.Solver.Monad. The reason why we need
to do this is explained in Note [Fully solving constraints for specialisation]
in GHC.Tc.Gen.Sig.
* All of GHC.Tc.Gen.Rule is moved into GHC.Tc.Gen.Sig, because the code is
very closely related.
* The forall'd binders for SPECIALISE are the same as those for a RULE, so I
refactored, introducing data type `L.H.S.Binds.RuleBndrs`, with functions
to rename, zonk, typecheck it. I refactored this data type a bit; nicer now.
* On the LHS of RULES, or SPECIALISE, we want to disable the tricky mechanims
described in Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr.
Previously it wasn't fully disabled (just set to the empty set), and that
didn't quite work in the new regime.
* There are knock-on changes to Template Haskell.
* For the LHS of a RULE and a SPECIALISE expression, I wanted to simplify
it /without/ inlining the let-bindings for evidence variables. I added
a flag `so_inline` to the SimpleOpt optimiser to support this. The
entry point is `GHC.Core.SimpleOpt.simpleOptExprNoInline`
* Since forever we have had a hack for type variables on the LHS of
RULES. I took the opportunity to tidy this up. The main action is
in the zonker. See GHC.Tc.Zonk.Type Note [Free tyvars on rule LHS],
and especially data construtor `SkolemiseFlexi`
in data type `GHC.Tc.Zonk.Env.ZonkFlexi`
* Move `scopedSort` from GHC.Core.TyCo.FVs to GHC.Core.Predicate
Reason: it now works for Ids as well, and I wanted to use isEvVar,
which is defined in GHC.Core.Predicate
Avoiding module loops meant that instead of exporting GHC.Core.TyCo.Tidy
from GHC.Core.Type, modules now import the former directly.
I also took the opportunity to remove unused exports
from GHC.Core.Type.hs-boot
* Flag stuff:
- Add flag `-Wdeprecated-pragmas` and use it to control the warning when
using old-style SPECIALISE pragmas with multiple type ascriptions,
- Add flag `-Wuseless-specialisations` and use it to control the warning emitted
when GHC determines that a SPECIALISE pragma would have no effect. Don't
want if the SPECIALISE is SPECIALISE INLINE (#4444)
In response to #25389, we continue to generate these seemingly code for these
seemingly useless SPECIALISE pragmas
- Adds deprecations to Template Haskell `pragSpecD` and `pracSpecInlD`,
* Split up old-style SPECIALISE pragmas in GHC.Internal.Float,
GHC.Internal.Numeric, GHC.Internal.Real
* Remove useless SPECIALISE pragmas in Data.Array (updating the array submodule)
Smaller things:
- Update the Users Guide
- Add mention of the changes to the 9.14 release notes as well as
the Template Haskell changelog,
---
compiler/GHC/Builtin/Names/TH.hs | 14 +-
compiler/GHC/Builtin/PrimOps/Ids.hs | 1 +
compiler/GHC/Core/FamInstEnv.hs | 1 +
compiler/GHC/Core/InstEnv.hs | 7 +-
compiler/GHC/Core/Make.hs | 2 +-
compiler/GHC/Core/Opt/CSE.hs | 3 +
compiler/GHC/Core/Opt/Simplify/Iteration.hs | 20 +-
compiler/GHC/Core/Opt/Simplify/Utils.hs | 10 +-
compiler/GHC/Core/Opt/SpecConstr.hs | 2 +-
compiler/GHC/Core/Predicate.hs | 126 ++-
compiler/GHC/Core/SimpleOpt.hs | 30 +-
compiler/GHC/Core/Tidy.hs | 5 +-
compiler/GHC/Core/TyCo/FVs.hs | 106 ---
compiler/GHC/Core/TyCo/Ppr.hs | 5 +-
compiler/GHC/Core/TyCo/Tidy.hs | 1 +
compiler/GHC/Core/Type.hs | 26 -
compiler/GHC/Core/Type.hs-boot | 35 +-
compiler/GHC/Core/Unify.hs | 1 +
compiler/GHC/CoreToIface.hs | 2 +-
compiler/GHC/Driver/Config.hs | 1 +
compiler/GHC/Driver/Flags.hs | 8 +-
compiler/GHC/Driver/Session.hs | 2 +
compiler/GHC/Hs/Binds.hs | 128 ++-
compiler/GHC/Hs/Decls.hs | 27 +-
compiler/GHC/Hs/Instances.hs | 7 +
compiler/GHC/Hs/Stats.hs | 1 +
compiler/GHC/HsToCore.hs | 17 +-
compiler/GHC/HsToCore/Binds.hs | 655 ++++++++++----
compiler/GHC/HsToCore/Errors/Ppr.hs | 54 +-
compiler/GHC/HsToCore/Errors/Types.hs | 33 +-
compiler/GHC/HsToCore/Expr.hs | 22 +-
compiler/GHC/HsToCore/Foreign/Call.hs | 27 +-
compiler/GHC/HsToCore/Monad.hs | 18 +-
compiler/GHC/HsToCore/Quote.hs | 113 ++-
compiler/GHC/HsToCore/Types.hs | 17 +-
compiler/GHC/Iface/Decl.hs | 1 +
compiler/GHC/Iface/Ext/Ast.hs | 25 +-
compiler/GHC/Iface/Tidy.hs | 1 +
compiler/GHC/Parser.y | 62 +-
compiler/GHC/Parser/Errors/Ppr.hs | 12 +
compiler/GHC/Parser/Errors/Types.hs | 16 +
compiler/GHC/Parser/PostProcess.hs | 99 ++-
compiler/GHC/Rename/Bind.hs | 102 ++-
compiler/GHC/Rename/HsType.hs | 1 +
compiler/GHC/Rename/Module.hs | 102 +--
compiler/GHC/Rename/Names.hs | 2 +-
compiler/GHC/Runtime/Debugger.hs | 1 +
compiler/GHC/Runtime/Eval.hs | 9 +-
compiler/GHC/Runtime/Heap/Inspect.hs | 1 +
compiler/GHC/StgToByteCode.hs | 1 +
compiler/GHC/Tc/Deriv.hs | 34 +-
compiler/GHC/Tc/Errors.hs | 2 +-
compiler/GHC/Tc/Errors/Ppr.hs | 10 +
compiler/GHC/Tc/Errors/Types.hs | 10 +
compiler/GHC/Tc/Gen/Bind.hs | 32 +-
compiler/GHC/Tc/Gen/HsType.hs | 45 +-
compiler/GHC/Tc/Gen/Rule.hs | 525 ------------
compiler/GHC/Tc/Gen/Sig.hs | 811 +++++++++++++++++-
compiler/GHC/Tc/Module.hs | 17 +-
compiler/GHC/Tc/Solver.hs | 52 +-
compiler/GHC/Tc/Solver/Default.hs | 1 +
compiler/GHC/Tc/Solver/Dict.hs | 21 -
compiler/GHC/Tc/Solver/InertSet.hs | 72 +-
compiler/GHC/Tc/Solver/Irred.hs | 4 -
compiler/GHC/Tc/Solver/Monad.hs | 147 +++-
compiler/GHC/Tc/Solver/Solve.hs | 159 +++-
compiler/GHC/Tc/TyCl.hs | 2 +-
compiler/GHC/Tc/TyCl/Instance.hs | 14 +-
compiler/GHC/Tc/TyCl/PatSyn.hs | 3 +-
compiler/GHC/Tc/Types/Constraint.hs | 1 +
compiler/GHC/Tc/Types/Evidence.hs | 14 +-
compiler/GHC/Tc/Types/Origin.hs | 17 +-
compiler/GHC/Tc/Utils/Instantiate.hs | 1 +
compiler/GHC/Tc/Utils/Monad.hs | 15 +-
compiler/GHC/Tc/Utils/TcMType.hs | 7 +-
compiler/GHC/Tc/Validity.hs | 15 +-
compiler/GHC/Tc/Zonk/Env.hs | 10 +-
compiler/GHC/Tc/Zonk/TcType.hs | 1 +
compiler/GHC/Tc/Zonk/Type.hs | 196 +++--
compiler/GHC/ThToHs.hs | 47 +-
compiler/GHC/Types/Basic.hs | 7 +-
compiler/GHC/Types/Error/Codes.hs | 26 +-
compiler/GHC/Types/Hint.hs | 5 +
compiler/GHC/Types/Hint/Ppr.hs | 2 +
compiler/GHC/Types/Var.hs | 2 +-
compiler/Language/Haskell/Syntax/Binds.hs | 55 +-
compiler/Language/Haskell/Syntax/Decls.hs | 24 +-
compiler/Language/Haskell/Syntax/Extension.hs | 6 +
compiler/ghc.cabal.in | 1 -
docs/users_guide/9.14.1-notes.rst | 29 +
docs/users_guide/exts/pragmas.rst | 44 +-
docs/users_guide/using-warnings.rst | 35 +
libraries/array | 2 +-
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs | 28 +-
.../ghc-internal/src/GHC/Internal/Float.hs | 8 +-
.../ghc-internal/src/GHC/Internal/Numeric.hs | 9 +-
.../ghc-internal/src/GHC/Internal/Real.hs | 14 +-
.../ghc-internal/src/GHC/Internal/TH/Lib.hs | 27 +
.../src/GHC/Internal/TH/Syntax.hs | 6 +-
.../Language/Haskell/TH/Lib.hs | 4 +-
libraries/template-haskell/changelog.md | 7 +
.../deSugar/should_compile/T10251.stderr | 5 +
testsuite/tests/diagnostic-codes/codes.stdout | 5 +-
testsuite/tests/ghc-api/T18522-dbg-ppr.hs | 4 +-
.../template-haskell-exports.stdout | 10 +-
.../should_compile/OpaqueParseWarn1.stderr | 4 +-
.../tests/parser/should_fail/T7848.stderr | 14 +-
.../simplCore/should_compile/DsSpecPragmas.hs | 147 ++++
.../should_compile/DsSpecPragmas.stderr | 75 ++
.../simplCore/should_compile/T12603.stdout | 2 +-
.../simplCore/should_compile/T15445.stderr | 1 +
.../tests/simplCore/should_compile/T24359a.hs | 18 +
.../simplCore/should_compile/T24359a.stderr | 7 +
.../tests/simplCore/should_compile/T25389.hs | 19 +
.../simplCore/should_compile/T25389.stderr | 103 +++
.../simplCore/should_compile/T4398.stderr | 4 +-
.../tests/simplCore/should_compile/T5821.hs | 3 +
.../simplCore/should_compile/T8537.stderr | 6 +-
.../tests/simplCore/should_compile/T9578b.hs | 84 ++
.../tests/simplCore/should_compile/all.T | 3 +
.../simplCore/should_compile/simpl016.stderr | 10 -
.../tests/simplCore/should_fail/T25117a.hs | 6 +
.../simplCore/should_fail/T25117a.stderr | 2 +
.../tests/simplCore/should_fail/T25117b.hs | 7 +
.../simplCore/should_fail/T25117b.stderr | 5 +
testsuite/tests/simplCore/should_fail/all.T | 2 +
.../tests/simplCore/should_run/T24359b.hs | 24 +
.../tests/simplCore/should_run/T24359b.stdout | 1 +
testsuite/tests/simplCore/should_run/all.T | 1 +
testsuite/tests/th/T13123.stderr | 5 +
testsuite/tests/th/T19363.stdout | 6 +-
testsuite/tests/th/T7064.stdout | 12 +-
testsuite/tests/th/TH_pragma.hs | 4 +
testsuite/tests/th/TH_pragma.stderr | 8 +
.../typecheck/should_compile/T10504.stderr | 6 +-
.../typecheck/should_compile/T2494.stderr | 14 +-
.../typecheck/should_compile/TcSpecPragmas.hs | 56 ++
.../should_compile/TcSpecPragmas.stderr | 15 +
.../tests/typecheck/should_compile/all.T | 1 +
.../tests/typecheck/should_compile/tc186.hs | 2 +-
.../tests/typecheck/should_compile/tc212.hs | 1 +
.../typecheck/should_fail/SpecPragmasFail.hs | 14 +
.../should_fail/SpecPragmasFail.stderr | 6 +
.../tests/typecheck/should_fail/T5853.stderr | 6 +-
.../should_compile/SpecMultipleTys.hs | 12 +
.../should_compile/SpecMultipleTys.stderr | 5 +
.../warnings/should_compile/T19296.stderr | 19 +-
testsuite/tests/warnings/should_compile/all.T | 1 +
.../warnings/should_fail/SpecEMultipleTys.hs | 10 +
.../should_fail/SpecEMultipleTys.stderr | 5 +
testsuite/tests/warnings/should_fail/all.T | 1 +
utils/check-exact/ExactPrint.hs | 111 ++-
152 files changed, 3836 insertions(+), 1644 deletions(-)
delete mode 100644 compiler/GHC/Tc/Gen/Rule.hs
create mode 100644 testsuite/tests/deSugar/should_compile/T10251.stderr
create mode 100644 testsuite/tests/simplCore/should_compile/DsSpecPragmas.hs
create mode 100644 testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr
create mode 100644 testsuite/tests/simplCore/should_compile/T24359a.hs
create mode 100644 testsuite/tests/simplCore/should_compile/T24359a.stderr
create mode 100644 testsuite/tests/simplCore/should_compile/T25389.hs
create mode 100644 testsuite/tests/simplCore/should_compile/T25389.stderr
create mode 100644 testsuite/tests/simplCore/should_compile/T9578b.hs
delete mode 100644 testsuite/tests/simplCore/should_compile/simpl016.stderr
create mode 100644 testsuite/tests/simplCore/should_fail/T25117a.hs
create mode 100644 testsuite/tests/simplCore/should_fail/T25117a.stderr
create mode 100644 testsuite/tests/simplCore/should_fail/T25117b.hs
create mode 100644 testsuite/tests/simplCore/should_fail/T25117b.stderr
create mode 100644 testsuite/tests/simplCore/should_run/T24359b.hs
create mode 100644 testsuite/tests/simplCore/should_run/T24359b.stdout
create mode 100644 testsuite/tests/th/T13123.stderr
create mode 100644 testsuite/tests/typecheck/should_compile/TcSpecPragmas.hs
create mode 100644 testsuite/tests/typecheck/should_compile/TcSpecPragmas.stderr
create mode 100644 testsuite/tests/typecheck/should_fail/SpecPragmasFail.hs
create mode 100644 testsuite/tests/typecheck/should_fail/SpecPragmasFail.stderr
create mode 100644 testsuite/tests/warnings/should_compile/SpecMultipleTys.hs
create mode 100644 testsuite/tests/warnings/should_compile/SpecMultipleTys.stderr
create mode 100644 testsuite/tests/warnings/should_fail/SpecEMultipleTys.hs
create mode 100644 testsuite/tests/warnings/should_fail/SpecEMultipleTys.stderr
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index a888294a687..7fd5d3c6bda 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -75,7 +75,9 @@ templateHaskellNames = [
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,
classDName, instanceWithOverlapDName,
standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
- pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
+ pragInlDName, pragOpaqueDName,
+ pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,
+ pragSpecInstDName,
pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
defaultSigDName, defaultDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -386,7 +388,8 @@ recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
- pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
+ pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,
+ pragSpecInstDName, pragRuleDName,
pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
@@ -411,6 +414,8 @@ pragInlDName = libFun (fsLit "pragInlD")
pragOpaqueDName = libFun (fsLit "pragOpaqueD") pragOpaqueDIdKey
pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
+pragSpecEDName = libFun (fsLit "pragSpecED") pragSpecEDIdKey
+pragSpecInlEDName = libFun (fsLit "pragSpecInlED") pragSpecInlEDIdKey
pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey
@@ -962,7 +967,8 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey,
roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey,
implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey,
- typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey :: Unique
+ typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey,
+ pragSpecEDIdKey, pragSpecInlEDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -1001,6 +1007,8 @@ pragOpaqueDIdKey = mkPreludeMiscIdUnique 354
typeDataDIdKey = mkPreludeMiscIdUnique 355
pragSCCFunDKey = mkPreludeMiscIdUnique 356
pragSCCFunNamedDKey = mkPreludeMiscIdUnique 357
+pragSpecEDIdKey = mkPreludeMiscIdUnique 358
+pragSpecInlEDIdKey = mkPreludeMiscIdUnique 359
-- type Cxt = ...
cxtIdKey :: Unique
diff --git a/compiler/GHC/Builtin/PrimOps/Ids.hs b/compiler/GHC/Builtin/PrimOps/Ids.hs
index cec163b9b15..488064ad909 100644
--- a/compiler/GHC/Builtin/PrimOps/Ids.hs
+++ b/compiler/GHC/Builtin/PrimOps/Ids.hs
@@ -16,6 +16,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules)
import GHC.Core.TyCo.Rep ( scaledThing )
import GHC.Core.Type
+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped )
import GHC.Core.FVs (mkRuleInfo)
import GHC.Builtin.PrimOps
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index 283f88a1c59..a44169329e1 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -42,6 +42,7 @@ import GHC.Core( IsOrphan, chooseOrphanAnchor )
import GHC.Core.Unify
import GHC.Core.Type as Type
import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Tidy
import GHC.Core.TyCo.Compare( eqType, eqTypes )
import GHC.Core.TyCon
import GHC.Core.Coercion
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 2dffc859a11..ee44c7e6afd 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -927,11 +927,8 @@ Here are the moving parts:
* That info is recorded in the `cir_is_coherent` field of `OneInst`, and thence
transferred to the `ep_is_coherent` field of the `EvBind` for the dictionary.
-* `GHC.HsToCore.Binds.dsHsWrapper` desugars the evidence application (f d) into
- (nospec f d) if `d` is incoherent. It has to do a dependency analysis to
- determine transitive dependencies, but we need to do that anyway.
- See Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds.
-
+* In the desugarer we exploit this info:
+ see Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr.
See also Note [nospecId magic] in GHC.Types.Id.Make.
-}
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index ad67f65832d..bd17b163cb9 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -65,7 +65,7 @@ import GHC.Types.Unique.Supply
import GHC.Core
import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec )
import GHC.Core.Type
-import GHC.Core.Predicate ( isCoVarType )
+import GHC.Core.Predicate ( scopedSort, isCoVarType )
import GHC.Core.TyCo.Compare ( eqType )
import GHC.Core.Coercion ( isCoVar )
import GHC.Core.DataCon ( DataCon, dataConWorkId, dataConWrapId )
diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs
index 74b6f3dfa58..2c004199beb 100644
--- a/compiler/GHC/Core/Opt/CSE.hs
+++ b/compiler/GHC/Core/Opt/CSE.hs
@@ -638,6 +638,9 @@ Notes:
doing this if there are no RULES; and other things being
equal it delays optimisation to delay inlining (#17409)
+* There can be a subtle order-dependency, as described in #25526;
+ it may matter whether we end up with f=g or g=f.
+
---- Historical note ---
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 6d828e40586..a13bfc091c5 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -1159,15 +1159,15 @@ simplExprF :: SimplEnv
-> SimplM (SimplFloats, OutExpr)
simplExprF !env e !cont -- See Note [Bangs in the Simplifier]
- = {- pprTrace "simplExprF" (vcat
- [ ppr e
- , text "cont =" <+> ppr cont
- , text "inscope =" <+> ppr (seInScope env)
- , text "tvsubst =" <+> ppr (seTvSubst env)
- , text "idsubst =" <+> ppr (seIdSubst env)
- , text "cvsubst =" <+> ppr (seCvSubst env)
- ]) $ -}
- simplExprF1 env e cont
+-- = pprTrace "simplExprF" (vcat
+-- [ ppr e
+-- , text "cont =" <+> ppr cont
+-- , text "inscope =" <+> ppr (seInScope env)
+-- , text "tvsubst =" <+> ppr (seTvSubst env)
+-- , text "idsubst =" <+> ppr (seIdSubst env)
+-- , text "cvsubst =" <+> ppr (seCvSubst env)
+-- ]) $
+ = simplExprF1 env e cont
simplExprF1 :: HasDebugCallStack
=> SimplEnv -> InExpr -> SimplCont
@@ -2514,7 +2514,7 @@ field of the ArgInfo record is the state of a little state-machine:
If we inline `f` before simplifying `BIG` well use preInlineUnconditionally,
and we'll simplify BIG once, at x's occurrence, rather than twice.
-* GHC.Core.Opt.Simplify.Utils. mkRewriteCall: if there are no rules, and no
+* GHC.Core.Opt.Simplify.Utils.mkRewriteCall: if there are no rules, and no
unfolding, we can skip both TryRules and TryInlining, which saves work.
Note [Avoid redundant simplification]
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index b217588fcd0..b637fa754da 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -361,11 +361,17 @@ data ArgSpec
-- Coercion is optimised
instance Outputable ArgInfo where
- ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })
+ ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rewrite = rewrite })
= text "ArgInfo" <+> braces
(sep [ text "fun =" <+> ppr fun
, text "dmds(first 10) =" <+> ppr (take 10 dmds)
- , text "args =" <+> ppr args ])
+ , text "args =" <+> ppr args
+ , text "rewrite =" <+> ppr rewrite ])
+
+instance Outputable RewriteCall where
+ ppr (TryRules ac _rules) = text "TryRules" <+> ppr ac
+ ppr TryInlining = text "TryInlining"
+ ppr TryNothing = text "TryNothing"
instance Outputable ArgSpec where
ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index bbc2f3c599f..d8073ee6ae5 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -35,7 +35,7 @@ import GHC.Core.DataCon
import GHC.Core.Class( classTyVars )
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.Rules
-import GHC.Core.Predicate ( typeDeterminesValue )
+import GHC.Core.Predicate ( scopedSort, typeDeterminesValue )
import GHC.Core.Type hiding ( substTy )
import GHC.Core.TyCon (TyCon, tyConName )
import GHC.Core.Multiplicity
diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs
index 4e2b3f76f36..b354260d23f 100644
--- a/compiler/GHC/Core/Predicate.hs
+++ b/compiler/GHC/Core/Predicate.hs
@@ -30,7 +30,11 @@ module GHC.Core.Predicate (
isIPPred_maybe,
-- Evidence variables
- DictId, isEvVar, isDictId
+ DictId, isEvVar, isDictId,
+
+ -- * Well-scoped free variables
+ scopedSort, tyCoVarsOfTypeWellScoped,
+ tyCoVarsOfTypesWellScoped
) where
@@ -39,9 +43,11 @@ import GHC.Prelude
import GHC.Core.Type
import GHC.Core.Class
import GHC.Core.TyCo.Compare( eqType )
+import GHC.Core.TyCo.FVs( tyCoVarsOfTypeList, tyCoVarsOfTypesList )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Var
+import GHC.Types.Var.Set
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Builtin.Names
@@ -248,6 +254,14 @@ see Note [Equality superclasses in quantified constraints]
in GHC.Tc.Solver.Dict.
-}
+isPredTy :: HasDebugCallStack => Type -> Bool
+-- Precondition: expects a type that classifies values
+-- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep
+-- Returns True for types of kind (CONSTRAINT _), False for ones of kind (TYPE _)
+isPredTy ty = case typeTypeOrConstraint ty of
+ TypeLike -> False
+ ConstraintLike -> True
+
-- | Does this type classify a core (unlifted) Coercion?
-- At either role nominal or representational
-- (t1 ~# t2) or (t1 ~R# t2)
@@ -492,3 +506,113 @@ isEvVar var = isEvVarType (varType var)
isDictId :: Id -> Bool
isDictId id = isDictTy (varType id)
+
+
+{- *********************************************************************
+* *
+ scopedSort
+
+ This function lives here becuase it uses isEvVar
+* *
+********************************************************************* -}
+
+{- Note [ScopedSort]
+~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()
+
+This function type is implicitly generalised over [a, b, k, k2]. These
+variables will be Specified; that is, they will be available for visible
+type application. This is because they are written in the type signature
+by the user.
+
+However, we must ask: what order will they appear in? In cases without
+dependency, this is easy: we just use the lexical left-to-right ordering
+of first occurrence. With dependency, we cannot get off the hook so
+easily.
+
+We thus state:
+
+ * These variables appear in the order as given by ScopedSort, where
+ the input to ScopedSort is the left-to-right order of first occurrence.
+
+Note that this applies only to *implicit* quantification, without a
+`forall`. If the user writes a `forall`, then we just use the order given.
+
+ScopedSort is defined thusly (as proposed in #15743):
+ * Work left-to-right through the input list, with a cursor.
+ * If variable v at the cursor is depended on by any earlier variable w,
+ move v immediately before the leftmost such w.
+
+INVARIANT: The prefix of variables before the cursor form a valid telescope.
+
+Note that ScopedSort makes sense only after type inference is done and all
+types/kinds are fully settled and zonked.
+
+-}
+
+-- | Do a topological sort on a list of tyvars,
+-- so that binders occur before occurrences
+-- E.g. given @[ a::k, k::Type, b::k ]@
+-- it'll return a well-scoped list @[ k::Type, a::k, b::k ]@.
+--
+-- This is a deterministic sorting operation
+-- (that is, doesn't depend on Uniques).
+--
+-- It is also meant to be stable: that is, variables should not
+-- be reordered unnecessarily. This is specified in Note [ScopedSort]
+-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"
+
+scopedSort :: [Var] -> [Var]
+scopedSort = go [] []
+ where
+ go :: [Var] -- already sorted, in reverse order
+ -> [TyCoVarSet] -- each set contains all the variables which must be placed
+ -- before the tv corresponding to the set; they are accumulations
+ -- of the fvs in the sorted Var's types
+
+ -- This list is in 1-to-1 correspondence with the sorted Vars
+ -- INVARIANT:
+ -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)
+ -- That is, each set in the list is a superset of all later sets.
+
+ -> [Var] -- yet to be sorted
+ -> [Var]
+ go acc _fv_list [] = reverse acc
+ go acc fv_list (tv:tvs)
+ = go acc' fv_list' tvs
+ where
+ (acc', fv_list') = insert tv acc fv_list
+
+ insert :: Var -- var to insert
+ -> [Var] -- sorted list, in reverse order
+ -> [TyCoVarSet] -- list of fvs, as above
+ -> ([Var], [TyCoVarSet]) -- augmented lists
+ -- Generally we put the new Var at the front of the accumulating list
+ -- (leading to a stable sort) unless there is are reason to put it later.
+ insert v [] [] = ([v], [tyCoVarsOfType (varType v)])
+ insert v (a:as) (fvs:fvss)
+ | (isTyVar v && isId a) || -- TyVars precede Ids
+ (isEvVar v && isId a && not (isEvVar a)) || -- DictIds precede non-DictIds
+ (v `elemVarSet` fvs)
+ -- (a) put Ids after TyVars, and (b) respect dependencies
+ , (as', fvss') <- insert v as fvss
+ = (a:as', fvs `unionVarSet` fv_v : fvss')
+
+ | otherwise -- Put `v` at the front
+ = (v:a:as, fvs `unionVarSet` fv_v : fvs : fvss)
+ where
+ fv_v = tyCoVarsOfType (varType v)
+
+ -- lists not in correspondence
+ insert _ _ _ = panic "scopedSort"
+
+-- | Get the free vars of a type in scoped order
+tyCoVarsOfTypeWellScoped :: Type -> [TyVar]
+tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList
+
+-- | Get the free vars of types in scoped order
+tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
+tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList
+
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 9efc3484658..93e45ce0362 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -8,7 +8,7 @@ module GHC.Core.SimpleOpt (
SimpleOpts (..), defaultSimpleOpts,
-- ** Simple expression optimiser
- simpleOptPgm, simpleOptExpr, simpleOptExprWith,
+ simpleOptPgm, simpleOptExpr, simpleOptExprNoInline, simpleOptExprWith,
-- ** Join points
joinPointBinding_maybe, joinPointBindings_maybe,
@@ -114,6 +114,8 @@ data SimpleOpts = SimpleOpts
{ so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
, so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
, so_eta_red :: !Bool -- ^ Eta reduction on?
+ , so_inline :: !Bool -- ^ False <=> do no inlining whatsoever,
+ -- even for trivial or used-once things
}
-- | Default options for the Simple optimiser.
@@ -122,6 +124,7 @@ defaultSimpleOpts = SimpleOpts
{ so_uf_opts = defaultUnfoldingOpts
, so_co_opts = OptCoercionOpts { optCoercionEnabled = False }
, so_eta_red = False
+ , so_inline = True
}
simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
@@ -159,6 +162,17 @@ simpleOptExpr opts expr
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
+simpleOptExprNoInline :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
+-- A variant of simpleOptExpr, but without
+-- occurrence analysis or inlining of any kind.
+-- Result: we don't inline evidence bindings, which is useful for the specialiser
+simpleOptExprNoInline opts expr
+ = simple_opt_expr init_env expr
+ where
+ init_opts = opts { so_inline = False }
+ init_env = (emptyEnv init_opts) { soe_subst = init_subst }
+ init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
+
simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
-- See Note [The simple optimiser]
simpleOptExprWith opts subst expr
@@ -468,7 +482,7 @@ simple_bind_pair :: SimpleOptEnv
-- (simple_bind_pair subst in_var out_rhs)
-- either extends subst with (in_var -> out_rhs)
-- or returns Nothing
-simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
+simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opts })
in_bndr mb_out_bndr clo@(rhs_env, in_rhs)
top_level
| Type ty <- in_rhs -- let a::* = TYPE ty in <body>
@@ -510,6 +524,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
pre_inline_unconditionally :: Bool
pre_inline_unconditionally
+ | not (so_inline opts) = False -- Not if so_inline is False
| isExportedId in_bndr = False
| stable_unf = False
| not active = False -- Note [Inline prag in simplOpt]
@@ -561,13 +576,14 @@ simple_out_bind_pair :: SimpleOptEnv
-> InId -> Maybe OutId -> OutExpr
-> OccInfo -> Bool -> Bool -> TopLevelFlag
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
-simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
+simple_out_bind_pair env@(SOE { soe_subst = subst, soe_opts = opts })
+ in_bndr mb_out_bndr out_rhs
occ_info active stable_unf top_level
| assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)
-- Type and coercion bindings are caught earlier
-- See Note [Core type and coercion invariant]
post_inline_unconditionally
- = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
+ = ( env' { soe_subst = extendIdSubst subst in_bndr out_rhs }
, Nothing)
| otherwise
@@ -580,6 +596,7 @@ simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
post_inline_unconditionally :: Bool
post_inline_unconditionally
+ | not (so_inline opts) = False -- Not if so_inline is False
| isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs]
| stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally]
| not active = False -- in GHC.Core.Opt.Simplify.Utils
@@ -852,7 +869,7 @@ too. Achieving all this is surprisingly tricky:
(MC1) We must compulsorily unfold MkAge to a cast.
See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make
-(MC2) We must compulsorily unfolding coerce on the rule LHS, yielding
+(MC2) We must compulsorily unfold coerce on the rule LHS, yielding
forall a b (dict :: Coercible * a b).
map @a @b (\(x :: a) -> case dict of
MkCoercible (co :: a ~R# b) -> x |> co) = ...
@@ -869,7 +886,6 @@ too. Achieving all this is surprisingly tricky:
Unfortunately, this still abstracts over a Coercible dictionary. We really
want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
which transforms the above to
- Desugar)
forall a b (co :: a ~R# b).
let dict = MkCoercible @* @a @b co in
@@ -894,7 +910,7 @@ too. Achieving all this is surprisingly tricky:
(MC4) The map/coerce rule is the only compelling reason for having a RULE that
quantifies over a coercion variable, something that is otherwise Very Deeply
- Suspicous. See Note [Casts in the template] in GHC.Core.Rules. Ugh!
+ Suspicious. See Note [Casts in the template] in GHC.Core.Rules. Ugh!
This is all a fair amount of special-purpose hackery, but it's for
a good cause. And it won't hurt other RULES and such that it comes across.
diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs
index de4fcbdc265..1e19467c0ea 100644
--- a/compiler/GHC/Core/Tidy.hs
+++ b/compiler/GHC/Core/Tidy.hs
@@ -16,12 +16,12 @@ import GHC.Prelude
import GHC.Core
import GHC.Core.Type
-
+import GHC.Core.TyCo.Tidy
import GHC.Core.Seq ( seqUnfolding )
+
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand ( zapDmdEnvSig, isStrUsedDmd )
-import GHC.Core.Coercion ( tidyCo )
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Unique (getUnique)
@@ -30,6 +30,7 @@ import GHC.Types.Name hiding (tidyNameOcc)
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Tickish
+
import GHC.Data.Maybe
import GHC.Utils.Misc
import Data.List (mapAccumL)
diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs
index 58a58fb454a..375fd712067 100644
--- a/compiler/GHC/Core/TyCo/FVs.hs
+++ b/compiler/GHC/Core/TyCo/FVs.hs
@@ -40,10 +40,6 @@ module GHC.Core.TyCo.FVs
-- * Occurrence-check expansion
occCheckExpand,
- -- * Well-scoped free variables
- scopedSort, tyCoVarsOfTypeWellScoped,
- tyCoVarsOfTypesWellScoped,
-
-- * Closing over kinds
closeOverKindsDSet, closeOverKindsList,
closeOverKinds,
@@ -72,7 +68,6 @@ import GHC.Types.Unique.Set
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Misc
-import GHC.Utils.Panic
import GHC.Data.Pair
import Data.Semigroup
@@ -989,107 +984,6 @@ noFreeVarsOfCo co = not $ DM.getAny (f co)
where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet
-{- *********************************************************************
-* *
- scopedSort
-* *
-********************************************************************* -}
-
-{- Note [ScopedSort]
-~~~~~~~~~~~~~~~~~~~~
-Consider
-
- foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()
-
-This function type is implicitly generalised over [a, b, k, k2]. These
-variables will be Specified; that is, they will be available for visible
-type application. This is because they are written in the type signature
-by the user.
-
-However, we must ask: what order will they appear in? In cases without
-dependency, this is easy: we just use the lexical left-to-right ordering
-of first occurrence. With dependency, we cannot get off the hook so
-easily.
-
-We thus state:
-
- * These variables appear in the order as given by ScopedSort, where
- the input to ScopedSort is the left-to-right order of first occurrence.
-
-Note that this applies only to *implicit* quantification, without a
-`forall`. If the user writes a `forall`, then we just use the order given.
-
-ScopedSort is defined thusly (as proposed in #15743):
- * Work left-to-right through the input list, with a cursor.
- * If variable v at the cursor is depended on by any earlier variable w,
- move v immediately before the leftmost such w.
-
-INVARIANT: The prefix of variables before the cursor form a valid telescope.
-
-Note that ScopedSort makes sense only after type inference is done and all
-types/kinds are fully settled and zonked.
-
--}
-
--- | Do a topological sort on a list of tyvars,
--- so that binders occur before occurrences
--- E.g. given [ a::k, k::*, b::k ]
--- it'll return a well-scoped list [ k::*, a::k, b::k ]
---
--- This is a deterministic sorting operation
--- (that is, doesn't depend on Uniques).
---
--- It is also meant to be stable: that is, variables should not
--- be reordered unnecessarily. This is specified in Note [ScopedSort]
--- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"
-
-scopedSort :: [TyCoVar] -> [TyCoVar]
-scopedSort = go [] []
- where
- go :: [TyCoVar] -- already sorted, in reverse order
- -> [TyCoVarSet] -- each set contains all the variables which must be placed
- -- before the tv corresponding to the set; they are accumulations
- -- of the fvs in the sorted tvs' kinds
-
- -- This list is in 1-to-1 correspondence with the sorted tyvars
- -- INVARIANT:
- -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)
- -- That is, each set in the list is a superset of all later sets.
-
- -> [TyCoVar] -- yet to be sorted
- -> [TyCoVar]
- go acc _fv_list [] = reverse acc
- go acc fv_list (tv:tvs)
- = go acc' fv_list' tvs
- where
- (acc', fv_list') = insert tv acc fv_list
-
- insert :: TyCoVar -- var to insert
- -> [TyCoVar] -- sorted list, in reverse order
- -> [TyCoVarSet] -- list of fvs, as above
- -> ([TyCoVar], [TyCoVarSet]) -- augmented lists
- insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)])
- insert tv (a:as) (fvs:fvss)
- | tv `elemVarSet` fvs
- , (as', fvss') <- insert tv as fvss
- = (a:as', fvs `unionVarSet` fv_tv : fvss')
-
- | otherwise
- = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)
- where
- fv_tv = tyCoVarsOfType (tyVarKind tv)
-
- -- lists not in correspondence
- insert _ _ _ = panic "scopedSort"
-
--- | Get the free vars of a type in scoped order
-tyCoVarsOfTypeWellScoped :: Type -> [TyVar]
-tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList
-
--- | Get the free vars of types in scoped order
-tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
-tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList
-
{-
************************************************************************
* *
diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs
index 137f7406163..b5fda91c203 100644
--- a/compiler/GHC/Core/TyCo/Ppr.hs
+++ b/compiler/GHC/Core/TyCo/Ppr.hs
@@ -41,8 +41,11 @@ import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Tidy
import GHC.Core.TyCo.FVs
import GHC.Core.Class
-import GHC.Types.Var
+import GHC.Core.Predicate( scopedSort )
import GHC.Core.Multiplicity( pprArrowWithMultiplicity )
+
+import GHC.Types.Var
+
import GHC.Iface.Type
import GHC.Types.Var.Set
diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs
index f5eb845a7ed..69c460965b9 100644
--- a/compiler/GHC/Core/TyCo/Tidy.hs
+++ b/compiler/GHC/Core/TyCo/Tidy.hs
@@ -19,6 +19,7 @@ module GHC.Core.TyCo.Tidy
import GHC.Prelude
import GHC.Data.FastString
+import GHC.Core.Predicate( scopedSort )
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.FVs
import GHC.Types.Name hiding (varName)
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index dd6b2a09d71..a2be9f39629 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -69,8 +69,6 @@ module GHC.Core.Type (
mkCharLitTy, isCharLitTy,
isLitTy,
- isPredTy,
-
getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep,
getLevity, levityType_maybe,
@@ -177,10 +175,6 @@ module GHC.Core.Type (
closeOverKindsDSet, closeOverKindsList,
closeOverKinds,
- -- * Well-scoped lists of variables
- scopedSort, tyCoVarsOfTypeWellScoped,
- tyCoVarsOfTypesWellScoped,
-
-- * Forcing evaluation of types
seqType, seqTypes,
@@ -222,17 +216,6 @@ module GHC.Core.Type (
substTyCoBndr, substTyVarToTyVar,
cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,
- -- * Tidying type related things up for printing
- tidyType, tidyTypes,
- tidyOpenType, tidyOpenTypes,
- tidyOpenTypeX, tidyOpenTypesX,
- tidyVarBndr, tidyVarBndrs,
- tidyFreeTyCoVars,
- tidyFreeTyCoVarX, tidyFreeTyCoVarsX,
- tidyTyCoVarOcc,
- tidyTopType,
- tidyForAllTyBinder, tidyForAllTyBinders,
-
-- * Kinds
isTYPEorCONSTRAINT,
isConcreteType,
@@ -248,7 +231,6 @@ import GHC.Types.Basic
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst
-import GHC.Core.TyCo.Tidy
import GHC.Core.TyCo.FVs
-- friends:
@@ -2760,14 +2742,6 @@ typeTypeOrConstraint ty
| otherwise
-> pprPanic "typeOrConstraint" (ppr ty <+> dcolon <+> ppr (typeKind ty))
-isPredTy :: HasDebugCallStack => Type -> Bool
--- Precondition: expects a type that classifies values
--- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep
--- Returns True for types of kind (CONSTRAINT _), False for ones of kind (TYPE _)
-isPredTy ty = case typeTypeOrConstraint ty of
- TypeLike -> False
- ConstraintLike -> True
-
-- | Does this classify a type allowed to have values? Responds True to things
-- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint.
isTYPEorCONSTRAINT :: Kind -> Bool
diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot
index b4cf5d8a222..fef4308ac4c 100644
--- a/compiler/GHC/Core/Type.hs-boot
+++ b/compiler/GHC/Core/Type.hs-boot
@@ -9,31 +9,18 @@ import GHC.Utils.Misc
import GHC.Types.Var( FunTyFlag, TyVar )
import GHC.Types.Basic( TypeOrConstraint )
-isPredTy :: HasDebugCallStack => Type -> Bool
-isCoercionTy :: Type -> Bool
-mkAppTy :: Type -> Type -> Type
-mkCastTy :: Type -> Coercion -> Type
-mkTyConApp :: TyCon -> [Type] -> Type
-mkCoercionTy :: Coercion -> Type
-piResultTy :: HasDebugCallStack => Type -> Type -> Type
-
-typeKind :: HasDebugCallStack => Type -> Type
-typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint
-
-coreView :: Type -> Maybe Type
-rewriterView :: Type -> Maybe Type
-isRuntimeRepTy :: Type -> Bool
-isLevityTy :: Type -> Bool
-isMultiplicityTy :: Type -> Bool
+coreView :: Type -> Maybe Type
+rewriterView :: Type -> Maybe Type
+chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag
+typeKind :: HasDebugCallStack => Type -> Type
+isCoercionTy :: Type -> Bool
+mkAppTy :: Type -> Type -> Type
+mkCastTy :: Type -> Coercion -> Type
+mkTyConApp :: TyCon -> [Type] -> Type
+getLevity :: HasDebugCallStack => Type -> Type
+getTyVar_maybe :: Type -> Maybe TyVar
isLiftedTypeKind :: Type -> Bool
-splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
-tyConAppTyCon_maybe :: Type -> Maybe TyCon
-getTyVar_maybe :: Type -> Maybe TyVar
-
-getLevity :: HasDebugCallStack => Type -> Type
-
partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])
-
-chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag
+typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index 5b2c3ec2e3f..58664a5ebfd 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -34,6 +34,7 @@ import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName )
import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )
import GHC.Core.Type hiding ( getTvSubstEnv )
import GHC.Core.Coercion hiding ( getCvSubstEnv )
+import GHC.Core.Predicate( scopedSort )
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare ( eqType, tcEqType )
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 32a8af16c88..f6d0bad23d8 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -63,7 +63,7 @@ import GHC.Core.Multiplicity
import GHC.Core.PatSyn
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Compare( eqType )
-import GHC.Core.TyCo.Tidy ( tidyCo )
+import GHC.Core.TyCo.Tidy
import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon )
import GHC.Builtin.Types ( heqTyCon )
diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs
index 642cc01d5cb..4537e4c2d2d 100644
--- a/compiler/GHC/Driver/Config.hs
+++ b/compiler/GHC/Driver/Config.hs
@@ -25,6 +25,7 @@ initSimpleOpts dflags = SimpleOpts
{ so_uf_opts = unfoldingOpts dflags
, so_co_opts = initOptCoercionOpts dflags
, so_eta_red = gopt Opt_DoEtaReduction dflags
+ , so_inline = True
}
-- | Extract GHCi options from DynFlags and step
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index c776e7058ad..5de4e975cfd 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -1081,6 +1081,8 @@ data WarningFlag =
| Opt_WarnDataKindsTC -- Since 9.10
| Opt_WarnDefaultedExceptionContext -- Since 9.10
| Opt_WarnViewPatternSignatures -- Since 9.12
+ | Opt_WarnUselessSpecialisations -- Since 9.14
+ | Opt_WarnDeprecatedPragmas -- Since 9.14
deriving (Eq, Ord, Show, Enum, Bounded)
-- | Return the names of a WarningFlag
@@ -1197,6 +1199,8 @@ warnFlagNames wflag = case wflag of
Opt_WarnDataKindsTC -> "data-kinds-tc" :| []
Opt_WarnDefaultedExceptionContext -> "defaulted-exception-context" :| []
Opt_WarnViewPatternSignatures -> "view-pattern-signatures" :| []
+ Opt_WarnUselessSpecialisations -> "useless-specialisations" :| ["useless-specializations"]
+ Opt_WarnDeprecatedPragmas -> "deprecated-pragmas" :| []
-- -----------------------------------------------------------------------------
-- Standard sets of warning options
@@ -1338,7 +1342,9 @@ standardWarnings -- see Note [Documenting warning flags]
Opt_WarnInconsistentFlags,
Opt_WarnDataKindsTC,
Opt_WarnTypeEqualityOutOfScope,
- Opt_WarnViewPatternSignatures
+ Opt_WarnViewPatternSignatures,
+ Opt_WarnUselessSpecialisations,
+ Opt_WarnDeprecatedPragmas
]
-- | Things you get with -W
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 86b8286edbf..2944c166d69 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2358,6 +2358,8 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
Opt_WarnDataKindsTC -> warnSpec x
Opt_WarnDefaultedExceptionContext -> warnSpec x
Opt_WarnViewPatternSignatures -> warnSpec x
+ Opt_WarnUselessSpecialisations -> warnSpec x
+ Opt_WarnDeprecatedPragmas -> warnSpec x
warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
warningGroupsDeps = map mk warningGroups
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index f130b970c72..71f22be4d1d 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -26,14 +26,16 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
module GHC.Hs.Binds
( module Language.Haskell.Syntax.Binds
, module GHC.Hs.Binds
+ , HsRuleBndrsAnn(..)
) where
import GHC.Prelude
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Binds
+import Language.Haskell.Syntax.Expr( LHsExpr )
-import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind )
+import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind )
import {-# SOURCE #-} GHC.Hs.Pat (pprLPat )
import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )
@@ -724,6 +726,11 @@ type instance XSpecInstSig (GhcPass p) = ((EpaLocation, EpToken "instance",
type instance XMinimalSig (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText)
type instance XSCCFunSig (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText)
type instance XCompleteMatchSig (GhcPass p) = ((EpaLocation, Maybe TokDcolon, EpToken "#-}"), SourceText)
+
+type instance XSpecSigE GhcPs = AnnSpecSig
+type instance XSpecSigE GhcRn = Name
+type instance XSpecSigE GhcTc = NoExtField
+
-- SourceText: See Note [Pragma source text] in "GHC.Types.SourceText"
type instance XXSig GhcPs = DataConCantHappen
type instance XXSig GhcRn = IdSig
@@ -738,7 +745,7 @@ data AnnSpecSig
= AnnSpecSig {
ass_open :: EpaLocation,
ass_close :: EpToken "#-}",
- ass_dcolon :: TokDcolon,
+ ass_dcolon :: Maybe TokDcolon,
ass_act :: ActivationAnn
} deriving Data
@@ -817,25 +824,47 @@ instance NoAnn AnnSig where
-- | Type checker Specialisation Pragmas
--
--- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
+-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker
+-- to the desugarer
data TcSpecPrags
= IsDefaultMethod -- ^ Super-specialised: a default method should
-- be macro-expanded at every call site
| SpecPrags [LTcSpecPrag]
- deriving Data
--- | Located Type checker Specification Pragmas
+-- | Located Type checker Specialisation Pragmas
type LTcSpecPrag = Located TcSpecPrag
--- | Type checker Specification Pragma
+-- | Type checker Specialisation Pragma
+--
+-- This data type is used to communicate between the typechecker and
+-- the desugarer.
data TcSpecPrag
+ -- | Old-form specialise pragma
= SpecPrag
- Id
- HsWrapper
- InlinePragma
- -- ^ The Id to be specialised, a wrapper that specialises the
- -- polymorphic function, and inlining spec for the specialised function
- deriving Data
+ Id
+ -- ^ 'Id' to be specialised
+ HsWrapper
+ -- ^ wrapper that specialises the polymorphic function
+ InlinePragma
+ -- ^ inlining spec for the specialised function
+ -- | New-form specialise pragma
+ | SpecPragE
+ { spe_fn_nm :: Name
+ -- ^ 'Name' of the 'Id' being specialised
+ , spe_fn_id :: Id
+ -- ^ 'Id' being specialised
+ --
+ -- Note that 'spe_fn_nm' may differ from @'idName' 'spe_fn_id'@
+ -- in the case of instance methods, where the 'Name' is the
+ -- class-op selector but the 'spe_fn_id' is that for the local method
+ , spe_inl :: InlinePragma
+ -- ^ (optional) INLINE annotation and activation phase annotation
+
+ , spe_bndrs :: [Var]
+ -- ^ TyVars, EvVars, and Ids
+ , spe_call :: LHsExpr GhcTc
+ -- ^ The type-checked specialise expression
+ }
noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []
@@ -858,19 +887,34 @@ ppr_sig (ClassOpSig _ is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
| otherwise = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (FixSig _ fix_sig) = ppr fix_sig
-ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
- = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)
- (interpp'SP ty) inl)
+
+ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_src = src, inl_inline = spec }))
+ = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $
+ pprSpec (unLoc var) (interpp'SP ty) inl
where
pragmaSrc = case spec of
- NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl)
- _ -> "{-# " ++ extractSpecPragName (inl_src inl) ++ "_INLINE"
+ NoUserInlinePrag -> "{-# " ++ extractSpecPragName src
+ _ -> "{-# " ++ extractSpecPragName src ++ "_INLINE"
+
+ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec }))
+ = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $
+ pp_inl <+> hang (ppr bndrs) 2 (pprLExpr spec_e)
+ where
+ -- SPECIALISE or SPECIALISE_INLINE
+ pragmaSrc = case spec of
+ NoUserInlinePrag -> "{-# " ++ extractSpecPragName src
+ _ -> "{-# " ++ extractSpecPragName src ++ "_INLINE"
+
+ pp_inl | isDefaultInlinePragma inl = empty
+ | otherwise = pprInline inl
+
ppr_sig (InlineSig _ var inl)
= ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}"
where
ppr_pfx = case inlinePragmaSource inl of
SourceText src -> ftext src
NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl)
+
ppr_sig (SpecInstSig (_, src) ty)
= pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)
ppr_sig (MinimalSig (_, src) bf)
@@ -905,6 +949,7 @@ hsSigDoc (ClassOpSig _ is_deflt _ _)
| is_deflt = text "default type signature"
| otherwise = text "class method signature"
hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"
+hsSigDoc (SpecSigE _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"
hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma"
-- Using the 'inlinePragmaName' function ensures that the pragma name for any
-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted
@@ -967,10 +1012,58 @@ pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl)
= text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
+ ppr (SpecPragE { spe_bndrs = bndrs, spe_call = spec_e, spe_inl = inl })
+ = text (extractSpecPragName $ inl_src inl)
+ <+> hang (ppr bndrs) 2 (pprLExpr spec_e)
pprMinimalSig :: OutputableBndrId p => LBooleanFormula (GhcPass p) -> SDoc
pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf
+
+{- *********************************************************************
+* *
+ RuleBndrs
+* *
+********************************************************************* -}
+
+data HsRuleBndrsAnn
+ = HsRuleBndrsAnn
+ { rb_tyanns :: Maybe (TokForall, EpToken ".")
+ -- ^ The locations of 'forall' and '.' for forall'd type vars
+ -- Using AddEpAnn to capture possible unicode variants
+ , rb_tmanns :: Maybe (TokForall, EpToken ".")
+ -- ^ The locations of 'forall' and '.' for forall'd term vars
+ -- Using AddEpAnn to capture possible unicode variants
+ } deriving (Data, Eq)
+
+instance NoAnn HsRuleBndrsAnn where
+ noAnn = HsRuleBndrsAnn Nothing Nothing
+
+
+
+type instance XXRuleBndrs (GhcPass _) = DataConCantHappen
+type instance XCRuleBndrs GhcPs = HsRuleBndrsAnn
+type instance XCRuleBndrs GhcRn = NoExtField
+type instance XCRuleBndrs GhcTc = [Var] -- Binders of the rule, not
+ -- necessarily in dependency order
+
+type instance XRuleBndrSig (GhcPass _) = AnnTyVarBndr
+type instance XCRuleBndr (GhcPass _) = AnnTyVarBndr
+type instance XXRuleBndr (GhcPass _) = DataConCantHappen
+
+instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where
+ ppr (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs })
+ = pp_forall_ty tyvs <+> pp_forall_tm tyvs
+ where
+ pp_forall_ty Nothing = empty
+ pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
+ pp_forall_tm Nothing | null tmvs = empty
+ pp_forall_tm _ = forAllLit <+> fsep (map ppr tmvs) <> dot
+
+instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
+ ppr (RuleBndr _ name) = ppr name
+ ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
+
{-
************************************************************************
* *
@@ -982,6 +1075,7 @@ pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf
type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA
type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA
type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA
+type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO
type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index b5576851722..76dcc941642 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -67,7 +67,7 @@ module GHC.Hs.Decls (
XViaStrategyPs(..),
-- ** @RULE@ declarations
LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
- HsRuleAnn(..), ActivationAnn(..),
+ HsRuleAnn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
@@ -1317,15 +1317,13 @@ type instance XCRuleDecls GhcTc = SourceText
type instance XXRuleDecls (GhcPass _) = DataConCantHappen
-type instance XHsRule GhcPs = (HsRuleAnn, SourceText)
+type instance XHsRule GhcPs = ((ActivationAnn, EpToken "="), SourceText)
type instance XHsRule GhcRn = (HsRuleRn, SourceText)
type instance XHsRule GhcTc = (HsRuleRn, SourceText)
data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
deriving Data
-type instance XXRuleDecl (GhcPass _) = DataConCantHappen
-
data HsRuleAnn
= HsRuleAnn
{ ra_tyanns :: Maybe (TokForall, EpToken ".")
@@ -1337,13 +1335,11 @@ data HsRuleAnn
instance NoAnn HsRuleAnn where
noAnn = HsRuleAnn Nothing Nothing noAnn noAnn
+type instance XXRuleDecl (GhcPass _) = DataConCantHappen
+
flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
-type instance XCRuleBndr (GhcPass _) = AnnTyVarBndr
-type instance XRuleBndrSig (GhcPass _) = AnnTyVarBndr
-type instance XXRuleBndr (GhcPass _) = DataConCantHappen
-
instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where
ppr (HsRules { rds_ext = ext
, rds_rules = rules })
@@ -1358,28 +1354,18 @@ instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
ppr (HsRule { rd_ext = ext
, rd_name = name
, rd_act = act
- , rd_tyvs = tys
- , rd_tmvs = tms
+ , rd_bndrs = bndrs
, rd_lhs = lhs
, rd_rhs = rhs })
= sep [pprFullRuleName st name <+> ppr act,
- nest 4 (pp_forall_ty tys <+> pp_forall_tm tys
- <+> pprExpr (unLoc lhs)),
+ nest 4 (ppr bndrs <+> pprExpr (unLoc lhs)),
nest 6 (equals <+> pprExpr (unLoc rhs)) ]
where
- pp_forall_ty Nothing = empty
- pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
- pp_forall_tm Nothing | null tms = empty
- pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
st = case ghcPass @p of
GhcPs | (_, st) <- ext -> st
GhcRn | (_, st) <- ext -> st
GhcTc | (_, st) <- ext -> st
-instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
- ppr (RuleBndr _ name) = ppr name
- ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
-
pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc
pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n)
@@ -1509,7 +1495,6 @@ type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA
type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (SourceText, RuleName) = EpAnnCO
-type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO
type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA
type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 6801211edd7..a77cc738740 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -261,6 +261,13 @@ deriving instance Data (RuleBndr GhcPs)
deriving instance Data (RuleBndr GhcRn)
deriving instance Data (RuleBndr GhcTc)
+deriving instance Data (RuleBndrs GhcPs)
+deriving instance Data (RuleBndrs GhcRn)
+deriving instance Data (RuleBndrs GhcTc)
+
+deriving instance Data TcSpecPrags
+deriving instance Data TcSpecPrag
+
-- deriving instance (DataId p) => Data (WarnDecls p)
deriving instance Data (WarnDecls GhcPs)
deriving instance Data (WarnDecls GhcRn)
diff --git a/compiler/GHC/Hs/Stats.hs b/compiler/GHC/Hs/Stats.hs
index ead9fa6e04b..9d0d3ea5ba0 100644
--- a/compiler/GHC/Hs/Stats.hs
+++ b/compiler/GHC/Hs/Stats.hs
@@ -115,6 +115,7 @@ ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = impor
sig_info (FixSig {}) = (1,0,0,0,0)
sig_info (TypeSig {}) = (0,1,0,0,0)
sig_info (SpecSig {}) = (0,0,1,0,0)
+ sig_info (SpecSigE {}) = (0,0,1,0,0)
sig_info (InlineSig {}) = (0,0,0,1,0)
sig_info (ClassOpSig {}) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 4b0cfea3981..74ad71b764b 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -52,7 +52,7 @@ import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
import GHC.Core.Utils
import GHC.Core.Unfold.Make
import GHC.Core.Coercion
-import GHC.Core.Predicate( mkNomEqPred )
+import GHC.Core.Predicate( scopedSort, mkNomEqPred )
import GHC.Core.DataCon ( dataConWrapId )
import GHC.Core.Make
import GHC.Core.Rules
@@ -69,7 +69,7 @@ import GHC.Data.SizedSeq ( sizeSS )
import GHC.Utils.Error
import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
+import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Logger
@@ -277,12 +277,6 @@ deSugar hsc_env
; return (msgs, Just mod_guts)
}}}}
-dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
-dsImpSpecs imp_specs
- = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
- ; let (spec_binds, spec_rules) = unzip spec_prs
- ; return (concatOL spec_binds, spec_rules) }
-
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
@@ -427,11 +421,14 @@ Reason
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule { rd_name = name
, rd_act = rule_act
- , rd_tmvs = vars
+ , rd_bndrs = RuleBndrs { rb_ext = bndrs }
, rd_lhs = lhs
, rd_rhs = rhs }))
= putSrcSpanDs (locA loc) $
- do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
+ do { let bndrs' = scopedSort bndrs
+ -- The scopedSort is because the binders may not
+ -- be in dependency order; see wrinkle (FTV1) in
+ -- Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 3c1c40878b9..2e025ddf96e 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-
@@ -15,7 +16,8 @@ lower levels it is preserved with @let@/@letrec@s).
-}
module GHC.HsToCore.Binds
- ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
+ ( dsTopLHsBinds, dsLHsBinds
+ , dsImpSpecs, decomposeRuleLhs
, dsHsWrapper, dsHsWrappers
, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
, dsWarnOrphanRule
@@ -42,7 +44,7 @@ import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
import GHC.Hs -- lots of things
import GHC.Core -- lots of things
-import GHC.Core.SimpleOpt ( simpleOptExpr )
+import GHC.Core.SimpleOpt
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Core.InstEnv ( CanonicalEvidence(..) )
import GHC.Core.Make
@@ -63,6 +65,7 @@ import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
import GHC.Tc.Types.Evidence
import GHC.Types.Id
+import GHC.Types.Id.Info (IdDetails(..))
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Var.Env
@@ -75,7 +78,6 @@ import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.Graph.Directed
import GHC.Data.Bag
-import qualified Data.Set as S
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
@@ -85,6 +87,7 @@ import GHC.Utils.Panic
import Control.Monad
+
{-**********************************************************************
* *
Desugaring a MonoBinds
@@ -786,6 +789,214 @@ The restrictions are:
4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
+Note [Desugaring new-form SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+"New-form" SPECIALISE pragmas generate a SpecPragE record in the typechecker,
+which is desugared in this module by `dsSpec`. For the context see
+Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
+
+Suppose we have f :: forall p q. (Ord p, Eq q) => p -> q -> q, and a pragma
+
+ {-# SPECIALISE forall x. f @[a] @[Int] x [3,4] #-}
+
+In `dsSpec` the `SpecPragE` will look something like this:
+
+ SpecPragE { spe_fn_id = f
+ , spe_bndrs = @a (d:Ord a) (x:[a])
+ , spe_call = let d2:Ord [a] = $dfOrdList d
+ d3:Eq [Int] = $dfEqList $dfEqInt
+ in f @[a] @[Int] d2 d3 x [3,4] }
+We want to get
+
+ RULE forall a (d2:Ord a) (d3:Eq [Int]) (x:[a]).
+ f @[a] @[Int] d2 d3 x [3,4] = $sf d2 x
+
+ $sf :: forall a. Ord [a] => a -> Int
+ $sf = /\a. \d2 x.
+ let d3 = $dfEqList $dfEqInt
+ in <f-rhs> @[a] @[Int] d2 d3 x [3,4]
+
+Notice that
+
+(SP1) If the expression in the SPECIALISE pragma had a type signature, such as
+ SPECIALISE f :: Eq b => Int -> b -> b
+ then the desugared expression may have type abstractions and applications
+ "in the way", like this:
+ (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b)
+ The lambdas come from the type signature, which is then re-instantiated,
+ hence the applications of those lambdas.
+
+ We use the simple optimiser to simplify this to
+ let { d = d2; d1 = $dfOrdInt } in f @Int @b (d2:Eq b)
+
+ Important: do no inlining in this "simple optimiser" phase:
+ use `simpleOptExprNoInline`. E.g. we don't want to turn
+ let { d1=d; d2=d } in f d1 d2 --> f d d
+ because the latter is harder to match.
+
+(SP2) $sf does not simply quantify over (d:Ord a). Instead, to figure out what
+ it should quantify over, and to include the 'd3' binding in the body of $sf,
+ we use the function `prepareSpecLHS`. It takes the simplified LHS `core_call`,
+ and uses the dictionary bindings to figure out the RULE LHS and RHS.
+
+ This is described in Note [prepareSpecLHS].
+
+Note [prepareSpecLHS]
+~~~~~~~~~~~~~~~~~~~~~
+To compute the appropriate RULE LHS and RHS for a new-form specialise pragma,
+as described in Note [Desugaring new-form SPECIALISE pragmas], we use a function
+called prepareSpecLHS.
+It takes as input a list of (type and evidence) binders, and a Core expression.
+For example, suppose its input is of the following form:
+
+ spe_bndrs = @a (d:Ord a)
+ spe_call =
+ let
+ -- call these bindings the call_binds
+ d1 :: Num Int
+ d1 = $dfNumInt
+ d2 :: Ord [a]
+ d2 = $dfOrdList d
+ d3 :: Eq a
+ d3 = $p1Ord d3
+ d4 :: Ord (F a)
+ d4 = d |> co1
+ d5 :: Ord (G a)
+ d5 = d4 |> co2
+ in
+ f @[a] @Int d1 d2 d3 d5
+
+The goal of prepareSpecLHS is then to generate the following two things:
+
+ - A specialisation, of the form:
+
+ $sf <spec_args> =
+ let <spec_binds>
+ in <f-rhs> @[a] @Int d1 d2 d3 d5
+
+ - A rule, of the form:
+
+ RULE forall a d1 d2 d3 d5. f @[a] @Int d1 d2 d3 d5 =
+ let <rule_binds>
+ in $sf <spec_args>
+
+That is, we must compute 'spec_args', 'rule_binds' and 'spec_binds'. A first
+approach might be:
+
+ - take spec_args = spe_bndrs,
+ - spec_binds = call_binds.
+
+If we did so, the RULE would look like:
+
+ RULE forall a d1 d2 d3 d5. f @[a] @Int d1 d2 d3 d5 =
+ let d = <???>
+ in $sf @a d
+
+The problem is: how do we recover 'd' from 'd1', 'd2', 'd3', 'd5'? Essentially,
+we need to run call_binds in reverse. In this example, we had:
+
+ d1 :: Num Int
+ d1 = $dfNumInt
+ d2 :: Ord [a]
+ d2 = $dfOrdList d
+ d3 :: Eq a
+ d3 = $p1Ord d3
+ d4 :: Ord (F a)
+ d4 = d |> co1
+ d5 :: Ord (G a)
+ d5 = d4 |> co2
+
+Let's try to recover (d: Ord a) from 'd1', 'd2', 'd4', 'd5':
+
+ - d1 is a constant binding, so it doesn't help us.
+ - d2 uses a top-level instance, which we can't run in reverse; we can't
+ obtain Ord a from Ord [a].
+ - d3 uses a superclass selector which prevents us from making progress.
+ - d5 is defined using d4, and both involve a cast.
+ In theory we could define d = d5 |> sym (co1 ; co2), but this gets
+ pretty complicated.
+
+This demonstrates the following:
+
+ 1. The bindings can't necessarily be "run in reverse".
+ 2. Even if the bindings theoretically can be "run in reverse", it is not
+ straightforward to do so.
+
+Now, we could strive to make the let-bindings reversible. We already do this
+to some extent for quantified constraints, as explained in
+Note [Fully solving constraints for specialisation] in GHC.Tc.Gen.Sig,
+using the TcSSpecPrag solver mode described in Note [TcSSpecPrag] in GHC.Tc.Solver.Monad.
+However, given (2), we don't bother ensuring that e.g. we don't use top-level
+class instances like in d2 above. Instead, we handle these bindings in
+prepareSpecLHS as follows:
+
+ (a) Go through the bindings in order.
+
+ (1) Bindings like
+ d1 = $dfNumInt
+ depend only on constants and move to the specialised function body.
+ That is crucial -- it makes those specialised methods available in the
+ specialised body. These are the `spec_const_binds`.
+
+ Note that these binds /can/ depend on locally-quantified /type/ variables.
+ For example, if we have
+ instance Monad (ST s) where ...
+ then the dictionary for (Monad (ST s)) is effectively a constant dictionary.
+ This is important to get specialisation for such types. Example in test T8331.
+
+ (2) Other bindings, like
+ d2:Ord [a] = $dfOrdList d
+ d3 = d
+ depend on a locally-quantifed evidence variable `d`.
+ Surprisingly, /we want to drop these bindings entirely!/
+ This is because, as explained above, it is too difficult to run these
+ in reverse. Instead, we drop them, and re-compute which dictionaries
+ we will quantify over.
+
+ (3) Finally, inside those dictionary bindings we should find the call of the
+ function itself
+ f @[a] @[Int] d2 d3 x [3,4]
+ 'prepareSpecLHS' takes the call apart and returns its arguments.
+
+ (b) Now, (a)(2) means that the RULE does not quantify over 'd' any more; it
+ quantifies over 'd1' 'd2' 'd3' 'd5'. So we recompute the `rule_bndrs`
+ from scratch.
+
+ Moreover, the specialised function also no longer quantifies over 'd',
+ it quantifies over 'd2' 'd3' 'd5'. This set of binders is computed by
+ taking the RULE binders and subtracting off the binders from
+ the `spec_const_binds`.
+
+[Shortcoming] This whole approach does have one downside, compared to running
+the let-bindings in reverse: it doesn't allow us to common-up dictionaries.
+Consider for example:
+
+ g :: forall a b. ( Eq a, Ord b ) => a -> b -> Bool
+ {-# SPECIALISE g :: forall c. Ord c => c -> c -> Bool #-}
+
+The input to prepareSpecLHS will be (more or less):
+
+ spe_bndrs: @c (d:Ord c)
+ spe_call =
+ let
+ d1 :: Eq c
+ d1 = $p1Ord d
+ d2 :: Ord c
+ d2 = d
+ in
+ g @c @c d1 d2
+
+The approach described in (2) will thus lead us to generate:
+
+ RULE g @c @c d1 d2 = $sg @c d1 d2
+ $sg @c d1 d2 = <g-rhs> @c @c d1 d2
+
+when we would rather avoid passing both dictionaries, and instead generate:
+
+ RULE g @c @c d1 d2 = let { d = d2 } in $sg @c d
+ $sg @c d = let { d1 = $p1Ord d; d2 = d } in <g-rhs> @c @c d1 d2
+
+For now, we accept this infelicity.
-}
------------------------
@@ -793,117 +1004,268 @@ dsSpecs :: CoreExpr -- Its rhs
-> TcSpecPrags
-> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
, [CoreRule] ) -- Rules for the Global Ids
--- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind
+-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
- = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+ = do { pairs <- mapMaybeM (dsLSpec poly_rhs) sps
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
-dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
- -- Nothing => RULE is for an imported Id
- -- rhs is in the Id's unfolding
- -> Located TcSpecPrag
+dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
+dsImpSpecs imp_specs
+ = do { spec_prs <- mapMaybeM spec_one imp_specs
+ ; let (spec_binds, spec_rules) = unzip spec_prs
+ ; return (concatOL spec_binds, spec_rules) }
+ where
+ spec_one (L loc prag) = putSrcSpanDs loc $
+ dsSpec (get_rhs prag) prag
+
+ get_rhs (SpecPrag poly_id _ _) = get_rhs1 poly_id
+ get_rhs (SpecPragE { spe_fn_id = poly_id }) = get_rhs1 poly_id
+
+ get_rhs1 poly_id
+ | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+ = unfolding -- Imported Id; this is its unfolding
+ -- Use realIdUnfolding so we get the unfolding
+ -- even when it is a loop breaker.
+ -- We want to specialise recursive functions!
+ | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+ -- The type checker has checked that it *has* an unfolding
+
+dsLSpec :: CoreExpr -> Located TcSpecPrag
+ -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+dsLSpec poly_rhs (L loc prag)
+ = putSrcSpanDs loc $ dsSpec poly_rhs prag
+
+dsSpec :: CoreExpr -- RHS to be specialised
+ -> TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
- | isJust (isClassOpId_maybe poly_id)
- = putSrcSpanDs loc $
- do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
- ; return Nothing } -- There is no point in trying to specialise a class op
- -- Moreover, classops don't (currently) have an inl_sat arity set
- -- (it would be Just 0) and that in turn makes makeCorePair bleat
-
- | no_act_spec && isNeverActive rule_act
- = putSrcSpanDs loc $
- do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
- ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that
- -- See Note [Activation pragmas for SPECIALISE]
-
- | otherwise
- = putSrcSpanDs loc $
- do { uniq <- newUnique
- ; let poly_name = idName poly_id
- spec_occ = mkSpecOcc (getOccName poly_name)
- spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
- (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
+dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)
+ -- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
+ | (spec_bndrs, spec_app) <- collectHsWrapBinders spec_co
-- spec_co looks like
-- \spec_bndrs. [] spec_args
-- perhaps with the body of the lambda wrapped in some WpLets
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
-
- ; dsHsWrapper spec_app $ \core_app -> do
-
- { let ds_lhs = core_app (Var poly_id)
- spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
- ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
- -- , text "spec_co:" <+> ppr spec_co
- -- , text "ds_rhs:" <+> ppr ds_lhs ]) $
- dflags <- getDynFlags
- ; case decomposeRuleLhs dflags spec_bndrs ds_lhs (mkVarSet spec_bndrs) of {
+ = dsHsWrapper spec_app $ \core_app ->
+ do { dflags <- getDynFlags
+ ; case decomposeRuleLhs dflags spec_bndrs (core_app (Var poly_id))
+ (mkVarSet spec_bndrs) of {
Left msg -> do { diagnosticDs msg; return Nothing } ;
- Right (rule_bndrs, _fn, rule_lhs_args) -> do
-
- { this_mod <- getModule
- ; let fn_unf = realIdUnfolding poly_id
- simpl_opts = initSimpleOpts dflags
- spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf
- spec_id = mkLocalId spec_name ManyTy spec_ty -- Specialised binding is toplevel, hence Many.
- `setInlinePragma` inl_prag
- `setIdUnfolding` spec_unf
-
- rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
- poly_id rule_bndrs rule_lhs_args
- (mkVarApps (Var spec_id) spec_bndrs)
- spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
-
- ; dsWarnOrphanRule rule
-
- ; tracePm "dsSpec" (vcat
- [ text "fun:" <+> ppr poly_id
- , text "spec_co:" <+> ppr spec_co
- , text "spec_bndrs:" <+> ppr spec_bndrs
- , text "ds_lhs:" <+> ppr ds_lhs
- , text "args:" <+> ppr rule_lhs_args ])
- ; return (Just (unitOL (spec_id, spec_rhs), rule))
- -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
- -- makeCorePair overwrites the unfolding, which we have
- -- just created using specUnfolding
- } } } }
+ Right (rule_bndrs, poly_id, rule_lhs_args) ->
+ finishSpecPrag (idName poly_id) poly_rhs
+ rule_bndrs poly_id rule_lhs_args
+ spec_bndrs core_app spec_inl } }
+
+dsSpec poly_rhs (
+ SpecPragE
+ { spe_fn_nm = poly_nm
+ , spe_fn_id = poly_id
+ , spe_inl = inl
+ , spe_bndrs = bndrs
+ , spe_call = the_call
+ })
+ -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
+ = do { ds_call <- unsetGOptM Opt_EnableRewriteRules $ -- Note [Desugaring RULE left hand sides]
+ unsetWOptM Opt_WarnIdentities $
+ zapUnspecables $
+ dsLExpr the_call
+
+ -- Simplify the (desugared) call; see wrinkle (SP1)
+ -- in Note [Desugaring new-form SPECIALISE pragmas]
+ ; dflags <- getDynFlags
+ ; let simpl_opts = initSimpleOpts dflags
+ core_call = simpleOptExprNoInline simpl_opts ds_call
+
+ ; case prepareSpecLHS poly_id bndrs core_call of {
+ Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
+ ; return Nothing } ;
+
+ Just (bndr_set, spec_const_binds, lhs_args) ->
+
+ do { let const_bndrs = mkVarSet (bindersOfBinds spec_const_binds)
+ all_bndrs = bndr_set `unionVarSet` const_bndrs
+ -- all_bndrs: all binders in core_call that should be quantified
+
+ -- rule_bndrs; see (SP3) in Note [Desugaring new-form SPECIALISE pragmas]
+ rule_bndrs = scopedSort (exprsSomeFreeVarsList (`elemVarSet` all_bndrs) lhs_args)
+ spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs
+
+ mk_spec_body fn_body = mkLets spec_const_binds $
+ mkCoreApps fn_body lhs_args
+
+ ; tracePm "dsSpec" (vcat [ text "poly_id" <+> ppr poly_id
+ , text "bndrs" <+> ppr bndrs
+ , text "lhs_args" <+> ppr lhs_args
+ , text "bndr_set" <+> ppr bndr_set
+ , text "all_bndrs" <+> ppr all_bndrs
+ , text "rule_bndrs" <+> ppr rule_bndrs
+ , text "const_bndrs" <+> ppr const_bndrs
+ , text "spec_bndrs" <+> ppr spec_bndrs
+ , text "core_call fvs" <+> ppr (exprFreeVars core_call)
+ , text "spec_const_binds" <+> ppr spec_const_binds
+ , text "ds_call" <+> ppr ds_call
+ , text "core_call" <+> ppr core_call ])
+
+ ; finishSpecPrag poly_nm poly_rhs
+ rule_bndrs poly_id lhs_args
+ spec_bndrs mk_spec_body inl } } }
+
+prepareSpecLHS :: Id -> [EvVar] -> CoreExpr
+ -> Maybe (VarSet, [CoreBind], [CoreExpr])
+-- See Note [prepareSpecLHS]
+prepareSpecLHS poly_id evs the_call
+ = go (mkVarSet evs) [] the_call
where
- is_local_id = isJust mb_poly_rhs
- poly_rhs | Just rhs <- mb_poly_rhs
- = rhs -- Local Id; this is its rhs
- | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
- = unfolding -- Imported Id; this is its unfolding
- -- Use realIdUnfolding so we get the unfolding
- -- even when it is a loop breaker.
- -- We want to specialise recursive functions!
- | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
- -- The type checker has checked that it *has* an unfolding
-
- id_inl = idInlinePragma poly_id
+ go :: VarSet -- Quantified variables, or dependencies thereof
+ -> [CoreBind] -- Reversed list of constant evidence bindings
+ -> CoreExpr
+ -> Maybe (IdSet, [CoreBind], [CoreExpr])
+ go qevs acc (Cast e _)
+ = go qevs acc e
+ go qevs acc (Let bind e)
+ | not (all isDictId bndrs) -- A normal 'let' is too complicated
+ = Nothing
+
+ -- (a) (1) in Note [prepareSpecLHS]
+ | all (transfer_to_spec_rhs qevs) $
+ rhssOfBind bind -- One of the `const_binds`
+ = go qevs (bind:acc) e
+
+ -- (a) (2) in Note [prepareSpecLHS]
+ | otherwise
+ = go (qevs `extendVarSetList` bndrs) acc e
+ where
+ bndrs = bindersOf bind
+
+ go qevs acc e
+ | (Var fun, args) <- collectArgs e
+ -- (a) (3) in Note [prepareSpecLHS]
+ = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $
+ Just (qevs, reverse acc, args)
+ | otherwise
+ = Nothing
+
+ transfer_to_spec_rhs qevs rhs
+ = isEmptyVarSet $ exprSomeFreeVars is_quant_id rhs
+ where
+ is_quant_id v = isId v && v `elemVarSet` qevs
+ -- See (a) (2) in Note [prepareSpecLHS]
+
+finishSpecPrag :: Name -> CoreExpr -- RHS to specialise
+ -> [Var] -> Id -> [CoreExpr] -- RULE LHS pattern
+ -> [Var] -> (CoreExpr -> CoreExpr) -> InlinePragma -- Specialised form
+ -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_args
+ spec_bndrs mk_spec_body spec_inl
+ | Just reason <- mb_useless
+ = do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason
+ ; if uselessSpecialisePragmaKeepAnyway reason
+ then Just <$> finish_prag
+ else return Nothing }
- -- See Note [Activation pragmas for SPECIALISE]
- inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
- | not is_local_id -- See Note [Specialising imported functions]
- -- in OccurAnal
- , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
- | otherwise = id_inl
- -- Get the INLINE pragma from SPECIALISE declaration, or,
- -- failing that, from the original Id
+ | otherwise
+ = Just <$> finish_prag
- spec_prag_act = inlinePragmaActivation spec_inl
+ where
+ -- The RULE looks like
+ -- RULE "USPEC" forall rule_bndrs. f rule_args = $sf spec_bndrs
+ -- The specialised function looks like
+ -- $sf spec_bndrs = mk_spec_body <f's original rhs>
+ -- We also use mk_spec_body to specialise the methods in f's stable unfolding
+ -- NB: spec_bindrs is a subset of rule_bndrs
+ finish_prag
+ = do { this_mod <- getModule
+ ; uniq <- newUnique
+ ; dflags <- getDynFlags
+ ; let poly_name = idName poly_id
+ spec_occ = mkSpecOcc (getOccName poly_name)
+ spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
+
+ simpl_opts = initSimpleOpts dflags
+ fn_unf = realIdUnfolding poly_id
+ spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_args fn_unf
+ spec_id = mkLocalId spec_name ManyTy spec_ty
+ -- Specialised binding is toplevel, hence Many.
+ `setInlinePragma` specFunInlinePrag poly_id id_inl spec_inl
+ `setIdUnfolding` spec_unf
+
+ rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
+ poly_id rule_bndrs rule_args
+ (mkVarApps (Var spec_id) spec_bndrs)
+
+ rule_ty = exprType (mkApps (Var poly_id) rule_args)
+ spec_ty = mkLamTypes spec_bndrs rule_ty
+ spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs)
+
+ ; dsWarnOrphanRule rule
+
+ ; tracePm "dsSpec" (vcat
+ [ text "fun:" <+> ppr poly_id
+ , text "spec_bndrs:" <+> ppr spec_bndrs
+ , text "args:" <+> ppr rule_args ])
+ ; return (unitOL (spec_id, spec_rhs), rule) }
+ -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
+ -- makeCorePair overwrites the unfolding, which we have
+ -- just created using specUnfolding
+
+ -- Is this SPECIALISE pragma useless?
+ mb_useless :: Maybe UselessSpecialisePragmaReason
+ mb_useless
+ | isJust (isClassOpId_maybe poly_id)
+ -- There is no point in trying to specialise a class op
+ -- Moreover, classops don't (currently) have an inl_sat arity set
+ -- (it would be Just 0) and that in turn makes makeCorePair bleat
+ = Just UselessSpecialiseForClassMethodSelector
+
+ | no_act_spec, isNeverActive rule_act
+ -- Function is NOINLINE, and the specialisation inherits that
+ -- See Note [Activation pragmas for SPECIALISE]
+ = Just UselessSpecialiseForNoInlineFunction
+
+ | all is_nop_arg rule_args, not (isInlinePragma spec_inl)
+ -- The specialisation does nothing.
+ -- But don't complain if it is SPECIALISE INLINE (#4444)
+ = Just UselessSpecialiseNoSpecialisation
+
+ | otherwise
+ = Nothing
-- See Note [Activation pragmas for SPECIALISE]
-- no_act_spec is True if the user didn't write an explicit
-- phase specification in the SPECIALISE pragma
+ id_inl = idInlinePragma poly_id
+ inl_prag_act = inlinePragmaActivation id_inl
+ spec_prag_act = inlinePragmaActivation spec_inl
no_act_spec = case inlinePragmaSpec spec_inl of
NoInline _ -> isNeverActive spec_prag_act
Opaque _ -> isNeverActive spec_prag_act
_ -> isAlwaysActive spec_prag_act
- rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
- | otherwise = spec_prag_act -- Specified by user
-
+ rule_act | no_act_spec = inl_prag_act -- Inherit
+ | otherwise = spec_prag_act -- Specified by user
+
+ is_nop_arg (Type {}) = True
+ is_nop_arg (Coercion {}) = True
+ is_nop_arg (Cast e _) = is_nop_arg e
+ is_nop_arg (Tick _ e) = is_nop_arg e
+ is_nop_arg (Var x) = x `elem` spec_bndrs
+ is_nop_arg _ = False
+
+ is_dfun = case idDetails poly_id of
+ DFunId {} -> True
+ _ -> False
+
+specFunInlinePrag :: Id -> InlinePragma
+ -> InlinePragma -> InlinePragma
+-- See Note [Activation pragmas for SPECIALISE]
+specFunInlinePrag poly_id id_inl spec_inl
+ | not (isDefaultInlinePragma spec_inl) = spec_inl
+ | isGlobalId poly_id -- See Note [Specialising imported functions]
+ -- in OccurAnal
+ , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+ | otherwise = id_inl
+ -- Get the INLINE pragma from SPECIALISE declaration, or,
+ -- failing that, from the original Id
dsWarnOrphanRule :: CoreRule -> DsM ()
dsWarnOrphanRule rule
@@ -996,6 +1358,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
-- , text "args2:" <+> ppr args2
-- ]) $
Left (DsRuleLhsTooComplicated orig_lhs lhs2)
+
Just (fn_id, args)
| not (null unbound) ->
-- Check for things unbound on LHS
@@ -1011,38 +1374,35 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
-- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
-- , text "orig_lhs:" <+> ppr orig_lhs
-- , text "lhs1:" <+> ppr lhs1
- -- , text "extra_bndrs:" <+> ppr extra_bndrs
+ -- , text "trimmed_bndrs:" <+> ppr trimmed_bndrs
+ -- , text "extra_dicts:" <+> ppr extra_dicts
-- , text "fn_id:" <+> ppr fn_id
-- , text "args:" <+> ppr args
-- , text "args fvs:" <+> ppr (exprsFreeVarsList args)
-- ]) $
- Right (trimmed_bndrs ++ extra_bndrs, fn_id, args)
+ Right (trimmed_bndrs ++ extra_dicts, fn_id, args)
where -- See Note [Variables unbound on the LHS]
- lhs_fvs = exprsFreeVars args
+ lhs_fvs = exprsFreeVars args
all_fvs = lhs_fvs `unionVarSet` rhs_fvs
trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs
unbound = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs
-- Needed on RHS but not bound on LHS
- -- Add extra tyvar binders: Note [Free tyvars on rule LHS]
- -- and extra dict binders: Note [Free dictionaries on rule LHS]
- extra_bndrs = scopedSort extra_tvs ++ extra_dicts
- where
- extra_tvs = [ v | v <- extra_vars, isTyVar v ]
-
- -- isEvVar: this includes coercions, matching what
- -- happens in `split_lets` (isDictId, isCoVar)
- extra_dicts =
- [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)
- | d <- extra_vars, isEvVar d ]
- extra_vars =
- [ v
- | v <- exprsFreeVarsList args
- , not (v `elemVarSet` orig_bndr_set)
- , not (v == fn_id) ]
- -- fn_id: do not quantify over the function itself, which may
- -- itself be a dictionary (in pathological cases, #10251)
+ -- extra_dicts: see Note [Free dictionaries on rule LHS]
+-- ToDo: extra_dicts is needed. E.g. the SPECIALISE rules for `ap` in GHC.Base
+ extra_dicts
+ = [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)
+ | d <- exprsSomeFreeVarsList is_extra args ]
+
+ is_extra v
+ = isEvVar v
+ -- isEvVar: includes coercions, matching what
+ -- happens in `split_lets` (isDictId, isCoVar)
+ && not (v `elemVarSet` orig_bndr_set)
+ && not (v == fn_id)
+ -- fn_id: do not quantify over the function itself, which may
+ -- itself be a dictionary (in pathological cases, #10251)
where
simpl_opts = initSimpleOpts dflags
@@ -1107,7 +1467,7 @@ Consider #22471
We get two dicts on the LHS, one from `1` and one from `+`.
For reasons described in Note [The SimplifyRule Plan] in
-GHC.Tc.Gen.Rule, we quantify separately over those dictionaries:
+GHC.Tc.Gen.Sig, we quantify separately over those dictionaries:
forall f (d1::Num Int) (d2 :: Num Int).
foo (\xs. (+) d1 (fromInteger d2 1) xs) = ...
@@ -1122,32 +1482,6 @@ There are several things going on here.
* simpleOptExpr: see Note [Simplify rule LHS]
* extra_dict_bndrs: see Note [Free dictionaries on rule LHS]
-Note [Free tyvars on rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data T a = C
-
- foo :: T a -> Int
- foo C = 1
-
- {-# RULES "myrule" foo C = 1 #-}
-
-After type checking the LHS becomes (foo alpha (C alpha)), where alpha
-is an unbound meta-tyvar. The zonker in GHC.Tc.Zonk.Type is careful not to
-turn the free alpha into Any (as it usually does). Instead it turns it
-into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in "GHC.Tc.Zonk.Type".
-
-Now we must quantify over that 'a'. It's /really/ inconvenient to do that
-in the zonker, because the HsExpr data type is very large. But it's /easy/
-to do it here in the desugarer.
-
-Moreover, we have to do something rather similar for dictionaries;
-see Note [Free dictionaries on rule LHS]. So that's why we look for
-type variables free on the LHS, and quantify over them.
-
-This relies on there not being any in-scope tyvars, which is true for
-user-defined RULEs, which are always top-level.
-
Note [Free dictionaries on rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
@@ -1182,9 +1516,9 @@ drop_dicts drops dictionary bindings on the LHS where possible.
quantify over it. That makes 'd' free in the LHS, but that is later
picked up by extra_dict_bndrs (see Note [Unused spec binders]).
- NB 1: We can only drop the binding if the RHS doesn't bind
- one of the orig_bndrs, which we assume occur on RHS.
- Example
+ NB 1: We can only drop the binding if the RHS of the binding doesn't
+ mention one of the orig_bndrs, which we assume occur on RHS of
+ the rule. Example
f :: (Eq a) => b -> a -> a
{-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
Here we want to end up with
@@ -1192,7 +1526,7 @@ drop_dicts drops dictionary bindings on the LHS where possible.
Of course, the ($dfEqlist d) in the pattern makes it less likely
to match, but there is no other way to get d:Eq a
- NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+ NB 2: We do drop_dicts *before* simplOptExpr, so that we expect all
the evidence bindings to be wrapped around the outside of the
LHS. (After simplOptExpr they'll usually have been inlined.)
dsHsWrapper does dependency analysis, so that civilised ones
@@ -1376,29 +1710,34 @@ dsEvBinds ev_binds thing_inside
thing_inside (core_bind:core_binds) }
go [] thing_inside = thing_inside []
- ds_component unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)
+ ds_component mb_unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)
where
((v, rhs), (this_canonical, deps)) = unpack_node node
- transitively_unspecable = is_unspecable this_canonical || any is_unspecable_dep deps
- is_unspecable_dep dep = dep `S.member` unspecables
- new_unspecables
- | transitively_unspecable = S.singleton v
- | otherwise = mempty
- ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)
+ new_unspecables = case mb_unspecables of
+ Nothing -> []
+ Just unspecs | transitively_unspecable -> [v]
+ | otherwise -> []
+ where
+ transitively_unspecable = is_unspecable this_canonical
+ || any (`elemVarSet` unspecs) deps
+
+ ds_component mb_unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)
where
(pairs, direct_canonicity) = unzip $ map unpack_node nodes
- is_unspecable_remote dep = dep `S.member` unspecables
- transitively_unspecable = or [ is_unspecable this_canonical || any is_unspecable_remote deps
- | (this_canonical, deps) <- direct_canonicity ]
+ new_unspecables = case mb_unspecables of
+ Nothing -> []
+ Just unspecs | transitively_unspecable -> map fst pairs
+ | otherwise -> []
+ where
+ transitively_unspecable
+ = or [ is_unspecable this_canonical
+ || any (`elemVarSet` unspecs) deps
+ | (this_canonical, deps) <- direct_canonicity ]
-- Bindings from a given SCC are transitively specialisable if
-- all are specialisable and all their remote dependencies are
-- also specialisable; see Note [Desugaring non-canonical evidence]
- new_unspecables
- | transitively_unspecable = S.fromList [ v | (v, _) <- pairs]
- | otherwise = mempty
-
unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps }
= ((v, rhs), (canonical, deps))
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index 976c87eaa87..66954d15058 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -83,12 +83,46 @@ instance Diagnostic DsMessage where
StrictBinds -> "strict bindings"
in mkSimpleDecorated $
hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)
- DsUselessSpecialiseForClassMethodSelector poly_id
- -> mkSimpleDecorated $
- text "Ignoring useless SPECIALISE pragma for class selector:" <+> quotes (ppr poly_id)
- DsUselessSpecialiseForNoInlineFunction poly_id
- -> mkSimpleDecorated $
- text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)
+ DsUselessSpecialisePragma poly_nm is_dfun rea ->
+ mkSimpleDecorated $
+ vcat [ what <+> pragma <+> text "pragma" <> why
+ , additional ]
+ where
+ quoted_nm = quotes (ppr poly_nm)
+ what
+ | uselessSpecialisePragmaKeepAnyway rea
+ = text "Dubious"
+ | otherwise
+ = text "Ignoring useless"
+ pragma = if is_dfun
+ then text "SPECIALISE instance"
+ else text "SPECIALISE"
+ why = case rea of
+ UselessSpecialiseForClassMethodSelector ->
+ text " for class selector:" <+> quoted_nm
+ UselessSpecialiseForNoInlineFunction ->
+ text " for NOINLINE function:" <+> quoted_nm
+ UselessSpecialiseNoSpecialisation ->
+ -- Omit the Name for a DFunId, as it will be internal and not
+ -- very illuminating to users who don't know what a DFunId is.
+ (if is_dfun then empty else text " for" <+> quoted_nm) <> dot
+
+ additional
+ | uselessSpecialisePragmaKeepAnyway rea
+ = -- No specialisation happening, but the pragma may still be useful.
+ -- For example (#25389):
+ --
+ -- data G a where { G1 :: G Int, G2 :: G Bool }
+ -- f :: G a -> a
+ -- f G1 = <branch1>; f G2 = <branch2>
+ -- {-# SPECIALISE f :: G Int -> Int #-}
+ -- -- In $sf, we get rid of dead code in <branch2>
+ vcat
+ [ text "The pragma does not specialise away any class dictionaries,"
+ , text "and neither is there any value specialisation."
+ ]
+ | otherwise
+ = empty
DsOrphanRule rule
-> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule
DsRuleLhsTooComplicated orig_lhs lhs2
@@ -109,7 +143,7 @@ instance Diagnostic DsMessage where
, text "is not bound in RULE lhs"])
2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
, text "Orig lhs:" <+> ppr orig_lhs
- , text "optimised lhs:" <+> ppr lhs2 ])
+ , text "Optimised lhs:" <+> ppr lhs2 ])
pp_bndr b
| isTyVar b = text "type variable" <+> quotes (ppr b)
@@ -224,8 +258,7 @@ instance Diagnostic DsMessage where
DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _
-> maybe WarningWithoutFlag WarningWithFlag mb_flag
DsTopLevelBindsNotAllowed{} -> ErrorWithoutFlag
- DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag
- DsUselessSpecialiseForNoInlineFunction{} -> WarningWithoutFlag
+ DsUselessSpecialisePragma{} -> WarningWithFlag Opt_WarnUselessSpecialisations
DsOrphanRule{} -> WarningWithFlag Opt_WarnOrphans
DsRuleLhsTooComplicated{} -> WarningWithoutFlag
DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag
@@ -260,8 +293,7 @@ instance Diagnostic DsMessage where
DsMaxPmCheckModelsReached{} -> [SuggestIncreaseMaxPmCheckModels]
DsNonExhaustivePatterns{} -> noHints
DsTopLevelBindsNotAllowed{} -> noHints
- DsUselessSpecialiseForClassMethodSelector{} -> noHints
- DsUselessSpecialiseForNoInlineFunction{} -> noHints
+ DsUselessSpecialisePragma{} -> noHints
DsOrphanRule{} -> noHints
DsRuleLhsTooComplicated{} -> noHints
DsRuleIgnoredDueToConstructor{} -> noHints
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index aecaeea1060..170754a0a06 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.HsToCore.Errors.Types where
@@ -105,9 +106,18 @@ data DsMessage
| DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc)
- | DsUselessSpecialiseForClassMethodSelector !Id
+ {-| DsUselessSpecialisePragma is a warning (controlled by the -Wuseless-specialisations flag)
+ that is emitted for SPECIALISE pragmas that (most likely) don't do anything.
- | DsUselessSpecialiseForNoInlineFunction !Id
+ Examples:
+
+ foo :: forall a. a -> a
+ {-# SPECIALISE foo :: Int -> Int #-}
+ -}
+ | DsUselessSpecialisePragma
+ !Name
+ !Bool -- ^ is this a @SPECIALISE instance@ pragma?
+ !UselessSpecialisePragmaReason
| DsOrphanRule !CoreRule
@@ -195,6 +205,25 @@ data ThRejectionReason
| ThSplicesWithinDeclBrackets
| ThNonLinearDataCon
+-- | Why is a @SPECIALISE@ pragmas useless?
+data UselessSpecialisePragmaReason
+ -- | Useless @SPECIALISE@ pragma for a class method
+ = UselessSpecialiseForClassMethodSelector
+ -- | Useless @SPECIALISE@ pragma for a function with NOINLINE
+ | UselessSpecialiseForNoInlineFunction
+ -- | Useless @SPECIALISE@ pragma which generates a specialised function
+ -- which is identical to the original function at runtime.
+ | UselessSpecialiseNoSpecialisation
+ deriving Generic
+
+uselessSpecialisePragmaKeepAnyway :: UselessSpecialisePragmaReason -> Bool
+uselessSpecialisePragmaKeepAnyway = \case
+ UselessSpecialiseForClassMethodSelector -> False
+ UselessSpecialiseForNoInlineFunction -> False
+ UselessSpecialiseNoSpecialisation -> True
+ -- See #25389/T25389 for why we might want to keep this specialisation
+ -- around even if it seemingly does nothing.
+
data NegLiteralExtEnabled
= YesUsingNegLiterals
| NotUsingNegLiterals
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index caaba2969d1..6200e3bdbe5 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -62,6 +62,7 @@ import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make
import GHC.Types.Var( isInvisibleAnonPiTyBinder )
+import GHC.Types.Var.Set( isEmptyVarSet, elemVarSet )
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Tickish
@@ -76,7 +77,6 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import Control.Monad
-import qualified Data.Set as S
{-
************************************************************************
@@ -692,8 +692,7 @@ ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_ar
= ds_app_rec_sel sel_id sel_id core_args
ds_app (HsVar _ lfun) hs_args core_args
- = do { tracePm "ds_app" (ppr lfun <+> ppr core_args)
- ; ds_app_var lfun hs_args core_args }
+ = ds_app_var lfun hs_args core_args
ds_app e _hs_args core_args
= do { core_e <- dsExpr e
@@ -789,15 +788,15 @@ ds_app_finish :: Id -> [CoreExpr] -> DsM CoreExpr
-- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does.
-- See Note [Desugaring non-canonical evidence]
ds_app_finish fun_id core_args
- = do { unspecables <- getUnspecables
+ = do { mb_unspecables <- getUnspecables
; let fun_ty = idType fun_id
free_dicts = exprsFreeVarsList
[ e | (e,pi_bndr) <- core_args `zip` fst (splitPiTys fun_ty)
, isInvisibleAnonPiTyBinder pi_bndr ]
- is_unspecable_var v = v `S.member` unspecables
- fun | not (S.null unspecables) -- Fast path
- , any (is_unspecable_var) free_dicts
+ fun | Just unspecables <- mb_unspecables
+ , not (isEmptyVarSet unspecables) -- Fast path
+ , any (`elemVarSet` unspecables) free_dicts
= Var nospecId `App` Type fun_ty `App` Var fun_id
| otherwise
= Var fun_id
@@ -916,8 +915,8 @@ Note [Desugaring non-canonical evidence]
When constructing an application
f @ty1 ty2 .. dict1 dict2 .. arg1 arg2 ..
if the evidence `dict_i` is canonical, we simply build that application.
-But if any of the `dict_i` are /non-canonical/, we wrap the appication in `nospec`,
-thus
+But if any of the `dict_i` are /non-canonical/, we wrap the application
+in `nospec`, thus
nospec @fty f @ty1 @ty2 .. dict1 dict2 .. arg1 arg2 ..
where nospec :: forall a. a -> a ensures that the typeclass specialiser
doesn't attempt to common up this evidence term with other evidence terms
@@ -942,7 +941,7 @@ How do we decide if the arguments are non-canonical dictionaries?
Wrinkle:
-(NC1) We don't do this in the LHS of a RULE. In paritcular, if we have
+(NC1) We don't do this in the LHS of a RULE. In particular, if we have
f :: (Num a, HasCallStack) => a -> a
{-# SPECIALISE f :: Int -> Int #-}
then making a rule like
@@ -954,7 +953,8 @@ Wrinkle:
We definitely can't desugar that LHS into this!
nospec (f @Int d1) d2
- This is done by zapping the unspecables in `dsRule`.
+ This is done by zapping the unspecables in `dsRule` to Nothing. That `Nothing`
+ says not to collect unspecables at all.
Note [Desugaring explicit lists]
diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs
index b135978e156..fbbf633814e 100644
--- a/compiler/GHC/HsToCore/Foreign/Call.hs
+++ b/compiler/GHC/HsToCore/Foreign/Call.hs
@@ -22,32 +22,37 @@ where
import GHC.Prelude
import GHC.Core
-
-import GHC.HsToCore.Monad
import GHC.Core.Utils
import GHC.Core.Make
-import GHC.Types.SourceText
-import GHC.Types.Id.Make
-import GHC.Types.ForeignCall
import GHC.Core.DataCon
-import GHC.HsToCore.Utils
-
-import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Coercion
-import GHC.Builtin.Types.Prim
import GHC.Core.TyCon
-import GHC.Builtin.Types
+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped )
+
+import GHC.HsToCore.Monad
+import GHC.HsToCore.Utils
+
+import GHC.Types.SourceText
+import GHC.Types.Id.Make
+import GHC.Types.ForeignCall
import GHC.Types.Basic
import GHC.Types.Literal
+import GHC.Types.RepType (typePrimRep1)
+
+import GHC.Tc.Utils.TcType
+
+import GHC.Builtin.Types.Prim
+import GHC.Builtin.Types
import GHC.Builtin.Names
+
import GHC.Driver.DynFlags
+
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Maybe
-import GHC.Types.RepType (typePrimRep1)
{-
Desugaring of @ccall@s consists of adding some state manipulation,
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index e70d59492b6..0c905d62b70 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -94,7 +94,8 @@ import GHC.Unit.Module.ModGuts
import GHC.Types.Name.Reader
import GHC.Types.SourceFile
import GHC.Types.Id
-import GHC.Types.Var (EvId)
+import GHC.Types.Var (EvVar)
+import GHC.Types.Var.Set( VarSet, emptyVarSet, extendVarSetList )
import GHC.Types.SrcLoc
import GHC.Types.TypeEnv
import GHC.Types.Unique.Supply
@@ -117,7 +118,6 @@ import qualified GHC.Data.Strict as Strict
import Data.IORef
import GHC.Driver.Env.KnotVars
-import qualified Data.Set as S
import GHC.IO.Unsafe (unsafeInterleaveIO)
{-
@@ -406,7 +406,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
, dsl_nablas = initNablas
- , dsl_unspecables = mempty
+ , dsl_unspecables = Just emptyVarSet
}
in (gbl_env, lcl_env)
@@ -469,13 +469,17 @@ getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
updPmNablas :: Nablas -> DsM a -> DsM a
updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
-addUnspecables :: S.Set EvId -> DsM a -> DsM a
-addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env })
+addUnspecables :: [EvVar] -> DsM a -> DsM a
+addUnspecables new_unspecables
+ = updLclEnv (\env -> case dsl_unspecables env of
+ Nothing -> env
+ Just us -> env { dsl_unspecables
+ = Just (us `extendVarSetList` new_unspecables) })
zapUnspecables :: DsM a -> DsM a
-zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = mempty })
+zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = Nothing })
-getUnspecables :: DsM (S.Set EvId)
+getUnspecables :: DsM (Maybe VarSet)
getUnspecables = dsl_unspecables <$> getLclEnv
getSrcSpanDs :: DsM SrcSpan
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 4420262bd9e..b0ad0a67811 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -799,29 +799,37 @@ repDefD (L loc (DefaultDecl _ _ tys)) = do { tys1 <- repLTys tys
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
, rd_act = act
- , rd_tyvs = m_ty_bndrs
- , rd_tmvs = tm_bndrs
+ , rd_bndrs = bndrs
, rd_lhs = lhs
, rd_rhs = rhs }))
+ = fmap (locA loc, ) <$>
+ repRuleBinders bndrs $ \ ty_bndrs' tm_bndrs' ->
+ do { n' <- coreStringLit $ unLoc n
+ ; act' <- repPhases act
+ ; lhs' <- repLE lhs
+ ; rhs' <- repLE rhs
+ ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
+
+repRuleBinders :: RuleBndrs GhcRn
+ -> (Core (Maybe [M (TH.TyVarBndr ())]) -> Core [M TH.RuleBndr] -> MetaM (Core (M a)))
+ -> MetaM (Core (M a))
+repRuleBinders (RuleBndrs { rb_tyvs = m_ty_bndrs, rb_tmvs = tm_bndrs }) thing_inside
= do { let ty_bndrs = fromMaybe [] m_ty_bndrs
- ; rule <- addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->
- do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
- ; ss <- mkGenSyms tm_bndr_names
- ; rule <- addBinds ss $
- do { elt_ty <- wrapName tyVarBndrUnitTyConName
- ; ty_bndrs' <- return $ case m_ty_bndrs of
- Nothing -> coreNothing' (mkListTy elt_ty)
- Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
- ; tm_bndrs' <- repListM ruleBndrTyConName
- repRuleBndr
- tm_bndrs
- ; n' <- coreStringLit $ unLoc n
- ; act' <- repPhases act
- ; lhs' <- repLE lhs
- ; rhs' <- repLE rhs
- ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
- ; wrapGenSyms ss rule }
- ; return (locA loc, rule) }
+ ; addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->
+ do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
+ ; ss <- mkGenSyms tm_bndr_names
+ ; x <- addBinds ss $
+ do { elt_ty <- wrapName tyVarBndrUnitTyConName
+ ; ty_bndrs' <- return $ case m_ty_bndrs of
+ Nothing -> coreNothing' (mkListTy elt_ty)
+ Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs
+ ; tm_bndrs' <- repListM ruleBndrTyConName
+ repRuleBndr
+ tm_bndrs
+ ; thing_inside ty_bndrs' tm_bndrs'
+ }
+ ; wrapGenSyms ss x }
+ }
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
@@ -992,8 +1000,11 @@ rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig
rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
-rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
-rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
+rep_sig (L loc (SpecSigE _nm bndrs expr ispec))
+ = fmap (\ d -> [(locA loc, d)]) $
+ rep_specialiseE bndrs expr ispec
+rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
+rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc)
rep_sig (L loc (CompleteMatchSig _ cls mty))
= rep_complete_sig cls mty (locA loc)
@@ -1094,23 +1105,38 @@ rep_inline nm ispec loc
; return [(loc, pragma)]
}
+rep_inline_phases :: InlinePragma -> MetaM (Maybe (Core TH.Inline), Core TH.Phases)
+rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl })
+ = do { phases <- repPhases act
+ ; inl <- if noUserInlineSpec inl
+ -- SPECIALISE
+ then return Nothing
+ -- SPECIALISE INLINE
+ else Just <$> repInline inl
+ ; return (inl, phases) }
+
rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma
-> SrcSpan
-> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialise nm ty ispec loc
+ -- Old form SPECIALISE pragmas
= do { nm1 <- lookupLOcc nm
; ty1 <- repHsSigType ty
- ; phases <- repPhases $ inl_act ispec
- ; let inline = inl_inline ispec
- ; pragma <- if noUserInlineSpec inline
- then -- SPECIALISE
- repPragSpec nm1 ty1 phases
- else -- SPECIALISE INLINE
- do { inline1 <- repInline inline
- ; repPragSpecInl nm1 ty1 inline1 phases }
+ ; (inl, phases) <- rep_inline_phases ispec
+ ; pragma <- repPragSpec nm1 ty1 inl phases
; return [(loc, pragma)]
}
+rep_specialiseE :: RuleBndrs GhcRn -> LHsExpr GhcRn -> InlinePragma
+ -> MetaM (Core (M TH.Dec))
+rep_specialiseE bndrs e ispec
+ -- New form SPECIALISE pragmas
+ = repRuleBinders bndrs $ \ ty_bndrs tm_bndrs ->
+ do { (inl, phases) <- rep_inline_phases ispec
+ ; exp <- repLE e
+ ; repPragSpecE ty_bndrs tm_bndrs exp inl phases
+ }
+
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
-> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_specialiseInst ty loc
@@ -2747,15 +2773,26 @@ repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))
repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]
-repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
+repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Maybe (Core (TH.Inline))
+ -> Core TH.Phases
-> MetaM (Core (M TH.Dec))
-repPragSpec (MkC nm) (MkC ty) (MkC phases)
- = rep2 pragSpecDName [nm, ty, phases]
-
-repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline
- -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
- = rep2 pragSpecInlDName [nm, ty, inline, phases]
+repPragSpec (MkC nm) (MkC ty) mb_inl (MkC phases)
+ = case mb_inl of
+ Nothing ->
+ rep2 pragSpecDName [nm, ty, phases]
+ Just (MkC inl) ->
+ rep2 pragSpecInlDName [nm, ty, inl, phases]
+
+repPragSpecE :: Core (Maybe [M (TH.TyVarBndr ())]) -> Core [(M TH.RuleBndr)]
+ -> Core (M TH.Exp)
+ -> Maybe (Core TH.Inline) -> Core TH.Phases
+ -> MetaM (Core (M TH.Dec))
+repPragSpecE (MkC ty_bndrs) (MkC tm_bndrs) (MkC expr) mb_inl (MkC phases)
+ = case mb_inl of
+ Nothing ->
+ rep2 pragSpecEDName [ty_bndrs, tm_bndrs, expr, phases]
+ Just (MkC inl) ->
+ rep2 pragSpecInlEDName [ty_bndrs, tm_bndrs, expr, inl, phases]
repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index d843db43a1d..f1433706c1d 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -14,27 +14,34 @@ module GHC.HsToCore.Types (
import GHC.Prelude (Int)
import Data.IORef
-import qualified Data.Set as S
import GHC.Types.CostCentre.State
import GHC.Types.Error
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.Var
+import GHC.Types.Var.Set
import GHC.Types.Name.Reader (GlobalRdrEnv)
+
import GHC.Hs (LForeignDecl, HsExpr, GhcTc)
+
import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv)
+
import GHC.HsToCore.Pmc.Types (Nablas)
import GHC.HsToCore.Errors.Types
+
import GHC.Core (CoreExpr)
import GHC.Core.FamInstEnv
import GHC.Utils.Outputable as Outputable
import GHC.Unit.Module
import GHC.Driver.Hooks (DsForeignsHook)
import GHC.Data.OrdList (OrdList)
+
import GHC.Types.ForeignStubs (ForeignStubs)
import GHC.Types.CompleteMatch
+import Data.Maybe( Maybe )
+
{-
************************************************************************
* *
@@ -80,9 +87,11 @@ data DsLclEnv
-- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".
-- The set of reaching values Nablas is augmented as we walk inwards, refined
-- through each pattern match in turn
- , dsl_unspecables :: S.Set EvVar
- -- ^ See Note [Desugaring non-canonical evidence]: this field collects
- -- all un-specialisable evidence variables in scope.
+
+ , dsl_unspecables :: Maybe VarSet
+ -- ^ See Note [Desugaring non-canonical evidence]
+ -- This field collects all un-specialisable evidence variables in scope.
+ -- Nothing <=> don't collect this info (used for the LHS of Rules)
}
-- Inside [| |] brackets, the desugarer looks
diff --git a/compiler/GHC/Iface/Decl.hs b/compiler/GHC/Iface/Decl.hs
index 44d04720208..09f3211483e 100644
--- a/compiler/GHC/Iface/Decl.hs
+++ b/compiler/GHC/Iface/Decl.hs
@@ -31,6 +31,7 @@ import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.Multiplicity
+import GHC.Core.TyCo.Tidy
import GHC.Types.Id
import GHC.Types.Var.Env
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 5896a30d811..2a5ff9790f4 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1832,6 +1832,10 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
[ toHie $ (C Use) name
, toHie $ map (TS (ResolvedScopes [])) typs
]
+ SpecSigE _ bndrs spec_e _ ->
+ [ toHieRuleBndrs (locA sp) (mkScope spec_e) bndrs
+ , toHie spec_e
+ ]
SpecInstSig _ typ ->
[ toHie $ TS (ResolvedScopes []) typ
]
@@ -2175,18 +2179,25 @@ instance ToHie (LocatedA (RuleDecls GhcRn)) where
]
instance ToHie (LocatedA (RuleDecl GhcRn)) where
- toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
+ toHie (L span r@(HsRule { rd_name = rname, rd_bndrs = bndrs
+ , rd_lhs = exprA, rd_rhs = exprB }))
+ = concatM
[ makeNodeA r span
, locOnly $ getLocA rname
- , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
- , toHie $ map (RS $ mkScope (locA span)) bndrs
+ , toHieRuleBndrs (locA span) scope bndrs
, toHie exprA
, toHie exprB
]
- where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
- bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs)
- exprA_sc = mkScope exprA
- exprB_sc = mkScope exprB
+ where
+ scope = mkScope exprA `combineScopes` mkScope exprB
+
+toHieRuleBndrs :: SrcSpan -> Scope -> RuleBndrs GhcRn -> HieM [HieAST Type]
+toHieRuleBndrs span body_sc (RuleBndrs { rb_tyvs = tybndrs, rb_tmvs = bndrs })
+ = concatM [ toHie $ fmap (tvScopes (ResolvedScopes []) full_sc) tybndrs
+ , toHie $ map (RS $ mkScope (locA span)) bndrs ]
+ where
+ full_sc = bndrs_sc `combineScopes` body_sc
+ bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs)
instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where
toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 42404f0772f..deb8112a697 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -58,6 +58,7 @@ import GHC.Core.InstEnv
import GHC.Core.Type
import GHC.Core.DataCon
import GHC.Core.TyCon
+import GHC.Core.TyCo.Tidy
import GHC.Core.Class
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 712c9210089..3d649bd249e 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1927,10 +1927,10 @@ rule :: { LRuleDecl GhcPs }
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
amsA' (sLL $1 $> $ HsRule
- { rd_ext =(((fstOf3 $3) (epTok $5) (fst $2)), getSTRINGs $1)
+ { rd_ext =((fst $2, epTok $5), getSTRINGs $1)
, rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
- , rd_act = (snd $2) `orElse` AlwaysActive
- , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
+ , rd_act = snd $2 `orElse` AlwaysActive
+ , rd_bndrs = ruleBndrsOrDef $3
, rd_lhs = $4, rd_rhs = $6 }) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
@@ -1966,19 +1966,22 @@ rule_explicit_activation :: { ( ActivationAnn
{ ( ActivationAnn (epTok $1) (epTok $3) $2 Nothing
, NeverActive) }
-rule_foralls :: { (EpToken "=" -> ActivationAnn -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }
- : 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2
- in hintExplicitForall $1
- >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
- >> return (\an_eq an_act -> HsRuleAnn
- (Just (epUniTok $1,epTok $3))
- (Just (epUniTok $4,epTok $6))
- an_eq an_act,
- Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }
- | 'forall' rule_vars '.' { (\an_eq an_act -> HsRuleAnn Nothing (Just (epUniTok $1,epTok $3)) an_eq an_act,
- Nothing, mkRuleBndrs $2) }
+rule_foralls :: { Maybe (RuleBndrs GhcPs) }
+ : 'forall' rule_vars '.' 'forall' rule_vars '.'
+ {% hintExplicitForall $1
+ >> checkRuleTyVarBndrNames $2
+ >> let ann = HsRuleBndrsAnn
+ (Just (epUniTok $1,epTok $3))
+ (Just (epUniTok $4,epTok $6))
+ in return (Just (mkRuleBndrs ann (Just $2) $5)) }
+
+ | 'forall' rule_vars '.'
+ { Just (mkRuleBndrs (HsRuleBndrsAnn Nothing (Just (epUniTok $1,epTok $3)))
+ Nothing $2) }
+
-- See Note [%shift: rule_foralls -> {- empty -}]
- | {- empty -} %shift { (\an_eq an_act -> HsRuleAnn Nothing Nothing an_eq an_act, Nothing, []) }
+ | {- empty -} %shift
+ { Nothing }
rule_vars :: { [LRuleTyTmVar] }
: rule_var rule_vars { $1 : $2 }
@@ -2766,16 +2769,21 @@ sigdecl :: { LHsDecl GhcPs }
; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing
; amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ((glR $1, epTok $4), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}
- | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
- {% amsA' (
- let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
- (NoUserInlinePrag, FunLike) (snd $2)
- in sLL $1 $> $ SigD noExtField (SpecSig (AnnSpecSig (glR $1) (epTok $6) (epUniTok $4) (fst $2)) $3 (fromOL $5) inl_prag)) }
-
- | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- {% amsA' (sLL $1 $> $ SigD noExtField (SpecSig (AnnSpecSig (glR $1) (epTok $6) (epUniTok $4) (fst $2)) $3 (fromOL $5)
- (mkInlinePragma (getSPEC_INLINE_PRAGs $1)
- (getSPEC_INLINE $1) (snd $2)))) }
+ | '{-# SPECIALISE' activation rule_foralls infixexp sigtypes_maybe '#-}'
+ {% runPV (unECP $4) >>= \ $4 -> do
+ let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
+ (NoUserInlinePrag, FunLike)
+ (snd $2)
+ spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) (fmap fst $5) (fst $2)) $3 $4 $5
+ amsA' $ sLL $1 $> $ SigD noExtField spec }
+
+ | '{-# SPECIALISE_INLINE' activation rule_foralls infixexp sigtypes_maybe '#-}'
+ {% runPV (unECP $4) >>= \ $4 -> do
+ let inl_prag = mkInlinePragma (getSPEC_INLINE_PRAGs $1)
+ (getSPEC_INLINE $1)
+ (snd $2)
+ spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) (fmap fst $5) (fst $2)) $3 $4 $5
+ amsA' $ sLL $1 $> $ SigD noExtField spec }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{% amsA' (sLL $1 $> $ SigD noExtField (SpecInstSig ((glR $1,epTok $2,epTok $4), (getSPEC_PRAGs $1)) $3)) }
@@ -2784,6 +2792,10 @@ sigdecl :: { LHsDecl GhcPs }
| '{-# MINIMAL' name_boolformula_opt '#-}'
{% amsA' (sLL $1 $> $ SigD noExtField (MinimalSig ((glR $1,epTok $3), (getMINIMAL_PRAGs $1)) $2)) }
+sigtypes_maybe :: { Maybe (TokDcolon, OrdList (LHsSigType GhcPs)) }
+ : '::' sigtypes1 { Just (epUniTok $1, $2) }
+ | {- empty -} { Nothing }
+
activation :: { (ActivationAnn,Maybe Activation) }
-- See Note [%shift: activation -> {- empty -}]
: {- empty -} %shift { (noAnn ,Nothing) }
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 9b3a8d04794..47650862a3e 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -559,6 +559,14 @@ instance Diagnostic PsMessage where
PsErrIllegalOrPat pat
-> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)]
+ PsErrSpecExprMultipleTypeAscription
+ -> mkSimpleDecorated $
+ text "SPECIALISE expression doesn't support multiple type ascriptions"
+
+ PsWarnSpecMultipleTypeAscription
+ -> mkSimpleDecorated $
+ text "SPECIALISE pragmas with multiple type ascriptions are deprecated, and will be removed in GHC 9.18"
+
diagnosticReason = \case
PsUnknownMessage m -> diagnosticReason m
PsHeaderMessage m -> psHeaderMessageReason m
@@ -677,6 +685,8 @@ instance Diagnostic PsMessage where
PsErrInvalidPun {} -> ErrorWithoutFlag
PsErrIllegalOrPat{} -> ErrorWithoutFlag
PsErrTypeSyntaxInPat{} -> ErrorWithoutFlag
+ PsErrSpecExprMultipleTypeAscription{} -> ErrorWithoutFlag
+ PsWarnSpecMultipleTypeAscription{} -> WarningWithFlag Opt_WarnDeprecatedPragmas
diagnosticHints = \case
PsUnknownMessage m -> diagnosticHints m
@@ -846,6 +856,8 @@ instance Diagnostic PsMessage where
PsErrInvalidPun {} -> [suggestExtension LangExt.ListTuplePuns]
PsErrIllegalOrPat{} -> [suggestExtension LangExt.OrPatterns]
PsErrTypeSyntaxInPat{} -> noHints
+ PsErrSpecExprMultipleTypeAscription {} -> [SuggestSplittingIntoSeveralSpecialisePragmas]
+ PsWarnSpecMultipleTypeAscription{} -> [SuggestSplittingIntoSeveralSpecialisePragmas]
diagnosticCode = constructorCode @GHC
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 2ae551b3168..9f814ebdecd 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -491,6 +491,22 @@ data PsMessage
-- T24159_pat_parse_error_6
| PsErrTypeSyntaxInPat !PsErrTypeSyntaxDetails
+ -- | 'PsErrSpecExprMultipleTypeAscription' is an error that occurs when
+ -- a user attempts to use the new form SPECIALISE pragma syntax with
+ -- multiple type signatures, e.g.
+ --
+ -- @{-# SPECIALISE foo 3 :: Float -> Float; Double -> Double #-}
+ | PsErrSpecExprMultipleTypeAscription
+
+ -- | 'PsWarnSpecMultipleTypeAscription' is a warning that occurs when
+ -- a user uses the old-form SPECIALISE pragma syntax with
+ -- multiple type signatures, e.g.
+ --
+ -- @{-# SPECIALISE bar :: Float -> Float; Double -> Double #-}
+ --
+ -- This constructor is deprecated and will be removed in GHC 9.18.
+ | PsWarnSpecMultipleTypeAscription
+
deriving Generic
-- | Extra details about a parse error, which helps
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 27b29076120..cc2f7ddce3f 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -62,8 +62,10 @@ module GHC.Parser.PostProcess (
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
- mkRuleBndrs, mkRuleTyVarBndrs,
+ mkRuleBndrs,
+ ruleBndrsOrDef,
checkRuleTyVarBndrNames,
+ mkSpecSig,
checkRecordSyntax,
checkEmptyGADTs,
addFatalError, hintBangPat,
@@ -1006,29 +1008,84 @@ type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar AnnTyVarBndr (LocatedN RdrName) (Maybe (LHsType GhcPs))
-- ^ Essentially a wrapper for a @RuleBndr GhcPs@
--- turns RuleTyTmVars into RuleBnrs - this is straightforward
-mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
-mkRuleBndrs = fmap (fmap cvt_one)
- where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v
- cvt_one (RuleTyTmVar ann v (Just sig)) =
- RuleBndrSig ann v (mkHsPatSigType noAnn sig)
-
--- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
-mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
-mkRuleTyVarBndrs = fmap (setLHsTyVarBndrNameSpace tvName . cvt_one)
- where cvt_one (L l (RuleTyTmVar ann v msig))
+ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs
+ruleBndrsOrDef (Just bndrs) = bndrs
+ruleBndrsOrDef Nothing = mkRuleBndrs noAnn Nothing []
+
+mkRuleBndrs :: HsRuleBndrsAnn -> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
+mkRuleBndrs ann tvbs tmbs
+ = RuleBndrs { rb_ext = ann
+ , rb_tyvs = fmap (fmap (setLHsTyVarBndrNameSpace tvName . cvt_tv)) tvbs
+ , rb_tmvs = fmap (fmap cvt_tm) tmbs }
+ where
+ -- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward
+ cvt_tm (RuleTyTmVar ann v Nothing) = RuleBndr ann v
+ cvt_tm (RuleTyTmVar ann v (Just sig)) = RuleBndrSig ann v (mkHsPatSigType noAnn sig)
+
+ -- cvt_tv turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
+ cvt_tv (L l (RuleTyTmVar ann v msig))
= L (l2l l) (HsTvb ann () (HsBndrVar noExtField v) (cvt_sig msig))
- cvt_sig Nothing = HsBndrNoKind noExtField
- cvt_sig (Just sig) = HsBndrKind noExtField sig
+ cvt_sig Nothing = HsBndrNoKind noExtField
+ cvt_sig (Just sig) = HsBndrKind noExtField sig
+checkRuleTyVarBndrNames :: [LRuleTyTmVar] -> P ()
-- See Note [Parsing explicit foralls in Rules] in Parser.y
-checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
-checkRuleTyVarBndrNames = mapM_ check . mapMaybe (hsTyVarLName . unLoc)
- where check (L loc (Unqual occ)) =
- when (occNameFS occ `elem` [fsLit "family",fsLit "role"])
- (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
- (PsErrParseErrorOnInput occ))
- check _ = panic "checkRuleTyVarBndrNames"
+checkRuleTyVarBndrNames bndrs
+ = sequence_ [ check lname | L _ (RuleTyTmVar _ lname _) <- bndrs ]
+ where
+ check (L loc (Unqual occ)) =
+ when (occNameFS occ `elem` [fsLit "family",fsLit "role"]) $
+ addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+ PsErrParseErrorOnInput occ
+ check _ = panic "checkRuleTyVarBndrNames"
+
+-- | Deal with both old-form and new-form specialise pragmas, using the new
+-- 'SpecSigE' form unless there are multiple comma-separated type signatures,
+-- in which case we use the old-form.
+--
+-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig.
+mkSpecSig :: InlinePragma
+ -> AnnSpecSig
+ -> Maybe (RuleBndrs GhcPs)
+ -> LHsExpr GhcPs
+ -> Maybe (TokDcolon, OrdList (LHsSigType GhcPs))
+ -> P (Sig GhcPs)
+mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr
+ = case m_sigtypes_ascr of
+ Nothing
+ -- New form, no trailing type signature, e.g {-# SPECIALISE f @Int #-}
+ -> pure $
+ SpecSigE activation_anns
+ (ruleBndrsOrDef m_rule_binds) expr inl_prag
+
+ Just (colon_ann, sigtype_ol)
+
+ -- Singleton, e.g. {-# SPECIALISE f :: ty #-}
+ -- Use the SpecSigE route
+ | [sigtype] <- sigtype_list
+ -> pure $
+ SpecSigE activation_anns
+ (ruleBndrsOrDef m_rule_binds)
+ (L (getLoc expr) -- ToDo: not really the right location for (e::ty)
+ (ExprWithTySig colon_ann expr (mkHsWildCardBndrs sigtype)))
+ inl_prag
+
+ -- So we must have the old form {# SPECIALISE f :: ty1, ty2, ty3 #-}
+ -- Use the old SpecSig route
+ | Nothing <- m_rule_binds
+ , L _ (HsVar _ var) <- expr
+ -> do addPsMessage sigs_loc PsWarnSpecMultipleTypeAscription
+ pure $
+ SpecSig activation_anns var sigtype_list inl_prag
+
+ | otherwise ->
+ addFatalError $
+ mkPlainErrorMsgEnvelope sigs_loc PsErrSpecExprMultipleTypeAscription
+
+ where
+ sigtype_list = fromOL sigtype_ol
+ sigs_loc =
+ getHasLoc colon_ann `combineSrcSpans` getHasLoc (last sigtype_list)
checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
checkRecordSyntax lr@(L loc r)
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 5ab6acf5c80..5876e7f27f4 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -20,7 +20,7 @@ module GHC.Rename.Bind (
rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
-- Other bindings
- rnMethodBinds, renameSigs,
+ rnMethodBinds, renameSigs, bindRuleBndrs,
rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
makeMiniFixityEnv, MiniFixityEnv, emptyMiniFixityEnv,
HsSigCtxt(..),
@@ -44,14 +44,10 @@ import GHC.Rename.Pat
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Fixity
-import GHC.Rename.Utils ( mapFvRn
- , checkDupRdrNames
- , warnUnusedLocalBinds
- , checkUnusedRecordWildcard
- , checkDupAndShadowedNames, bindLocalNamesFV
- , addNoNestedForallsContextsErr, checkInferredVars )
+import GHC.Rename.Utils
import GHC.Driver.DynFlags
import GHC.Unit.Module
+
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Name
@@ -60,16 +56,22 @@ import GHC.Types.Name.Set
import GHC.Types.Name.Reader ( RdrName, rdrNameOcc )
import GHC.Types.SourceFile
import GHC.Types.SrcLoc as SrcLoc
-import GHC.Data.List.SetOps ( findDupsEq )
import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) )
import GHC.Data.Graph.Directed ( SCC(..) )
+
+import GHC.Types.Unique.Set
+
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+
import GHC.Types.CompleteMatch
-import GHC.Types.Unique.Set
+
import GHC.Data.Maybe ( orElse, mapMaybe )
+import GHC.Data.List.SetOps ( findDupsEq )
+
import GHC.Data.OrdList
+
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
@@ -1119,6 +1121,13 @@ renameSig ctxt sig@(SpecSig _ v tys inl)
= do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
+renameSig _ctxt (SpecSigE _ bndrs spec_e inl)
+ = do { fn_rdr <- checkSpecESigShape spec_e
+ ; fn_name <- lookupOccRn fn_rdr -- Checks that the head isn't forall-bound
+ ; bindRuleBndrs (SpecECtx fn_rdr) bndrs $ \_ bndrs' ->
+ do { (spec_e', fvs) <- rnLExpr spec_e
+ ; return (SpecSigE fn_name bndrs' spec_e' inl, fvs) } }
+
renameSig ctxt sig@(InlineSig _ v s)
= do { new_v <- lookupSigOccRn ctxt sig v
; return (InlineSig noAnn new_v s, emptyFVs) }
@@ -1158,6 +1167,21 @@ renameSig _ctxt (CompleteMatchSig (_, s) bf mty)
return (rn_sig, emptyFVs)
+checkSpecESigShape :: LHsExpr GhcPs -> RnM RdrName
+-- Checks the shape of a SPECIALISE
+-- That it looks like (f a1 .. an [ :: ty ])
+checkSpecESigShape spec_e = go_l spec_e
+ where
+ go_l (L _ e) = go e
+
+ go :: HsExpr GhcPs -> RnM RdrName
+ go (ExprWithTySig _ fn _) = go_l fn
+ go (HsApp _ fn _) = go_l fn
+ go (HsAppType _ fn _) = go_l fn
+ go (HsVar _ (L _ fn)) = return fn
+ go (HsPar _ e) = go_l e
+ go _ = failWithTc (TcRnSpecSigShape spec_e)
+
{-
Note [Orphan COMPLETE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1203,10 +1227,8 @@ okHsSig ctxt (L _ sig)
(InlineSig {}, HsBootCtxt {}) -> False
(InlineSig {}, _) -> True
- (SpecSig {}, TopSigCtxt {}) -> True
- (SpecSig {}, LocalBindCtxt {}) -> True
- (SpecSig {}, InstDeclCtxt {}) -> True
- (SpecSig {}, _) -> False
+ (SpecSig {}, ctxt) -> ok_spec_ctxt ctxt
+ (SpecSigE {}, ctxt) -> ok_spec_ctxt ctxt
(SpecInstSig {}, InstDeclCtxt {}) -> True
(SpecInstSig {}, _) -> False
@@ -1224,6 +1246,12 @@ okHsSig ctxt (L _ sig)
(XSig {}, InstDeclCtxt {}) -> True
(XSig {}, _) -> False
+ok_spec_ctxt ::HsSigCtxt -> Bool
+-- Contexts where SPECIALISE can occur
+ok_spec_ctxt (TopSigCtxt {}) = True
+ok_spec_ctxt (LocalBindCtxt {}) = True
+ok_spec_ctxt (InstDeclCtxt {}) = True
+ok_spec_ctxt _ = False
-------------------
findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
@@ -1275,6 +1303,54 @@ localCompletePragmas sigs = mapMaybe (getCompleteSig . unLoc) $ reverse sigs
-- backwards wrt. declaration order. So we reverse them here, because it makes
-- a difference for incomplete match suggestions.
+bindRuleBndrs :: HsDocContext -> RuleBndrs GhcPs
+ -> ([Name] -> RuleBndrs GhcRn -> RnM (a,FreeVars))
+ -> RnM (a,FreeVars)
+bindRuleBndrs doc (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
+ = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
+ ; checkDupRdrNames rdr_names_w_loc
+ ; checkShadowedRdrNames rdr_names_w_loc
+ ; names <- newLocalBndrsRn rdr_names_w_loc
+ ; bindRuleTyVars doc tyvs $ \ tyvs' ->
+ bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
+ thing_inside names (RuleBndrs { rb_ext = noExtField
+ , rb_tyvs = tyvs', rb_tmvs = tmvs' }) }
+ where
+ get_var :: RuleBndr GhcPs -> LocatedN RdrName
+ get_var (RuleBndrSig _ v _) = v
+ get_var (RuleBndr _ v) = v
+
+
+bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
+ -> [LRuleBndr GhcPs] -> [Name]
+ -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+bindRuleTmVars doc tyvs vars names thing_inside
+ = go vars names $ \ vars' ->
+ bindLocalNamesFV names (thing_inside vars')
+ where
+ go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside
+ = go vars ns $ \ vars' ->
+ thing_inside (L l (RuleBndr noAnn (L loc n)) : vars')
+
+ go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)
+ (n : ns) thing_inside
+ = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->
+ go vars ns $ \ vars' ->
+ thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars')
+
+ go [] [] thing_inside = thing_inside []
+ go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
+
+ bind_free_tvs = case tyvs of Nothing -> AlwaysBind
+ Just _ -> NeverBind
+
+bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
+ -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
+ -> RnM (b, FreeVars)
+bindRuleTyVars doc (Just bndrs) thing_inside
+ = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just)
+bindRuleTyVars _ _ thing_inside = thing_inside Nothing
{-
************************************************************************
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index e1e0c0a05b3..d7ad77dd671 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -825,6 +825,7 @@ wildCardsAllowed env
ExprWithTySigCtx {} -> True
PatCtx {} -> True
RuleCtx {} -> True
+ SpecECtx {} -> True
FamPatCtx {} -> True -- Not named wildcards though
GHCiCtx {} -> True
HsTypeCtx {} -> True
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index b4ef1359ddd..f48b0ae770e 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -24,25 +24,23 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
import GHC.Hs
-import GHC.Types.FieldLabel
-import GHC.Types.Name.Reader
+
import GHC.Rename.HsType
import GHC.Rename.Bind
import GHC.Rename.Doc
import GHC.Rename.Env
import GHC.Rename.Utils ( mapFvRn, bindLocalNames
, checkDupRdrNames, bindLocalNamesFV
- , checkShadowedRdrNames, warnUnusedTypePatterns
- , newLocalBndrsRn
+ , warnUnusedTypePatterns
, noNestedForallsContextsErr
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
import GHC.Rename.Names
+
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin ( TypedThing(..) )
-import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Unit
import GHC.Unit.Module.Warnings
import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
@@ -50,23 +48,29 @@ import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
, semigroupClassName, sappendName
, monoidClassName, mappendName
)
+
+import GHC.Types.FieldLabel
+import GHC.Types.Name.Reader
+import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Utils.Outputable
-import GHC.Types.Basic (VisArity)
-import GHC.Types.Basic ( TypeOrKind(..) )
-import GHC.Data.FastString
+import GHC.Types.Basic ( VisArity, TypeOrKind(..), RuleName )
+import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields)
+import GHC.Types.Unique.Set
import GHC.Types.SrcLoc as SrcLoc
+
import GHC.Driver.DynFlags
+import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
+
import GHC.Utils.Misc ( lengthExceeds, partitionWith )
import GHC.Utils.Panic
-import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
+import GHC.Utils.Outputable
+
+import GHC.Data.FastString
import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
-import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields)
-import GHC.Types.Unique.Set
import GHC.Data.OrdList
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.DataCon ( isSrcStrict )
@@ -1159,65 +1163,23 @@ rnHsRuleDecls (HsRules { rds_ext = (_, src)
, rds_rules = rn_rules }, fvs) }
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule { rd_ext = (_, st)
- , rd_name = rule_name
- , rd_act = act
- , rd_tyvs = tyvs
- , rd_tmvs = tmvs
- , rd_lhs = lhs
- , rd_rhs = rhs })
- = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
- ; checkDupRdrNames rdr_names_w_loc
- ; checkShadowedRdrNames rdr_names_w_loc
- ; names <- newLocalBndrsRn rdr_names_w_loc
- ; let doc = RuleCtx (unLoc rule_name)
- ; bindRuleTyVars doc tyvs $ \ tyvs' ->
- bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
+rnHsRuleDecl (HsRule { rd_ext = (_, st)
+ , rd_name = lrule_name@(L _ rule_name)
+ , rd_act = act
+ , rd_bndrs = bndrs
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
+ = bindRuleBndrs (RuleCtx rule_name) bndrs $ \tm_names bndrs' ->
do { (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
- ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'
- ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st)
- , rd_name = rule_name
- , rd_act = act
- , rd_tyvs = tyvs'
- , rd_tmvs = tmvs'
- , rd_lhs = lhs'
- , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
- where
- get_var :: RuleBndr GhcPs -> LocatedN RdrName
- get_var (RuleBndrSig _ v _) = v
- get_var (RuleBndr _ v) = v
-
-bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
- -> [LRuleBndr GhcPs] -> [Name]
- -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
- -> RnM (a, FreeVars)
-bindRuleTmVars doc tyvs vars names thing_inside
- = go vars names $ \ vars' ->
- bindLocalNamesFV names (thing_inside vars')
- where
- go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside
- = go vars ns $ \ vars' ->
- thing_inside (L l (RuleBndr noAnn (L loc n)) : vars')
-
- go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)
- (n : ns) thing_inside
- = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->
- go vars ns $ \ vars' ->
- thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars')
-
- go [] [] thing_inside = thing_inside []
- go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
-
- bind_free_tvs = case tyvs of Nothing -> AlwaysBind
- Just _ -> NeverBind
-
-bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
- -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
- -> RnM (b, FreeVars)
-bindRuleTyVars doc (Just bndrs) thing_inside
- = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just)
-bindRuleTyVars _ _ thing_inside = thing_inside Nothing
+ ; checkValidRule rule_name tm_names lhs' fv_lhs'
+ ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st)
+ , rd_name = lrule_name
+ , rd_act = act
+ , rd_bndrs = bndrs'
+ , rd_lhs = lhs'
+ , rd_rhs = rhs' }
+ , fv_lhs' `plusFV` fv_rhs') }
{-
Note [Rule LHS validity checking]
@@ -1244,7 +1206,7 @@ with the LHS wrapped in parens. But Template Haskell does (#24621)!
So we should accommodate them.
-}
-checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
+checkValidRule :: RuleName -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
checkValidRule rule_name ids lhs' fv_lhs'
= do { -- Check for the form of the LHS
case (validRuleLhs ids lhs') of
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index a4850a1ff17..f71008b297d 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -54,7 +54,7 @@ import GHC.Iface.Load ( loadSrcInterface )
import GHC.Iface.Syntax ( IfaceDefault, fromIfaceWarnings )
import GHC.Builtin.Names
import GHC.Parser.PostProcess ( setRdrNameSpace )
-import GHC.Core.Type
+import GHC.Core.TyCo.Tidy
import GHC.Core.PatSyn
import GHC.Core.TyCon ( TyCon, tyConName )
import qualified GHC.LanguageExtensions as LangExt
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index 37413a68f1d..ca09a673049 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -33,6 +33,7 @@ import GHC.Runtime.Context
import GHC.Iface.Syntax ( showToHeader )
import GHC.Iface.Env ( newInteractiveBinder )
import GHC.Core.Type
+import GHC.Core.TyCo.Tidy( tidyOpenType )
import GHC.Utils.Outputable
import GHC.Utils.Error
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 9420a9e2c2e..dcb6b98410e 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -72,6 +72,7 @@ import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst )
import GHC.Core.InstEnv
import GHC.Core.Predicate
import GHC.Core.TyCo.Ppr
+import GHC.Core.TyCo.Tidy( tidyType, tidyOpenTypes )
import GHC.Core.TyCon
import GHC.Core.Type hiding( typeKind )
import qualified GHC.Core.Type as Type
@@ -121,12 +122,11 @@ import GHC.Unit.Module.ModSummary
import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
-import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
+import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces )
import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Env (tcGetInstEnvs)
import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Utils.Monad
-import GHC.Tc.Zonk.Env ( ZonkFlexi (SkolemiseFlexi) )
import GHC.IfaceToCore
@@ -1072,8 +1072,9 @@ parseInstanceHead str = withSession $ \hsc_env0 -> do
(ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ty <- hscParseType str
- ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty
-
+ ioMsgMaybe $ hoistTcRnMessage $
+ tcRnTypeSkolemising hsc_env ty
+ -- I'm not sure what to do about those zonked skolems
return ty
-- Get all the constraints required of a dictionary binding
diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
index b340760bb0c..0bac82d34cd 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ b/compiler/GHC/Runtime/Heap/Inspect.hs
@@ -44,6 +44,7 @@ import GHCi.Message ( fromSerializableException )
import GHC.Core.DataCon
import GHC.Core.Type
+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped )
import GHC.Types.RepType
import GHC.Core.Multiplicity
import qualified GHC.Core.Unify as U
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index e0521ddcd9c..6ebd599e50b 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -43,6 +43,7 @@ import GHC.Types.Literal
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Core.Type
+import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped )
import GHC.Core.TyCo.Compare (eqType)
import GHC.Types.RepType
import GHC.Core.DataCon
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index d4e19259955..45412cb0b32 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -20,52 +20,56 @@ import GHC.Hs
import GHC.Driver.Session
import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Tc.Deriv.Infer
import GHC.Tc.Deriv.Utils
-import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )
-import GHC.Tc.Utils.Env
import GHC.Tc.Deriv.Generate
+import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )
import GHC.Tc.Validity( checkValidInstHead )
-import GHC.Core.InstEnv
-import GHC.Tc.Utils.Instantiate
-import GHC.Core.FamInstEnv
import GHC.Tc.Gen.HsType
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr ( pprTyVars )
-import GHC.Unit.Module.Warnings
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.Instantiate
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Utils.Env
import GHC.Rename.Bind
import GHC.Rename.Env
import GHC.Rename.Module ( addTcgDUs )
import GHC.Rename.Utils
+import GHC.Core.TyCo.Ppr ( pprTyVars )
+import GHC.Core.FamInstEnv
+import GHC.Core.InstEnv
import GHC.Core.Unify( tcUnifyTy )
import GHC.Core.Class
import GHC.Core.Type
-import GHC.Utils.Error
import GHC.Core.DataCon
-import GHC.Data.Maybe
+import GHC.Core.TyCon
+import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped )
+
import GHC.Types.Hint (AssumedDerivingStrategy(..))
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Name.Set as NameSet
-import GHC.Core.TyCon
-import GHC.Tc.Utils.TcType
import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
-import GHC.Builtin.Names
import GHC.Types.SrcLoc
+
+import GHC.Unit.Module.Warnings
+import GHC.Builtin.Names
+
+import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
-import GHC.Data.Bag
import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt
+
+import GHC.Data.Bag
+import GHC.Data.Maybe
import GHC.Data.BooleanFormula ( isUnsatisfied )
import Control.Monad
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index b6e8fa8cdd5..cdf14f10719 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -60,7 +60,7 @@ import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.TyCo.Ppr ( pprTyVars )
-import GHC.Core.TyCo.Tidy ( tidyAvoiding )
+import GHC.Core.TyCo.Tidy
import GHC.Core.InstEnv
import GHC.Core.TyCon
import GHC.Core.DataCon
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 16009860037..c500d6c2baa 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -64,6 +64,7 @@ import GHC.Core.TyCo.Rep (Type(..))
import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,
pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll)
import GHC.Core.PatSyn ( patSynName, pprPatSynType )
+import GHC.Core.TyCo.Tidy
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.FVs( orphNamesOfTypes )
@@ -1355,6 +1356,7 @@ instance Diagnostic TcRnMessage where
PatSynBind {} -> text "Pattern synonyms"
-- Associated pattern synonyms are not implemented yet
_ -> pprPanic "rnMethodBind" (ppr bind)
+
TcRnOrphanCompletePragma -> mkSimpleDecorated $
text "Orphan COMPLETE pragmas not supported" $$
text "A COMPLETE pragma must mention at least one data constructor" $$
@@ -1403,6 +1405,9 @@ instance Diagnostic TcRnMessage where
, text "Combine alternative minimal complete definitions with `|'" ]
where
sigs = sig1 : sig2 : otherSigs
+ TcRnSpecSigShape spec_e -> mkSimpleDecorated $
+ hang (text "Illegal form of SPECIALISE pragma:")
+ 2 (ppr spec_e)
TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $
text "Illegal standalone deriving declaration"
TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $
@@ -2397,6 +2402,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnOrphanCompletePragma{}
-> ErrorWithoutFlag
+ TcRnSpecSigShape{}
+ -> ErrorWithoutFlag
TcRnEmptyCase{}
-> ErrorWithoutFlag
TcRnNonStdGuards{}
@@ -3070,6 +3077,8 @@ instance Diagnostic TcRnMessage where
EmptyCaseWithoutFlag{} -> [suggestExtension LangExt.EmptyCase]
EmptyCaseDisallowedCtxt{} -> noHints
EmptyCaseForall{} -> noHints
+ TcRnSpecSigShape{}
+ -> noHints
TcRnNonStdGuards{}
-> [suggestExtension LangExt.PatternGuards]
TcRnDuplicateSigDecl{}
@@ -5591,6 +5600,7 @@ pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"
pprHsDocContext DefaultDeclCtx = text "a `default' declaration"
pprHsDocContext DerivDeclCtx = text "a deriving declaration"
pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name)
+pprHsDocContext (SpecECtx name) = text "the SPECIALISE pragma for" <+> quotes (ppr name)
pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon)
pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon)
pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 5a7840ba16c..67faa2199c4 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2606,6 +2606,7 @@ data TcRnMessage where
typecheck/should_compile/T10504
-}
TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage
+ -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540)
{-| TcRnSpecialiseNotVisible is a warning that occurs when the subject of a
SPECIALISE pragma has a definition that is not visible from the current module.
@@ -3187,6 +3188,14 @@ data TcRnMessage where
-}
TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage
+ {-| TcRnSpecSigShape is an error that occurs when the user writes a SPECIALISE
+ pragma that isn't just a function application.
+
+ Example:
+ {-# SPECIALISE let x=True in x #-}
+ -}
+ TcRnSpecSigShape :: LHsExpr GhcPs -> TcRnMessage
+
{-| 'TcRnIllegalInvisTyVarBndr' is an error that occurs
when invisible type variable binders in type declarations
are used without enabling the @TypeAbstractions@ extension.
@@ -5994,6 +6003,7 @@ data HsDocContext
| ForeignDeclCtx (LocatedN RdrName)
| DerivDeclCtx
| RuleCtx FastString
+ | SpecECtx RdrName
| TyDataCtx (LocatedN RdrName)
| TySynCtx (LocatedN RdrName)
| TyFamilyCtx (LocatedN RdrName)
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index b102607bc09..eb4ea696b71 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -59,8 +59,9 @@ import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Core.Class ( Class )
import GHC.Core.Coercion( mkSymCo )
-import GHC.Core.Type (mkStrLitTy, tidyOpenTypeX, mkCastTy)
+import GHC.Core.Type (mkStrLitTy, mkCastTy)
import GHC.Core.TyCo.Ppr( pprTyVars )
+import GHC.Core.TyCo.Tidy( tidyOpenTypeX )
import GHC.Builtin.Types ( mkConstraintTupleTy, multiplicityTy, oneDataConTy )
import GHC.Builtin.Types.Prim
@@ -912,9 +913,11 @@ mkExport prag_fn residual insoluble qtvs theta
; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty
-- NB: poly_id has a zonked type
- ; poly_id <- addInlinePrags poly_id prag_sigs
- ; spec_prags <- tcSpecPrags poly_id prag_sigs
- -- tcPrags requires a zonked poly_id
+ ; poly_id <- addInlinePrags poly_id prag_sigs
+ ; spec_prags <- tcExtendIdEnv1 poly_name poly_id $
+ tcSpecPrags poly_id prag_sigs
+ -- tcSpecPrags requires a zonked poly_id. It also needs poly_id to
+ -- be in the type env (so we can typecheck the SPECIALISE expression)
-- See Note [Impedance matching]
-- NB: we have already done checkValidType, including an ambiguity check,
@@ -1280,27 +1283,6 @@ The impedance matcher can do defaulting: in the above example, we default
to Integer because of Num. See #7173. If we're dealing with a nondefaultable
class, impedance matching can fail. See #23427.
-Note [SPECIALISE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-There is no point in a SPECIALISE pragma for a non-overloaded function:
- reverse :: [a] -> [a]
- {-# SPECIALISE reverse :: [Int] -> [Int] #-}
-
-But SPECIALISE INLINE *can* make sense for GADTS:
- data Arr e where
- ArrInt :: !Int -> ByteArray# -> Arr Int
- ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
-
- (!:) :: Arr e -> Int -> e
- {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
- {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
- (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
- (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
-
-When (!:) is specialised it becomes non-recursive, and can usefully
-be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
-for a non-overloaded function.
-
************************************************************************
* *
tcMonoBinds
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index ad9964d161f..d95e53693ff 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -68,7 +68,7 @@ module GHC.Tc.Gen.HsType (
tcMult,
-- Pattern type signatures
- tcHsPatSigType, tcHsTyPat,
+ tcHsPatSigType, tcHsTyPat, tcRuleBndrSig,
HoleMode(..),
-- Utils
@@ -4399,8 +4399,26 @@ tcHsPatSigType ctxt hole_mode
(HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }
, hsps_body = hs_ty })
ctxt_kind
- = tc_type_in_pat ctxt hole_mode hs_ty sig_wcs sig_ns ctxt_kind
-
+ = tc_type_in_pat ctxt Nothing hole_mode hs_ty sig_wcs sig_ns ctxt_kind
+
+tcRuleBndrSig :: Name
+ -> SkolemInfo
+ -> HsPatSigType GhcRn -- The type signature
+ -> TcM ( [(Name, TcTyVar)] -- Wildcards
+ , [(Name, TcTyVar)] -- The new bit of type environment, binding
+ -- the scoped type variables
+ , TcType) -- The type
+-- Used for type-checking type signatures in
+-- RULE forall bndrs e.g. forall (x::Int). f x = x
+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type
+--
+-- This may emit constraints
+-- See Note [Recipe for checking a signature]
+tcRuleBndrSig name skol_info
+ (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }
+ , hsps_body = hs_ty })
+ = tc_type_in_pat (RuleBndrTypeCtxt name) (Just skol_info)
+ HM_Sig hs_ty sig_wcs sig_ns OpenKind
-- Typecheck type patterns, in data constructor patterns, e.g
-- f (MkT @a @(Maybe b) ...) = ...
@@ -4423,7 +4441,7 @@ tcHsTyPat hs_pat@(HsTP{hstp_ext = hstp_rn, hstp_body = hs_ty}) expected_kind
where
all_ns = imp_ns ++ exp_ns
HsTPRn{hstp_nwcs = wcs, hstp_imp_tvs = imp_ns, hstp_exp_tvs = exp_ns} = hstp_rn
- tc_unif_in_pat = tc_type_in_pat TypeAppCtxt HM_TyAppPat
+ tc_unif_in_pat = tc_type_in_pat TypeAppCtxt Nothing HM_TyAppPat
-- `tc_bndr_in_pat` is used in type patterns to handle the binders case.
-- See Note [Type patterns: binders and unifiers]
@@ -4476,6 +4494,7 @@ tc_bndr_in_pat bndr wcs imp_ns expected_kind = do
--
-- * In patterns `tc_type_in_pat` is used to check pattern signatures.
tc_type_in_pat :: UserTypeCtxt
+ -> Maybe SkolemInfo -- Just sk for RULE and SPECIALISE pragmas only
-> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.
-> LHsType GhcRn -- The type in pattern
-> [Name] -- All named wildcards in type
@@ -4485,9 +4504,10 @@ tc_type_in_pat :: UserTypeCtxt
, [(Name, TcTyVar)] -- The new bit of type environment, binding
-- the scoped type variables
, TcType) -- The type
-tc_type_in_pat ctxt hole_mode hs_ty wcs ns ctxt_kind
+tc_type_in_pat ctxt mb_skol hole_mode hs_ty wcs ns ctxt_kind
= addSigCtxt ctxt (UserLHsType hs_ty) $
- do { tkv_prs <- mapM new_implicit_tv ns
+ do { tkvs <- mapM new_implicit_tv ns
+ ; let tkv_prs = ns `zip` tkvs
; mode <- mkHoleMode TypeLevel hole_mode
; (wcs, ty)
<- addTypeCtxt hs_ty $
@@ -4517,14 +4537,11 @@ tc_type_in_pat ctxt hole_mode hs_ty wcs ns ctxt_kind
where
new_implicit_tv name
= do { kind <- newMetaKindVar
- ; tv <- case ctxt of
- RuleSigCtxt rname _ -> do
- skol_info <- mkSkolemInfo (RuleSkol rname)
- newSkolemTyVar skol_info name kind
- _ -> newPatTyVar name kind
- -- See Note [Typechecking pattern signature binders]
- -- NB: tv's Name may be fresh (in the case of newPatTyVar)
- ; return (name, tv) }
+ ; case mb_skol of
+ Just skol_info -> newSkolemTyVar skol_info name kind
+ Nothing -> newPatTyVar name kind }
+ -- See Note [Typechecking pattern signature binders]
+ -- NB: tv's Name may be fresh (in the case of newPatTyVar)
-- See Note [Type patterns: binders and unifiers]
tyPatToBndr :: HsTyPat GhcRn -> Maybe (HsTyVarBndr () GhcRn)
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
deleted file mode 100644
index cc3253e7c47..00000000000
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ /dev/null
@@ -1,525 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1993-1998
-
--}
-
--- | Typechecking rewrite rules
-module GHC.Tc.Gen.Rule ( tcRules ) where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Tc.Types
-import GHC.Tc.Errors.Types ( ErrCtxtMsg(RuleCtxt) )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Solver.Solve( solveWanteds )
-import GHC.Tc.Solver.Monad ( runTcS )
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Gen.Expr
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Unify( buildImplicationFor )
-import GHC.Tc.Zonk.TcType
-
-import GHC.Core.Type
-import GHC.Core.Coercion( mkCoVarCo )
-import GHC.Core.TyCon( isTypeFamilyTyCon )
-import GHC.Core.Predicate
-
-import GHC.Types.Id
-import GHC.Types.Var( EvVar, tyVarName )
-import GHC.Types.Var.Set
-import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) )
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Data.FastString
-import GHC.Data.Bag
-
-{-
-Note [Typechecking rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We *infer* the typ of the LHS, and use that type to *check* the type of
-the RHS. That means that higher-rank rules work reasonably well. Here's
-an example (test simplCore/should_compile/rule2.hs) produced by Roman:
-
- foo :: (forall m. m a -> m b) -> m a -> m b
- foo f = ...
-
- bar :: (forall m. m a -> m a) -> m a -> m a
- bar f = ...
-
- {-# RULES "foo/bar" foo = bar #-}
-
-He wanted the rule to typecheck.
-
-Note [TcLevel in type checking rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Bringing type variables into scope naturally bumps the TcLevel. Thus, we type
-check the term-level binders in a bumped level, and we must accordingly bump
-the level whenever these binders are in scope.
-
-Note [Re-quantify type variables in rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this example from #17710:
-
- foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b
- foo x = Proxy
- {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-}
-
-Written out in more detail, the "foo" rewrite rule looks like this:
-
- forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0
-
-Where b0 is a unification variable. Where should b0 be quantified? We have to
-quantify it after k, since (b0 :: k). But generalization usually puts inferred
-type variables (such as b0) at the /front/ of the telescope! This creates a
-conflict.
-
-One option is to simply throw an error, per the principles of
-Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen
-if we were generalising over a normal type signature. On the other hand, the
-types in a rewrite rule aren't quite "normal", since the notions of specified
-and inferred type variables aren't applicable.
-
-A more permissive design (and the design that GHC uses) is to simply requantify
-all of the type variables. That is, we would end up with this:
-
- forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b
-
-It's a bit strange putting the generalized variable `b` after the user-written
-variables `k` and `a`. But again, the notion of specificity is not relevant to
-rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not
-only makes "foo" typecheck, but it also makes the implementation simpler.
-
-See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which
-explains a very similar design when generalising over a type family instance
-equation.
--}
-
-tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]
-tcRules decls = mapM (wrapLocMA tcRuleDecls) decls
-
-tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)
-tcRuleDecls (HsRules { rds_ext = src
- , rds_rules = decls })
- = do { maybe_tc_decls <- mapM (wrapLocMA tcRule) decls
- ; let tc_decls = [L loc rule | (L loc (Just rule)) <- maybe_tc_decls]
- ; return $ HsRules { rds_ext = src
- , rds_rules = tc_decls } }
-
-
-tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc))
-tcRule (HsRule { rd_ext = ext
- , rd_name = rname@(L _ name)
- , rd_act = act
- , rd_tyvs = ty_bndrs
- , rd_tmvs = tm_bndrs
- , rd_lhs = lhs
- , rd_rhs = rhs })
- = addErrCtxt (RuleCtxt name) $
- do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname)
- ; skol_info <- mkSkolemInfo (RuleSkol name)
- -- Note [Typechecking rules]
- ; (tc_lvl, stuff) <- pushTcLevelM $
- generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs
-
- ; let (id_bndrs, lhs', lhs_wanted
- , rhs', rhs_wanted, rule_ty) = stuff
-
- ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname
- , ppr lhs_wanted
- , ppr rhs_wanted ])
-
- ; (lhs_evs, residual_lhs_wanted, dont_default)
- <- simplifyRule name tc_lvl lhs_wanted rhs_wanted
-
- -- SimplifyRule Plan, step 4
- -- Now figure out what to quantify over
- -- c.f. GHC.Tc.Solver.simplifyInfer
- -- We quantify over any tyvars free in *either* the rule
- -- *or* the bound variables. The latter is important. Consider
- -- ss (x,(y,z)) = (x,z)
- -- RULE: forall v. fst (ss v) = fst v
- -- The type of the rhs of the rule is just a, but v::(a,(b,c))
- --
- -- We also need to get the completely-unconstrained tyvars of
- -- the LHS, lest they otherwise get defaulted to Any; but we do that
- -- during zonking (see GHC.Tc.Zonk.Type.zonkRule)
-
- ; let tpl_ids = lhs_evs ++ id_bndrs
-
- -- See Note [Re-quantify type variables in rules]
- ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)
- ; let weed_out = (`dVarSetMinusVarSet` dont_default)
- quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)
- , dv_tvs = weed_out (dv_tvs forall_tkvs) }
- ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands
- ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname
- , text "forall_tkvs:" <+> ppr forall_tkvs
- , text "quant_cands:" <+> ppr quant_cands
- , text "dont_default:" <+> ppr dont_default
- , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted
- , text "qtkvs:" <+> ppr qtkvs
- , text "rule_ty:" <+> ppr rule_ty
- , text "ty_bndrs:" <+> ppr ty_bndrs
- , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)
- , text "tpl_id info:" <+>
- vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]
- ])
-
- -- SimplfyRule Plan, step 5
- -- Simplify the LHS and RHS constraints:
- -- For the LHS constraints we must solve the remaining constraints
- -- (a) so that we report insoluble ones
- -- (b) so that we bind any soluble ones
- ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
- lhs_evs residual_lhs_wanted
- ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
- lhs_evs rhs_wanted
- ; emitImplications (lhs_implic `unionBags` rhs_implic)
-
- -- A type error on the LHS of a rule will be reported earlier while solving for
- -- lhs_implic. However, we should also drop the rule entirely for cases where
- -- compilation continues regardless of the error. For example with
- -- `-fdefer-type-errors`, where this ill-typed LHS rule may cause follow-on errors
- -- (#24026).
- ; if anyBag insolubleImplic lhs_implic
- then
- return Nothing -- The RULE LHS does not type-check and will be dropped.
- else
- return . Just $ HsRule { rd_ext = ext
- , rd_name = rname
- , rd_act = act
- , rd_tyvs = ty_bndrs -- preserved for ppr-ing
- , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)
- (qtkvs ++ tpl_ids)
- , rd_lhs = mkHsDictLet lhs_binds lhs'
- , rd_rhs = mkHsDictLet rhs_binds rhs' } }
-
-generateRuleConstraints :: FastString
- -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]
- -> LHsExpr GhcRn -> LHsExpr GhcRn
- -> TcM ( [TcId]
- , LHsExpr GhcTc, WantedConstraints
- , LHsExpr GhcTc, WantedConstraints
- , TcType )
-generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs
- = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $
- tcRuleBndrs rule_name ty_bndrs tm_bndrs
- -- bndr_wanted constraints can include wildcard hole
- -- constraints, which we should not forget about.
- -- It may mention the skolem type variables bound by
- -- the RULE. c.f. #10072
- ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $
- tcExtendIdEnv id_bndrs $
- do { -- See Note [Solve order for RULES]
- ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
- ; (rhs', rhs_wanted) <- captureConstraints $
- tcCheckMonoExpr rhs rule_ty
- ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
- ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
-
--- See Note [TcLevel in type checking rules]
-tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]
- -> TcM ([TcTyVar], [Id])
-tcRuleBndrs rule_name (Just bndrs) xs
- = do { skol_info <- mkSkolemInfo (RuleSkol rule_name)
- ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $
- tcRuleTmBndrs rule_name xs
- ; let tys1 = binderVars tybndrs1
- ; return (tys1 ++ tys2, tms) }
-
-tcRuleBndrs rule_name Nothing xs
- = tcRuleTmBndrs rule_name xs
-
--- See Note [TcLevel in type checking rules]
-tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
-tcRuleTmBndrs _ [] = return ([],[])
-tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
- = do { ty <- newOpenFlexiTyVarTy
- ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs
- ; return (tyvars, mkLocalId name ManyTy ty : tmvars) }
-tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
--- e.g x :: a->a
--- The tyvar 'a' is brought into scope first, just as if you'd written
--- a::*, x :: a->a
--- If there's an explicit forall, the renamer would have already reported an
--- error for each out-of-scope type variable used
- = do { let ctxt = RuleSigCtxt rule_name name
- ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind
- ; let id = mkLocalId name ManyTy id_ty
- -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
-
- -- The type variables scope over subsequent bindings; yuk
- ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
- tcRuleTmBndrs rule_name rule_bndrs
- ; return (map snd tvs ++ tyvars, id : tmvars) }
-
-{-
-*********************************************************************************
-* *
- Constraint simplification for rules
-* *
-***********************************************************************************
-
-Note [The SimplifyRule Plan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Example. Consider the following left-hand side of a rule
- f (x == y) (y > z) = ...
-If we typecheck this expression we get constraints
- d1 :: Ord a, d2 :: Eq a
-We do NOT want to "simplify" to the LHS
- forall x::a, y::a, z::a, d1::Ord a.
- f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
-Instead we want
- forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
- f ((==) d2 x y) ((>) d1 y z) = ...
-
-Here is another example:
- fromIntegral :: (Integral a, Num b) => a -> b
- {-# RULES "foo" fromIntegral = id :: Int -> Int #-}
-In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
-we *dont* want to get
- forall dIntegralInt.
- fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
-because the scsel will mess up RULE matching. Instead we want
- forall dIntegralInt, dNumInt.
- fromIntegral Int Int dIntegralInt dNumInt = id Int
-
-Even if we have
- g (x == y) (y == z) = ..
-where the two dictionaries are *identical*, we do NOT WANT
- forall x::a, y::a, z::a, d1::Eq a
- f ((==) d1 x y) ((>) d1 y z) = ...
-because that will only match if the dict args are (visibly) equal.
-Instead we want to quantify over the dictionaries separately.
-
-In short, simplifyRuleLhs must *only* squash equalities, leaving
-all dicts unchanged, with absolutely no sharing.
-
-Also note that we can't solve the LHS constraints in isolation:
-Example foo :: Ord a => a -> a
- foo_spec :: Int -> Int
- {-# RULE "foo" foo = foo_spec #-}
-Here, it's the RHS that fixes the type variable
-
-HOWEVER, under a nested implication things are different
-Consider
- f :: (forall a. Eq a => a->a) -> Bool -> ...
- {-# RULES "foo" forall (v::forall b. Eq b => b->b).
- f b True = ...
- #-}
-Here we *must* solve the wanted (Eq a) from the given (Eq a)
-resulting from skolemising the argument type of g. So we
-revert to SimplCheck when going under an implication.
-
-
---------- So the SimplifyRule Plan is this -----------------------
-
-* Step 0: typecheck the LHS and RHS to get constraints from each
-
-* Step 1: Simplify the LHS and RHS constraints all together in one bag,
- but /discarding/ the simplified constraints. We do this only
- to discover all unification equalities.
-
-* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take
- advantage of those unifications
-
-* Setp 3: Partition the LHS constraints into the ones we will
- quantify over, and the others.
- See Note [RULE quantification over equalities]
-
-* Step 4: Decide on the type variables to quantify over
-
-* Step 5: Simplify the LHS and RHS constraints separately, using the
- quantified constraints as givens
-
-Note [Solve order for RULES]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In step 1 above, we need to be a bit careful about solve order.
-Consider
- f :: Int -> T Int
- type instance T Int = Bool
-
- RULE f 3 = True
-
-From the RULE we get
- lhs-constraints: T Int ~ alpha
- rhs-constraints: Bool ~ alpha
-where 'alpha' is the type that connects the two. If we glom them
-all together, and solve the RHS constraint first, we might solve
-with alpha := Bool. But then we'd end up with a RULE like
-
- RULE: f 3 |> (co :: T Int ~ Bool) = True
-
-which is terrible. We want
-
- RULE: f 3 = True |> (sym co :: Bool ~ T Int)
-
-So we are careful to solve the LHS constraints first, and *then* the
-RHS constraints. Actually much of this is done by the on-the-fly
-constraint solving, so the same order must be observed in
-tcRule.
-
-
-Note [RULE quantification over equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Deciding which equalities to quantify over is tricky:
- * We do not want to quantify over insoluble equalities (Int ~ Bool)
- (a) because we prefer to report a LHS type error
- (b) because if such things end up in 'givens' we get a bogus
- "inaccessible code" error
-
- * But we do want to quantify over things like (a ~ F b), where
- F is a type function.
-
-The difficulty is that it's hard to tell what is insoluble!
-So we see whether the simplification step yielded any type errors,
-and if so refrain from quantifying over *any* equalities.
-
-Note [Quantifying over coercion holes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Equality constraints from the LHS will emit coercion hole Wanteds.
-These don't have a name, so we can't quantify over them directly.
-Instead, because we really do want to quantify here, invent a new
-EvVar for the coercion, fill the hole with the invented EvVar, and
-then quantify over the EvVar. Not too tricky -- just some
-impedance matching, really.
-
-Note [Simplify cloned constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At this stage, we're simplifying constraints only for insolubility
-and for unification. Note that all the evidence is quickly discarded.
-We use a clone of the real constraint. If we don't do this,
-then RHS coercion-hole constraints get filled in, only to get filled
-in *again* when solving the implications emitted from tcRule. That's
-terrible, so we avoid the problem by cloning the constraints.
-
--}
-
-simplifyRule :: RuleName
- -> TcLevel -- Level at which to solve the constraints
- -> WantedConstraints -- Constraints from LHS
- -> WantedConstraints -- Constraints from RHS
- -> TcM ( [EvVar] -- Quantify over these LHS vars
- , WantedConstraints -- Residual un-quantified LHS constraints
- , TcTyVarSet ) -- Don't default these
--- See Note [The SimplifyRule Plan]
--- NB: This consumes all simple constraints on the LHS, but not
--- any LHS implication constraints.
-simplifyRule name tc_lvl lhs_wanted rhs_wanted
- = do {
- -- Note [The SimplifyRule Plan] step 1
- -- First solve the LHS and *then* solve the RHS
- -- Crucially, this performs unifications
- -- Why clone? See Note [Simplify cloned constraints]
- ; lhs_clone <- cloneWC lhs_wanted
- ; rhs_clone <- cloneWC rhs_wanted
- ; (dont_default, _)
- <- setTcLevel tc_lvl $
- runTcS $
- do { lhs_wc <- solveWanteds lhs_clone
- ; _rhs_wc <- solveWanteds rhs_clone
- -- Why do them separately?
- -- See Note [Solve order for RULES]
-
- ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc
- -- If lhs_wanteds has
- -- (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc])
- -- we want r0 to be non-defaultable;
- -- see nonDefaultableTyVarsOfWC. Simplest way to get
- -- this is to look at the post-simplified lhs_wc, which
- -- will contain (rr[sk] ~ r0[conc)]. An example is in
- -- test rep-poly/RepPolyRule1
- ; return dont_default }
-
- -- Note [The SimplifyRule Plan] step 2
- ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted
- ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
-
- -- Note [The SimplifyRule Plan] step 3
- ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)
-
- ; traceTc "simplifyRule" $
- vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
- , text "lhs_wanted" <+> ppr lhs_wanted
- , text "rhs_wanted" <+> ppr rhs_wanted
- , text "quant_cts" <+> ppr quant_cts
- , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted
- , text "dont_default" <+> ppr dont_default
- ]
-
- ; return (quant_evs, residual_lhs_wanted, dont_default) }
-
- where
- mk_quant_ev :: Ct -> TcM EvVar
- mk_quant_ev ct
- | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct
- = case dest of
- EvVarDest ev_id -> return ev_id
- HoleDest hole -> -- See Note [Quantifying over coercion holes]
- do { ev_id <- newEvVar pred
- ; fillCoercionHole hole (mkCoVarCo ev_id)
- ; return ev_id }
- mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)
-
-
-getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
--- Extract all the constraints we can quantify over,
--- also returning the depleted WantedConstraints
---
--- NB: we must look inside implications, because with
--- -fdefer-type-errors we generate implications rather eagerly;
--- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.
---
--- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
--- and attempt to solve them from the quantified constraints. That
--- nearly works, but fails for a constraint like (d :: Eq Int).
--- We /do/ want to quantify over it, but the short-cut solver
--- (see GHC.Tc.Solver.Dict Note [Shortcut solving]) ignores the quantified
--- and instead solves from the top level.
---
--- So we must partition the WantedConstraints ourselves
--- Not hard, but tiresome.
-
-getRuleQuantCts wc
- = float_wc emptyVarSet wc
- where
- float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
- float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })
- = ( simple_yes `andCts` implic_yes
- , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })
- where
- (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples
- (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)
- emptyBag implics
-
- float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)
- float_implic skol_tvs yes1 imp
- = (yes1 `andCts` yes2, imp { ic_wanted = no })
- where
- (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)
- new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp
-
- rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool
- rule_quant_ct skol_tvs ct = case classifyPredType (ctPred ct) of
- EqPred _ t1 t2
- | not (ok_eq t1 t2)
- -> False -- Note [RULE quantification over equalities]
- _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs
-
- ok_eq t1 t2
- | t1 `tcEqType` t2 = False
- | otherwise = is_fun_app t1 || is_fun_app t2
-
- is_fun_app ty -- ty is of form (F tys) where F is a type function
- = case tyConAppTyCon_maybe ty of
- Just tc -> isTypeFamilyTyCon tc
- Nothing -> False
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index bbd47757b8e..2676708ed65 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -19,7 +19,9 @@ module GHC.Tc.Gen.Sig(
TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,
- addInlinePrags, addInlinePragArity
+ addInlinePrags, addInlinePragArity,
+
+ tcRules
) where
import GHC.Prelude
@@ -30,29 +32,39 @@ import GHC.Driver.Backend
import GHC.Hs
+import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcInferRho, tcCheckMonoExpr )
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.HsType
-import GHC.Tc.Types
-import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
+import GHC.Tc.Solver( reportUnsolvedEqualities, pushLevelAndSolveEqualitiesX
+ , emitResidualConstraints )
+import GHC.Tc.Solver.Solve( solveWanteds )
+import GHC.Tc.Solver.Monad( runTcS, runTcSSpecPrag )
+import GHC.Tc.Validity ( checkValidType )
+
import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep, newOpenTypeKind )
-import GHC.Tc.Zonk.Type
-import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
-import GHC.Tc.Validity ( checkValidType )
-import GHC.Tc.Utils.Unify( DeepSubsumptionFlag(..), tcSkolemise, unifyType )
+import GHC.Tc.Utils.TcMType
+import GHC.Tc.Utils.Unify( DeepSubsumptionFlag(..), tcSkolemise, unifyType, buildImplicationFor )
import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
-import GHC.Tc.Utils.Env( tcLookupId )
-import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
+import GHC.Tc.Utils.Env
+
+import GHC.Tc.Types.Origin
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Constraint
+
+import GHC.Tc.Zonk.TcType
+import GHC.Tc.Zonk.Type
import GHC.Core( hasSomeUnfolding )
-import GHC.Core.Type ( mkTyVarBinders )
+import GHC.Core.Type
import GHC.Core.Multiplicity
+import GHC.Core.Predicate
import GHC.Core.TyCo.Rep( mkNakedFunTy )
-import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )
-import GHC.Types.Id ( Id, idName, idType, setInlinePragma
+import GHC.Types.Var
+import GHC.Types.Var.Set
+import GHC.Types.Id ( idName, idType, setInlinePragma
, mkLocalId, realIdUnfolding )
import GHC.Types.Basic
import GHC.Types.Name
@@ -60,19 +72,19 @@ import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Builtin.Names( mkUnboundName )
-import GHC.Unit.Module( getModule )
+import GHC.Unit.Module( Module, getModule )
import GHC.Utils.Misc as Utils ( singleton )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Data.Bag
import GHC.Data.Maybe( orElse, whenIsJust )
import Data.Maybe( mapMaybe )
import qualified Data.List.NonEmpty as NE
import Control.Monad( unless )
-
{- -------------------------------------------------------------
Note [Overview of type signatures]
----------------------------------------------------------------
@@ -567,8 +579,9 @@ mkPragEnv sigs binds
prs = mapMaybe get_sig sigs
get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
- get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig)
- get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)
+ get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig)
+ get_sig sig@(L _ (SpecSigE nm _ _ _)) = Just (nm, add_arity nm sig)
+ get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)
get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig)
get_sig _ = Nothing
@@ -584,6 +597,7 @@ mkPragEnv sigs binds
addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl))
addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))
+addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl))
addInlinePragArity _ sig = sig
add_inl_arity :: Arity -> InlinePragma -> InlinePragma
@@ -650,13 +664,204 @@ should add the arity later for all binders. But it works fine like this.
* *
************************************************************************
-Note [Handling SPECIALISE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Overview of SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The basic idea is this:
foo :: Num a => a -> b -> a
- {-# SPECIALISE foo :: Int -> b -> Int #-}
+ foo = rhs
+ {-# SPECIALISE foo :: Int -> b -> Int #-} -- Old form
+ {-# SPECIALISE foo @Float #-} -- New form
+
+Generally:
+* Rename as usual
+* Typecheck, attaching info to the ABExport record of the AbsBinds for foo
+* Desugar by generating
+ - a specialised binding $sfoo = rhs @Float
+ - a rewrite rule like RULE "USPEC foo" foo @Float = $sfoo
+
+There are two major routes:
+
+* Old form
+ - Handled by `SpecSig` and `SpecPrag`
+ - Deals with SPECIALISE pragmas have multiple signatures
+ {-# SPECIALISE f :: Int -> Int, Float -> Float #-}
+ - See Note [Handling old-form SPECIALISE pragmas]
+ - Deprecated, to be removed in GHC 9.18 as per #25540.
+
+* New form, described in GHC Proposal #493
+ - Handled by `SpecSigE` and `SpecPragE`
+ - Deals with SPECIALISE pragmas which may have value arguments
+ {-# SPECIALISE f @Int 3 #-}
+ - See Note [Handling new-form SPECIALISE pragmas]
+
+Note [Handling new-form SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+New-form SPECIALISE pragmas are described by GHC Proposal #493.
+
+The pragma takes the form of a function application, possibly with intervening
+parens and type signatures, with a variable at the head:
+
+ {-# SPECIALISE f1 @Int 3 #-}
+ {-# SPECIALISE f2 :: Int -> Int #-}
+ {-# SPECIALISE (f3 :: Int -> Int) 5 #-}
+
+It may also have rule for-alls at the top, e.g.
+
+ {-# SPECIALISE forall x xs. f4 (x:xs) #-}
+ {-# SPECIALISE forall a. forall x xs. f5 @a @a (x:xs) #-}
+
+See `GHC.Rename.Bind.checkSpecESigShape` for the shape-check.
+
+Example:
+ f :: forall a b. (Eq a, Eq b, Eq c) => a -> b -> c -> Bool -> blah
+ {-# SPECIALISE forall x y. f (x::Int) y y True #-}
+ -- y::p
+
+We want to generate:
+
+ RULE forall @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p).
+ f @Int @p @p d1 d2 d3 x y y True
+ = $sf @p d2 x y
+ $sf @p (d2::Eq p) (x::Int) (y::p)
+ = let d1 = $fEqInt
+ d3 = d2
+ in <f-rhs> @p @p @Int (d1::Eq p) (d2::Eq p) (d3::Eq p) x y y True
+
+Note that
+
+* The `rule_bndrs`, over which the RULE is quantified, are all the variables
+ free in the call to `f`, /ignoring/ all dictionary simplification. Why?
+ Because we want to make the rule maximally applicable; provided the types
+ match, the dictionaries should match.
+
+ rule_bndrs = @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p).
+
+ Note that we have separate binders for `d1` and `d2` even though they are
+ the same (Eq p) dictionary. Reason: we don't want to force them to be visibly
+ equal at the call site.
+
+* The `spec_bnrs`, which are lambda-bound in the specialised function `$sf`,
+ are a subset of `rule_bndrs`.
+
+ spec_bndrs = @p (d2::Eq p) (x::Int) (y::p)
+
+* The `spec_const_binds` make up the difference between `rule_bndrs` and
+ `spec_bndrs`. They communicate the specialisation!
+ If `spec_bndrs` = `rule_bndrs`, no specialisation has happened.
+
+ spec_const_binds = let d1 = $fEqInt
+ d3 = d2
+
+This is done in three parts.
+
+ A. Typechecker: `GHC.Tc.Gen.Sig.tcSpecPrag`
+
+ (1) Typecheck the expression, capturing its constraints
+
+ (2) Solve these constraints, but in special TcSSpecPrag mode which ensures
+ each original Wanted is either fully solved or left untouched.
+ See Note [Fully solving constraints for specialisation].
+
+ (3) Compute the constraints to quantify over, using `getRuleQuantCts` on
+ the unsolved constraints returned by (2).
+
+ (4) Emit the residual (non-solved, non-quantified) constraints, and wrap the
+ expression in a let binding for those constraints.
+
+ (5) Wrap the call in the combined evidence bindings from steps (2) and (4)
+
+ (6) Store all the information in a 'SpecPragE' record, to be consumed
+ by the desugarer.
+
+ B. Zonker: `GHC.Tc.Zonk.Type.zonkLTcSpecPrags`
+
+ The zonker does a little extra work to collect any free type variables
+ of the LHS. See Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type.
+ These weren't conveniently available earlier.
+
+ C. Desugarer: `GHC.HsToCore.Binds.dsSpec`.
+
+ See Note [Desugaring new-form SPECIALISE pragmas] in GHC.HsToCore.Binds for details,
+ but in brief:
+
+ (1) Simplify the expression. This is important because a type signature in
+ the expression will have led to type/dictionary abstractions/applications.
+ After simplification it should look like
+ let <dict-binds> in f d1 d2 d3
+
+ (2) `prepareSpecLHS` identifies the `spec_const_binds`, discards the other
+ dictionary bindings, and decomposes the call.
+
+ (3) Then we build the specialised function $sf, and concoct a RULE
+ of the form:
+ forall @a @b d1 d2 d3. f d1 d2 d3 = $sf d1 d2 d3
+
+Note [Fully solving constraints for specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As far as specialisation is concerned, it is actively harmful to simplify
+constraints without /fully/ solving them.
+
+Example:
+
+ f :: ∀ a t. (Eq a, ∀x. Eq x => Eq (t x)). t a -> Char
+ {-# SPECIALISE f @Int #-}
+
+ Typechecking 'f' will result in [W] Eq Int, [W] ∀x. Eq x => Eq (t x).
+ We absolutely MUST leave the quantified constraint alone, because we want to
+ quantify over it. If we were to try to simplify it, we would emit an
+ implication and would thereafter never be able to quantify over the original
+ quantified constraint.
+
+ However, we still need to simplify quantified constraints that can be
+ /fully solved/ from instances, otherwise we would never be able to
+ specialise them away. Example: {-# SPECIALISE f @a @[] #-}.
+
+The conclusion is this:
+
+ when solving the constraints that arise from a specialise pragma, following
+ the recipe described in Note [Handling new-form SPECIALISE pragmas], all
+ Wanted quantified constraints should either be:
+ - fully solved (no free evidence variables), or
+ - left untouched.
+
+To achieve this, we run the solver in a special "all-or-nothing" solving mode,
+described in Note [TcSSpecPrag] in GHC.Tc.Solver.Monad.
+
+Note that a similar problem arises in other situations in which the solver takes
+an irreversible step, such as using a top-level class instance. This is currently
+less important, as the desugarer can handle these cases. To explain, consider:
+ g :: ∀ a. Eq a => a -> Bool
+ {-# SPECIALISE g @[e] #-}
+
+ Typechecking 'g' will result in [W] Eq [e]. Were we to simplify this to
+ [W] Eq e, we would have difficulty generating a RULE for the specialisation:
+
+ $sg :: Eq e => [e] -> Bool
+
+ RULE ∀ e (d :: Eq [e]). g @[e] d = $sg @e (??? :: Eq e)
+ -- Can't fill in ??? because we can't run instances in reverse.
+
+ RULE ∀ e (d :: Eq e). g @[e] ($fEqList @e d) = $sg @e d
+ -- Bad RULE matching template: matches on the structure of a dictionary
+
+ Moreover, there is no real benefit to any of this, because the specialiser
+ can't do anything useful from the knowledge that a dictionary for 'Eq [e]' is
+ constructed from a dictionary for 'Eq e' using the 'Eq' instance for lists.
+
+Here, it would make sense to also use the "solve completely" mechanism in the
+typechecker to avoid producing evidence terms that we can't "run in reverse".
+However, the current implementation tackles this issue in the desugarer, as is
+explained in Note [prepareSpecLHS] in GHC.HsToCore.Binds.
+So, for the time being at least, in TcSSpecPrag mode, we don't attempt to "fully solve"
+constraints when we use a top-level instance. This might change in the future,
+were we to decide to attempt to address [Shortcoming] in Note [prepareSpecLHS]
+in GHC.HsToCore.Binds.
+
+Note [Handling old-form SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: this code path is deprecated, and is scheduled to be removed in GHC 9.18, as per #25440.
We check that
(forall a b. Num a => a -> b -> a)
is more polymorphic than
@@ -749,6 +954,27 @@ Some wrinkles
regardless of XXX. It's sort of polymorphic in XXX. This is
useful: we use the same wrapper to transform each of the class ops, as
well as the dict. That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags
+
+Note [SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no point in a SPECIALISE pragma for a non-overloaded function:
+ reverse :: [a] -> [a]
+ {-# SPECIALISE reverse :: [Int] -> [Int] #-}
+
+But SPECIALISE INLINE *can* make sense for GADTS:
+ data Arr e where
+ ArrInt :: !Int -> ByteArray# -> Arr Int
+ ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
+
+ (!:) :: Arr e -> Int -> e
+ {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
+ {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
+ (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i)
+ (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i)
+
+When (!:) is specialised it becomes non-recursive, and can usefully
+be inlined. Scary! So we only warn for SPECIALISE *without* INLINE
+for a non-overloaded function.
-}
tcSpecPrags :: Id -> [LSig GhcRn]
@@ -775,7 +1001,7 @@ tcSpecPrags poly_id prag_sigs
--------------
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
--- See Note [Handling SPECIALISE pragmas]
+-- See Note [Handling old-form SPECIALISE pragmas]
--
-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
-- Example: SPECIALISE for a class method: the Name in the SpecSig is
@@ -798,19 +1024,80 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty
; return (SpecPrag poly_id wrap inl) }
+tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl)
+ -- For running commentary, see Note [Handling new-form SPECIALISE pragmas]
+ = do { -- (1) Typecheck the expression, spec_e, capturing its constraints
+ let skol_info_anon = SpecESkol nm
+ ; traceTc "tcSpecPrag SpecSigE {" (ppr nm $$ ppr spec_e)
+ ; skol_info <- mkSkolemInfo skol_info_anon
+ ; (rhs_tclvl, spec_e_wanted, (rule_bndrs', (tc_spec_e, _rho)))
+ <- tcRuleBndrs skol_info rule_bndrs $
+ tcInferRho spec_e
+
+ -- (2) Solve the resulting wanteds in TcSSpecPrag mode.
+ ; ev_binds_var <- newTcEvBinds
+ ; spec_e_wanted <- setTcLevel rhs_tclvl $
+ runTcSSpecPrag ev_binds_var $
+ solveWanteds spec_e_wanted
+ ; spec_e_wanted <- liftZonkM $ zonkWC spec_e_wanted
+
+ -- (3) Compute which constraints to quantify over, by looking
+ -- at the unsolved constraints from (2)
+ ; (quant_cands, residual_wc) <- getRuleQuantCts spec_e_wanted
+
+ -- (4) Emit the residual constraints (i.e. ones that we have
+ -- not solved in (2) nor quantified in (3)
+ -- NB: use the same `ev_binds_var` as (2), so the bindings
+ -- for (2) and (4) are combined
+ ; let tv_bndrs = filter isTyVar rule_bndrs'
+ qevs = map ctEvId (bagToList quant_cands)
+ ; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var
+ emptyVarSet tv_bndrs qevs
+ residual_wc
+
+ -- (5) Wrap the call in the combined evidence bindings
+ -- from steps (2) and (4)
+ ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) tc_spec_e
+
+ ; ev_binds <- getTcEvBindsMap ev_binds_var
+
+ ; traceTc "tcSpecPrag SpecSigE }" $
+ vcat [ text "nm:" <+> ppr nm
+ , text "rule_bndrs':" <+> ppr rule_bndrs'
+ , text "qevs:" <+> ppr qevs
+ , text "spec_e:" <+> ppr tc_spec_e
+ , text "inl:" <+> ppr inl
+ , text "spec_e_wanted:" <+> ppr spec_e_wanted
+ , text "quant_cands:" <+> ppr quant_cands
+ , text "residual_wc:" <+> ppr residual_wc
+ , text (replicate 80 '-')
+ , text "ev_binds_var:" <+> ppr ev_binds_var
+ , text "ev_binds:" <+> ppr ev_binds
+ ]
+
+ -- (6) Store the results in a SpecPragE record, which will be
+ -- zonked and then consumed by the desugarer.
+
+ ; return [SpecPragE { spe_fn_nm = nm
+ , spe_fn_id = poly_id
+ , spe_bndrs = qevs ++ rule_bndrs' -- Dependency order
+ -- does not matter
+ , spe_call = lhs_call
+ , spe_inl = inl }] }
+
tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
--------------
tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
-- A simpler variant of tcSubType, used for SPECIALISE pragmas
--- See Note [Handling SPECIALISE pragmas], wrinkle 1
+-- See Note [Handling old-form SPECIALISE pragmas], wrinkle 1
tcSpecWrapper ctxt poly_ty spec_ty
= do { (sk_wrap, inst_wrap)
<- tcSkolemise Shallow ctxt spec_ty $ \spec_tau ->
do { (inst_wrap, tau) <- topInstantiate orig poly_ty
; _ <- unifyType Nothing spec_tau tau
-- Deliberately ignore the evidence
- -- See Note [Handling SPECIALISE pragmas],
+ -- See Note [Handling old-form SPECIALISE pragmas],
-- wrinkle (2)
; return inst_wrap }
; return (sk_wrap <.> inst_wrap) }
@@ -821,15 +1108,13 @@ tcSpecWrapper ctxt poly_ty spec_ty
tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
-- SPECIALISE pragmas for imported things
tcImpPrags prags
- = do { this_mod <- getModule
- ; dflags <- getDynFlags
+ = do { dflags <- getDynFlags
+ ; traceTc "tcImpPrags1" (ppr prags)
; if (not_specialising dflags) then
return []
else do
- { pss <- mapAndRecoverM (wrapLocMA tcImpSpec)
- [L loc (name,prag)
- | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
- , not (nameIsLocalOrFrom this_mod name) ]
+ { this_mod <- getModule
+ ; pss <- mapAndRecoverM (wrapLocMA (tcImpSpec this_mod)) prags
; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } }
where
-- Ignore SPECIALISE pragmas for imported things
@@ -839,8 +1124,10 @@ tcImpPrags prags
not_specialising dflags =
not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags))
-tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
-tcImpSpec (name, prag)
+tcImpSpec :: Module -> Sig GhcRn -> TcM [TcSpecPrag]
+tcImpSpec this_mod prag
+ | Just name <- is_spec_prag prag -- It's a specialisation pragma
+ , not (nameIsLocalOrFrom this_mod name) -- The Id is imported
= do { id <- tcLookupId name
; if hasSomeUnfolding (realIdUnfolding id)
-- See Note [SPECIALISE pragmas for imported Ids]
@@ -848,6 +1135,12 @@ tcImpSpec (name, prag)
else do { let dia = TcRnSpecialiseNotVisible name
; addDiagnosticTc dia
; return [] } }
+ | otherwise
+ = return []
+ where
+ is_spec_prag (SpecSig _ (L _ nm) _ _) = Just nm
+ is_spec_prag (SpecSigE nm _ _ _) = Just nm
+ is_spec_prag _ = Nothing
{- Note [SPECIALISE pragmas for imported Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -866,3 +1159,459 @@ longer has an unfolding in the future. But then you'll get a helpful
error message suggesting an INLINABLE pragma, which you can follow.
That seems enough for now.
-}
+
+
+{- *********************************************************************
+* *
+ Rules
+* *
+************************************************************************
+
+Note [Typechecking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We *infer* the type of the LHS, and use that type to *check* the type of
+the RHS. That means that higher-rank rules work reasonably well. Here's
+an example (test simplCore/should_compile/rule2.hs) produced by Roman:
+
+ foo :: (forall m. m a -> m b) -> m a -> m b
+ foo f = ...
+
+ bar :: (forall m. m a -> m a) -> m a -> m a
+ bar f = ...
+
+ {-# RULES "foo/bar" foo = bar #-}
+
+He wanted the rule to typecheck.
+
+Note [TcLevel in type checking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Bringing type variables into scope naturally bumps the TcLevel. Thus, we type
+check the term-level binders in a bumped level, and we must accordingly bump
+the level whenever these binders are in scope.
+
+Note [Re-quantify type variables in rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this example from #17710:
+
+ foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b
+ foo x = Proxy
+ {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-}
+
+Written out in more detail, the "foo" rewrite rule looks like this:
+
+ forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0
+
+Where b0 is a unification variable. Where should b0 be quantified? We have to
+quantify it after k, since (b0 :: k). But generalization usually puts inferred
+type variables (such as b0) at the /front/ of the telescope! This creates a
+conflict.
+
+One option is to simply throw an error, per the principles of
+Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen
+if we were generalising over a normal type signature. On the other hand, the
+types in a rewrite rule aren't quite "normal", since the notions of specified
+and inferred type variables aren't applicable.
+
+A more permissive design (and the design that GHC uses) is to simply requantify
+all of the type variables. That is, we would end up with this:
+
+ forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b
+
+It's a bit strange putting the generalized variable `b` after the user-written
+variables `k` and `a`. But again, the notion of specificity is not relevant to
+rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not
+only makes "foo" typecheck, but it also makes the implementation simpler.
+
+See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which
+explains a very similar design when generalising over a type family instance
+equation.
+-}
+
+tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]
+tcRules decls = mapM (wrapLocMA tcRuleDecls) decls
+
+tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)
+tcRuleDecls (HsRules { rds_ext = src
+ , rds_rules = decls })
+ = do { maybe_tc_decls <- mapM (wrapLocMA tcRule) decls
+ ; let tc_decls = [L loc rule | (L loc (Just rule)) <- maybe_tc_decls]
+ ; return $ HsRules { rds_ext = src
+ , rds_rules = tc_decls } }
+
+tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc))
+tcRule (HsRule { rd_ext = ext
+ , rd_name = rname@(L _ name)
+ , rd_act = act
+ , rd_bndrs = bndrs
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
+ = addErrCtxt (RuleCtxt name) $
+ do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname)
+ ; skol_info <- mkSkolemInfo (RuleSkol name)
+ -- Note [Typechecking rules]
+ ; (tc_lvl, lhs_wanted, stuff)
+ <- tcRuleBndrs skol_info bndrs $
+ do { (lhs', rule_ty) <- tcInferRho lhs
+ ; (rhs', rhs_wanted) <- captureConstraints $
+ tcCheckMonoExpr rhs rule_ty
+ ; return (lhs', rule_ty, rhs', rhs_wanted) }
+
+ ; let (bndrs', (lhs', rule_ty, rhs', rhs_wanted)) = stuff
+
+ ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname
+ , ppr lhs_wanted
+ , ppr rhs_wanted ])
+
+ ; (lhs_evs, residual_lhs_wanted, dont_default)
+ <- simplifyRule name tc_lvl lhs_wanted rhs_wanted
+
+ -- SimplifyRule Plan, step 4
+ -- Now figure out what to quantify over
+ -- c.f. GHC.Tc.Solver.simplifyInfer
+ -- We quantify over any tyvars free in *either* the rule
+ -- *or* the bound variables. The latter is important. Consider
+ -- ss (x,(y,z)) = (x,z)
+ -- RULE: forall v. fst (ss v) = fst v
+ -- The type of the rhs of the rule is just a, but v::(a,(b,c))
+ --
+ -- We also need to get the completely-unconstrained tyvars of
+ -- the LHS, lest they otherwise get defaulted to Any; but we do that
+ -- during zonking (see GHC.Tc.Zonk.Type.zonkRule)
+
+ ; let tpl_ids = lhs_evs ++ filter isId bndrs'
+
+ -- See Note [Re-quantify type variables in rules]
+ ; dvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)
+ ; let weed_out = (`dVarSetMinusVarSet` dont_default)
+ weeded_dvs = weedOutCandidates weed_out dvs
+ ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs
+ ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname
+ , text "dvs:" <+> ppr dvs
+ , text "weeded_dvs:" <+> ppr weeded_dvs
+ , text "dont_default:" <+> ppr dont_default
+ , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted
+ , text "qtkvs:" <+> ppr qtkvs
+ , text "rule_ty:" <+> ppr rule_ty
+ , text "bndrs:" <+> ppr bndrs
+ , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)
+ , text "tpl_id info:" <+>
+ vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]
+ ])
+
+ -- SimplfyRule Plan, step 5
+ -- Simplify the LHS and RHS constraints:
+ -- For the LHS constraints we must solve the remaining constraints
+ -- (a) so that we report insoluble ones
+ -- (b) so that we bind any soluble ones
+ ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
+ lhs_evs residual_lhs_wanted
+ ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
+ lhs_evs rhs_wanted
+ ; emitImplications (lhs_implic `unionBags` rhs_implic)
+
+ ; return $ Just $ HsRule { rd_ext = ext
+ , rd_name = rname
+ , rd_act = act
+ , rd_bndrs = bndrs { rb_ext = qtkvs ++ tpl_ids }
+ , rd_lhs = mkHsDictLet lhs_binds lhs'
+ , rd_rhs = mkHsDictLet rhs_binds rhs' } }
+
+{- ********************************************************************************
+* *
+ tcRuleBndrs
+* *
+******************************************************************************** -}
+
+tcRuleBndrs :: SkolemInfo -> RuleBndrs GhcRn
+ -> TcM a -- Typecheck this with the rule binders in scope
+ -> TcM (TcLevel, WantedConstraints, ([Var], a))
+ -- The [Var] are the explicitly-quantified variables,
+ -- both type variables and term variables
+tcRuleBndrs skol_info (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tm_bndrs })
+ thing_inside
+ = pushLevelAndCaptureConstraints $
+ case mb_tv_bndrs of
+ Nothing -> go_tms tm_bndrs thing_inside
+ Just tv_bndrs -> do { (bndrs1, (bndrs2, res)) <- go_tvs tv_bndrs $
+ go_tms tm_bndrs $
+ thing_inside
+ ; return (binderVars bndrs1 ++ bndrs2, res) }
+ where
+ --------------
+ go_tvs tvs thing_inside = bindExplicitTKBndrs_Skol skol_info tvs thing_inside
+
+ --------------
+ go_tms [] thing_inside
+ = do { res <- thing_inside; return ([], res) }
+ go_tms (L _ (RuleBndr _ (L _ name)) : rule_bndrs) thing_inside
+ = do { ty <- newOpenFlexiTyVarTy
+ ; let bndr_id = mkLocalId name ManyTy ty
+ ; (bndrs, res) <- tcExtendIdEnv [bndr_id] $
+ go_tms rule_bndrs thing_inside
+ ; return (bndr_id : bndrs, res) }
+
+ go_tms (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) thing_inside
+ -- e.g x :: a->a
+ -- The tyvar 'a' is brought into scope first, just as if you'd written
+ -- a::*, x :: a->a
+ -- If there's an explicit forall, the renamer would have already reported an
+ -- error for each out-of-scope type variable used
+ = do { (_ , tv_prs, id_ty) <- tcRuleBndrSig name skol_info rn_ty
+ ; let bndr_id = mkLocalId name ManyTy id_ty
+ -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
+
+ -- The type variables scope over subsequent bindings; yuk
+ ; (bndrs, res) <- tcExtendNameTyVarEnv tv_prs $
+ tcExtendIdEnv [bndr_id] $
+ go_tms rule_bndrs thing_inside
+ ; return (map snd tv_prs ++ bndr_id : bndrs, res) }
+
+
+{-
+*********************************************************************************
+* *
+ Constraint simplification for rules
+* *
+***********************************************************************************
+
+Note [The SimplifyRule Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example. Consider the following left-hand side of a rule
+ f (x == y) (y > z) = ...
+If we typecheck this expression we get constraints
+ d1 :: Ord a, d2 :: Eq a
+We do NOT want to "simplify" to the LHS
+ forall x::a, y::a, z::a, d1::Ord a.
+ f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
+Instead we want
+ forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
+ f ((==) d2 x y) ((>) d1 y z) = ...
+
+Here is another example:
+ fromIntegral :: (Integral a, Num b) => a -> b
+ {-# RULES "foo" fromIntegral = id :: Int -> Int #-}
+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
+we *dont* want to get
+ forall dIntegralInt.
+ fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
+because the scsel will mess up RULE matching. Instead we want
+ forall dIntegralInt, dNumInt.
+ fromIntegral Int Int dIntegralInt dNumInt = id Int
+
+Even if we have
+ g (x == y) (y == z) = ..
+where the two dictionaries are *identical*, we do NOT WANT
+ forall x::a, y::a, z::a, d1::Eq a
+ f ((==) d1 x y) ((>) d1 y z) = ...
+because that will only match if the dict args are (visibly) equal.
+Instead we want to quantify over the dictionaries separately.
+
+In short, simplifyRuleLhs must *only* squash equalities, leaving
+all dicts unchanged, with absolutely no sharing.
+
+Also note that we can't solve the LHS constraints in isolation:
+Example foo :: Ord a => a -> a
+ foo_spec :: Int -> Int
+ {-# RULE "foo" foo = foo_spec #-}
+Here, it's the RHS that fixes the type variable
+
+HOWEVER, under a nested implication things are different
+Consider
+ f :: (forall a. Eq a => a->a) -> Bool -> ...
+ {-# RULES "foo" forall (v::forall b. Eq b => b->b).
+ f b True = ...
+ #-}
+Here we *must* solve the wanted (Eq a) from the given (Eq a)
+resulting from skolemising the argument type of g. So we
+revert to SimplCheck when going under an implication.
+
+
+--------- So the SimplifyRule Plan is this -----------------------
+
+* Step 0: typecheck the LHS and RHS to get constraints from each
+
+* Step 1: Simplify the LHS and RHS constraints all together in one bag,
+ but /discarding/ the simplified constraints. We do this only
+ to discover all unification equalities.
+
+* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take
+ advantage of those unifications
+
+* Step 3: Partition the LHS constraints into the ones we will
+ quantify over, and the others.
+ See Note [RULE quantification over equalities]
+
+* Step 4: Decide on the type variables to quantify over
+
+* Step 5: Simplify the LHS and RHS constraints separately, using the
+ quantified constraints as givens
+
+Note [Solve order for RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In step 1 above, we need to be a bit careful about solve order.
+Consider
+ f :: Int -> T Int
+ type instance T Int = Bool
+
+ RULE f 3 = True
+
+From the RULE we get
+ lhs-constraints: T Int ~ alpha
+ rhs-constraints: Bool ~ alpha
+where 'alpha' is the type that connects the two. If we glom them
+all together, and solve the RHS constraint first, we might solve
+with alpha := Bool. But then we'd end up with a RULE like
+
+ RULE: f 3 |> (co :: T Int ~ Bool) = True
+
+which is terrible. We want
+
+ RULE: f 3 = True |> (sym co :: Bool ~ T Int)
+
+So we are careful to solve the LHS constraints first, and *then* the
+RHS constraints. Actually much of this is done by the on-the-fly
+constraint solving, so the same order must be observed in
+tcRule.
+
+
+Note [RULE quantification over equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment a RULE never quantifies over an equality; see `rule_quant_ct`
+in `getRuleQuantCts`. Why not?
+
+ * It's not clear why we would want to do so (see Historical Note
+ below)
+
+ * We do not want to quantify over insoluble equalities (Int ~ Bool)
+ (a) because we prefer to report a LHS type error
+ (b) because if such things end up in 'givens' we get a bogus
+ "inaccessible code" error
+
+ * Equality constraints are unboxed, and that leads to complications
+ For example equality constraints from the LHS will emit coercion hole
+ Wanteds. These don't have a name, so we can't quantify over them directly.
+ Instead, in `getRuleQuantCts`, we'd have to invent a new EvVar for the
+ coercion, fill the hole with the invented EvVar, and then quantify over the
+ EvVar. Here is old code from `mk_one`
+ do { ev_id <- newEvVar pred
+ ; fillCoercionHole hole (mkCoVarCo ev_id)
+ ; return ev_id }
+ But that led to new complications becuase of the side effect on the coercion
+ hole. Much easier just to side-step the issue entirely by not quantifying over
+ equalities.
+
+Historical Note:
+ Back in 2012 (5aa1ae24567) we started quantifying over some equality
+ constraints, saying
+ * But we do want to quantify over things like (a ~ F b),
+ where F is a type function.
+ It is not clear /why/ we did so, and we don't do so any longer.
+End of historical note.
+
+Note [Simplify cloned constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At this stage, we're simplifying constraints only for insolubility
+and for unification. Note that all the evidence is quickly discarded.
+We use a clone of the real constraint. If we don't do this,
+then RHS coercion-hole constraints get filled in, only to get filled
+in *again* when solving the implications emitted from tcRule. That's
+terrible, so we avoid the problem by cloning the constraints.
+
+-}
+
+simplifyRule :: RuleName
+ -> TcLevel -- Level at which to solve the constraints
+ -> WantedConstraints -- Constraints from LHS
+ -> WantedConstraints -- Constraints from RHS
+ -> TcM ( [EvVar] -- Quantify over these LHS vars
+ , WantedConstraints -- Residual un-quantified LHS constraints
+ , TcTyVarSet ) -- Don't default these
+-- See Note [The SimplifyRule Plan]
+-- NB: This consumes all simple constraints on the LHS, but not
+-- any LHS implication constraints.
+simplifyRule name tc_lvl lhs_wanted rhs_wanted
+ = do {
+ -- Note [The SimplifyRule Plan] step 1
+ -- First solve the LHS and *then* solve the RHS
+ -- Crucially, this performs unifications
+ -- Why clone? See Note [Simplify cloned constraints]
+ ; lhs_clone <- cloneWC lhs_wanted
+ ; rhs_clone <- cloneWC rhs_wanted
+ ; (dont_default, _)
+ <- setTcLevel tc_lvl $
+ runTcS $
+ do { lhs_wc <- solveWanteds lhs_clone
+ ; _rhs_wc <- solveWanteds rhs_clone
+ -- Why do them separately?
+ -- See Note [Solve order for RULES]
+
+ ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc
+ -- If lhs_wanteds has
+ -- (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc])
+ -- we want r0 to be non-defaultable;
+ -- see nonDefaultableTyVarsOfWC. Simplest way to get
+ -- this is to look at the post-simplified lhs_wc, which
+ -- will contain (rr[sk] ~ r0[conc)]. An example is in
+ -- test rep-poly/RepPolyRule1
+ ; return dont_default }
+
+ -- Note [The SimplifyRule Plan] step 2
+ ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted
+
+ -- Note [The SimplifyRule Plan] step 3
+ ; (quant_cts, residual_lhs_wanted) <- getRuleQuantCts lhs_wanted
+ ; let quant_evs = map ctEvId (bagToList quant_cts)
+
+ ; traceTc "simplifyRule" $
+ vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
+ , text "lhs_wanted" <+> ppr lhs_wanted
+ , text "rhs_wanted" <+> ppr rhs_wanted
+ , text "quant_cts" <+> ppr quant_evs
+ , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted
+ , text "dont_default" <+> ppr dont_default
+ ]
+
+ ; return (quant_evs, residual_lhs_wanted, dont_default) }
+
+getRuleQuantCts :: WantedConstraints -> TcM (Cts, WantedConstraints)
+-- Extract all the constraints that we can quantify over,
+-- also returning the depleted WantedConstraints
+--
+-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
+-- and attempt to solve them from the quantified constraints. Instead
+-- we /partition/ the WantedConstraints into ones to quantify and ones
+-- we can't quantify. We could use approximateWC instead, and leave
+-- `wanted` unchanged; but then we'd have to clone fresh binders and
+-- generate silly identity bindings. Seems more direct to do this.
+-- Probably not a big deal wither way.
+--
+-- NB: we must look inside implications, because with
+-- -fdefer-type-errors we generate implications rather eagerly;
+-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.
+
+getRuleQuantCts wc
+ = return $ float_wc emptyVarSet wc
+ where
+ float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
+ float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })
+ = ( simple_yes `andCts` implic_yes
+ , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })
+ where
+ (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples
+ (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) emptyBag implics
+
+ float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)
+ float_implic skol_tvs yes1 imp
+ = (yes1 `andCts` yes2, imp { ic_wanted = no })
+ where
+ (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)
+ new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp
+
+ rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool
+ rule_quant_ct skol_tvs ct
+ | insolubleWantedCt ct
+ = False
+ | otherwise
+ = case classifyPredType (ctPred ct) of
+ EqPred {} -> False -- Note [RULE quantification over equalities]
+ _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 75b57149324..3a178d73db3 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -16,7 +16,8 @@
--
-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker
module GHC.Tc.Module (
- tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
+ tcRnStmt, tcRnExpr, TcRnExprMode(..),
+ tcRnType, tcRnTypeSkolemising,
tcRnImportDecls,
tcRnLookupRdrName,
getModuleInterface,
@@ -71,7 +72,7 @@ import GHC.Tc.Gen.Annotation
import GHC.Tc.Gen.Bind
import GHC.Tc.Gen.Default
import GHC.Tc.Utils.Env
-import GHC.Tc.Gen.Rule
+import GHC.Tc.Gen.Sig( tcRules )
import GHC.Tc.Gen.Foreign
import GHC.Tc.TyCl.Instance
import GHC.Tc.Utils.TcMType
@@ -115,6 +116,7 @@ import GHC.Core.Class
import GHC.Core.Coercion.Axiom
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.TyCo.Ppr( debugPprType )
+import GHC.Core.TyCo.Tidy( tidyTopType )
import GHC.Core.FamInstEnv
( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst
, famInstEnvElts, extendFamInstEnvList, normaliseType )
@@ -184,6 +186,7 @@ import qualified Data.Set as S
import qualified Data.Map as M
import Data.Foldable ( for_ )
import Data.Traversable ( for )
+import Data.IORef( newIORef )
@@ -2680,6 +2683,16 @@ tcRnImportDecls hsc_env import_decls
where
zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
+
+tcRnTypeSkolemising :: HscEnv
+ -> LHsType GhcPs
+ -> IO (Messages TcRnMessage, Maybe (Type, Kind))
+-- tcRnTypeSkolemising skolemisese any free unification variables,
+-- and normalises the type
+tcRnTypeSkolemising env ty
+ = do { skol_tv_ref <- liftIO (newIORef [])
+ ; tcRnType env (SkolemiseFlexi skol_tv_ref) True ty }
+
-- tcRnType just finds the kind of a type
tcRnType :: HscEnv
-> ZonkFlexi
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index 0bdf9bdf735..c4771cc79d5 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -16,7 +16,7 @@ module GHC.Tc.Solver(
tcNormalise,
approximateWC, -- Exported for plugins to use
- captureTopConstraints,
+ captureTopConstraints, emitResidualConstraints,
simplifyTopWanteds,
@@ -231,7 +231,7 @@ simplifyAndEmitFlatConstraints wanted
-- it's OK to use unkSkol | we must increase the TcLevel,
-- because we don't bind | as explained in
-- any skolem variables here | Note [Wrapping failing kind equalities]
- ; emitImplication implic
+ ; TcM.emitImplication implic
; failM }
Just (simples, errs)
-> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)
@@ -968,14 +968,17 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds
; bound_theta_vars <- mapM TcM.newEvVar bound_theta
; let full_theta = map idType bound_theta_vars
- ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkPhiTy full_theta ty)
- | (name, ty) <- name_taus ])
+ skol_info = InferSkol [ (name, mkPhiTy full_theta ty)
+ | (name, ty) <- name_taus ]
+ -- mkPhiTy: we don't add the quantified variables here, because
+ -- they are also bound in ic_skols and we want them to be tidied
+ -- uniformly.
}
-- Now emit the residual constraint
- ; emitResidualConstraints rhs_tclvl ev_binds_var
- name_taus co_vars qtvs bound_theta_vars
+ ; emitResidualConstraints rhs_tclvl skol_info ev_binds_var
+ co_vars qtvs bound_theta_vars
wanted_transformed
-- All done!
@@ -992,13 +995,12 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds
partial_sigs = filter isPartialSig sigs
--------------------
-emitResidualConstraints :: TcLevel -> EvBindsVar
- -> [(Name, TcTauType)]
+emitResidualConstraints :: TcLevel -> SkolemInfoAnon -> EvBindsVar
-> CoVarSet -> [TcTyVar] -> [EvVar]
-> WantedConstraints -> TcM ()
-- Emit the remaining constraints from the RHS.
-emitResidualConstraints rhs_tclvl ev_binds_var
- name_taus co_vars qtvs full_theta_vars wanteds
+emitResidualConstraints rhs_tclvl skol_info ev_binds_var
+ co_vars qtvs full_theta_vars wanteds
| isEmptyWC wanteds
= return ()
@@ -1031,13 +1033,6 @@ emitResidualConstraints rhs_tclvl ev_binds_var
; emitConstraints (emptyWC { wc_simple = outer_simple
, wc_impl = implics }) }
- where
- full_theta = map idType full_theta_vars
- skol_info = InferSkol [ (name, mkPhiTy full_theta ty)
- | (name, ty) <- name_taus ]
- -- We don't add the quantified variables here, because they are
- -- also bound in ic_skols and we want them to be tidied
- -- uniformly.
--------------------
findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType
@@ -1286,7 +1281,7 @@ decideQuantification
:: TopLevelFlag
-> TcLevel
-> InferMode
- -> SkolemInfo
+ -> SkolemInfoAnon
-> [(Name, TcTauType)] -- Variables to be generalised
-> [TcIdSigInst] -- Partial type signatures (if any)
-> WantedConstraints -- Candidate theta; already zonked
@@ -1818,13 +1813,13 @@ defaultTyVarsAndSimplify rhs_tclvl candidates
------------------
decideQuantifiedTyVars
- :: SkolemInfo
+ :: SkolemInfoAnon
-> [(Name,TcType)] -- Annotated theta and (name,tau) pairs
-> [TcIdSigInst] -- Partial signatures
-> [PredType] -- Candidates, zonked
-> TcM [TyVar]
-- Fix what tyvars we are going to quantify over, and quantify them
-decideQuantifiedTyVars skol_info name_taus psigs candidates
+decideQuantifiedTyVars skol_info_anon name_taus psigs candidates
= do { -- Why psig_tys? We try to quantify over everything free in here
-- See Note [Quantification and partial signatures]
-- Wrinkles 2 and 3
@@ -1843,20 +1838,19 @@ decideQuantifiedTyVars skol_info name_taus psigs candidates
-- The psig_tys are first in seed_tys, then candidates, then tau_tvs.
-- This makes candidateQTyVarsOfTypes produces them in that order, so that the
-- final qtvs quantifies in the same- order as the partial signatures do (#13524)
- ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
- <- candidateQTyVarsOfTypes $
- psig_tys ++ candidates ++ tau_tys
- ; let pick = (`dVarSetIntersectVarSet` grown_tcvs)
- dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
+ ; dvs <- candidateQTyVarsOfTypes (psig_tys ++ candidates ++ tau_tys)
+ ; let dvs_plus = weedOutCandidates (`dVarSetIntersectVarSet` grown_tcvs) dvs
; traceTc "decideQuantifiedTyVars" (vcat
- [ text "candidates =" <+> ppr candidates
- , text "cand_kvs =" <+> ppr cand_kvs
- , text "cand_tvs =" <+> ppr cand_tvs
- , text "seed_tys =" <+> ppr seed_tvs
+ [ text "tau_tys =" <+> ppr tau_tys
+ , text "candidates =" <+> ppr candidates
+ , text "dvs =" <+> ppr dvs
+ , text "tau_tys =" <+> ppr tau_tys
+ , text "seed_tvs =" <+> ppr seed_tvs
, text "grown_tcvs =" <+> ppr grown_tcvs
, text "dvs =" <+> ppr dvs_plus])
+ ; skol_info <- mkSkolemInfo skol_info_anon
; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus }
------------------
diff --git a/compiler/GHC/Tc/Solver/Default.hs b/compiler/GHC/Tc/Solver/Default.hs
index 2e16ddabb97..d1320e051eb 100644
--- a/compiler/GHC/Tc/Solver/Default.hs
+++ b/compiler/GHC/Tc/Solver/Default.hs
@@ -33,6 +33,7 @@ import GHC.Core.Unify ( tcMatchTyKis )
import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Core.TyCon ( TyCon )
+import GHC.Core.TyCo.Tidy
import GHC.Types.DefaultEnv ( ClassDefaults (..), defaultList )
import GHC.Types.Unique.Set
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs
index c14e032d449..36ad82c0837 100644
--- a/compiler/GHC/Tc/Solver/Dict.hs
+++ b/compiler/GHC/Tc/Solver/Dict.hs
@@ -62,7 +62,6 @@ import Control.Monad.Trans.Maybe( MaybeT, runMaybeT )
import Control.Monad.Trans.Class( lift )
import Control.Monad
-
{- *********************************************************************
* *
* Class Canonicalization
@@ -101,26 +100,6 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
; simpleStage (updInertDicts dict_ct)
; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" }
-updInertDicts :: DictCt -> TcS ()
-updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
- = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
-
- ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
- -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
- -- Update /both/ inert_cans /and/ inert_solved_dicts.
- updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
- inerts { inert_cans = updDicts (filterDicts (not_ip_for str_ty)) ics
- , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved }
- | otherwise
- -> return ()
-
- -- Add the new constraint to the inert set
- ; updInertCans (updDicts (addDict dict_ct)) }
- where
- not_ip_for :: Type -> DictCt -> Bool
- not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not (mentionsIP str_ty cls tys)
-
canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt
-- Once-only processing of Dict constraints:
-- * expand superclasses
diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs
index 3d3f8b295f5..fda755da648 100644
--- a/compiler/GHC/Tc/Solver/InertSet.hs
+++ b/compiler/GHC/Tc/Solver/InertSet.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
@@ -24,6 +25,8 @@ module GHC.Tc.Solver.InertSet (
InertEqs,
foldTyEqs, delEq, findEq,
partitionInertEqs, partitionFunEqs,
+ filterInertEqs, filterFunEqs,
+ inertGivens,
foldFunEqs, addEqToCans,
-- * Inert Dicts
@@ -73,10 +76,9 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Bag
-import Data.List.NonEmpty ( NonEmpty(..), (<|) )
-import Data.Function ( on )
-
import Control.Monad ( forM_ )
+import Data.List.NonEmpty ( NonEmpty(..), (<|) )
+import Data.Function ( on )
{-
************************************************************************
@@ -390,7 +392,6 @@ emptyInert
, inert_famapp_cache = emptyFunEqs
, inert_solved_dicts = emptyDictMap }
-
{- Note [Solved dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we apply a top-level instance declaration, we add the "solved"
@@ -1377,6 +1378,17 @@ addInertEqs :: EqCt -> InertEqs -> InertEqs
addInertEqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) eqs = addTyEq eqs tv eq_ct
addInertEqs other _ = pprPanic "extendInertEqs" (ppr other)
+-- | Filter InertEqs according to a predicate
+filterInertEqs :: (EqCt -> Bool) -> InertEqs -> InertEqs
+filterInertEqs f = mapMaybeDVarEnv g
+ where
+ g xs =
+ let filtered = filter f xs
+ in
+ if null filtered
+ then Nothing
+ else Just filtered
+
------------------------
addCanFunEq :: InertFunEqs -> TyCon -> [TcType] -> EqCt -> InertFunEqs
@@ -1400,7 +1412,16 @@ addFunEqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args }) fun_eqs
= addCanFunEq fun_eqs tc args eq_ct
addFunEqs other _ = pprPanic "extendFunEqs" (ppr other)
-
+-- | Filter entries in InertFunEqs that satisfy the predicate
+filterFunEqs :: (EqCt -> Bool) -> InertFunEqs -> InertFunEqs
+filterFunEqs f = mapMaybeTcAppMap g
+ where
+ g xs =
+ let filtered = filter f xs
+ in
+ if null filtered
+ then Nothing
+ else Just filtered
{- *********************************************************************
* *
@@ -2214,3 +2235,44 @@ Wrong! The level-check ensures that the inner implicit parameter wins.
(Actually I think that the order in which the work-list is processed means
that this chain of events won't happen, but that's very fragile.)
-}
+
+{- *********************************************************************
+* *
+ Extracting Givens from the inert set
+* *
+********************************************************************* -}
+
+
+-- | Extract only Given constraints from the inert set.
+inertGivens :: InertSet -> InertSet
+inertGivens is@(IS { inert_cans = cans }) =
+ is { inert_cans = givens_cans
+ , inert_solved_dicts = emptyDictMap
+ }
+ where
+
+ isGivenEq :: EqCt -> Bool
+ isGivenEq eq = isGiven (ctEvidence (CEqCan eq))
+ isGivenDict :: DictCt -> Bool
+ isGivenDict dict = isGiven (ctEvidence (CDictCan dict))
+ isGivenIrred :: IrredCt -> Bool
+ isGivenIrred irred = isGiven (ctEvidence (CIrredCan irred))
+
+ -- Filter the inert constraints for Givens
+ (eq_givens_list, _) = partitionInertEqs isGivenEq (inert_eqs cans)
+ (funeq_givens_list, _) = partitionFunEqs isGivenEq (inert_funeqs cans)
+ dict_givens = filterDicts isGivenDict (inert_dicts cans)
+ safehask_givens = filterDicts isGivenDict (inert_safehask cans)
+ irreds_givens = filterBag isGivenIrred (inert_irreds cans)
+
+ eq_givens = foldr addInertEqs emptyTyEqs eq_givens_list
+ funeq_givens = foldr addFunEqs emptyFunEqs funeq_givens_list
+
+ givens_cans =
+ cans
+ { inert_eqs = eq_givens
+ , inert_funeqs = funeq_givens
+ , inert_dicts = dict_givens
+ , inert_safehask = safehask_givens
+ , inert_irreds = irreds_givens
+ }
diff --git a/compiler/GHC/Tc/Solver/Irred.hs b/compiler/GHC/Tc/Solver/Irred.hs
index 63f35127637..08751882fed 100644
--- a/compiler/GHC/Tc/Solver/Irred.hs
+++ b/compiler/GHC/Tc/Solver/Irred.hs
@@ -39,10 +39,6 @@ solveIrred irred
; simpleStage (updInertIrreds irred)
; stopWithStage (irredCtEvidence irred) "Kept inert IrredCt" }
-updInertIrreds :: IrredCt -> TcS ()
-updInertIrreds irred
- = do { tc_lvl <- getTcLevel
- ; updInertCans $ addIrredToCans tc_lvl irred }
{- *********************************************************************
* *
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 387263ff5d7..b15feebf5c7 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -14,11 +14,14 @@
module GHC.Tc.Solver.Monad (
-- The TcS monad
- TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
+ TcS(..), TcSEnv(..), TcSMode(..),
+ runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
+ runTcSSpecPrag,
failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,
runTcSEqualities,
nestTcS, nestImplicTcS, setEvBindsTcS,
emitImplicationTcS, emitTvImplicationTcS,
+ emitImplication,
emitFunDepWanteds,
selectNextWorkItem,
@@ -76,6 +79,7 @@ module GHC.Tc.Solver.Monad (
getUnsolvedInerts,
removeInertCts, getPendingGivenScs,
insertFunEq, addInertForAll,
+ updInertDicts, updInertIrreds,
emitWorkNC, emitWork,
lookupInertDict,
@@ -170,6 +174,7 @@ import GHC.Builtin.Names ( unsatisfiableClassNameKey )
import GHC.Core.Type
import GHC.Core.TyCo.Rep as Rep
+import GHC.Core.TyCo.Tidy
import GHC.Core.Coercion
import GHC.Core.Coercion.Axiom( TypeEqn )
import GHC.Core.Predicate
@@ -210,6 +215,7 @@ import Data.Maybe ( isJust )
import qualified Data.Semigroup as S
import GHC.Types.SrcLoc
import GHC.Rename.Env
+--import GHC.Tc.Solver.Solve (solveWanteds)
#if defined(DEBUG)
import GHC.Types.Unique.Set (nonDetEltsUniqSet)
@@ -370,6 +376,31 @@ duplicates, is explained in Note [Use only the best matching quantified constrai
in GHC.Tc.Solver.Dict.
-}
+updInertDicts :: DictCt -> TcS ()
+updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
+ = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys)
+
+ ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
+ -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
+ -- Update /both/ inert_cans /and/ inert_solved_dicts.
+ updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
+ inerts { inert_cans = updDicts (filterDicts (not_ip_for str_ty)) ics
+ , inert_solved_dicts = filterDicts (not_ip_for str_ty) solved }
+ | otherwise
+ -> return ()
+
+ -- Add the new constraint to the inert set
+ ; updInertCans (updDicts (addDict dict_ct)) }
+ where
+ not_ip_for :: Type -> DictCt -> Bool
+ not_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
+ = not (mentionsIP str_ty cls tys)
+
+updInertIrreds :: IrredCt -> TcS ()
+updInertIrreds irred
+ = do { tc_lvl <- getTcLevel
+ ; updInertCans $ addIrredToCans tc_lvl irred }
+
{- *********************************************************************
* *
Kicking out
@@ -580,7 +611,7 @@ getInertGivens :: TcS [Ct]
getInertGivens
= do { inerts <- getInertCans
; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts)
- $ foldDicts ((:) . CDictCan) (inert_dicts inerts)
+ $ foldDicts ((:) . CDictCan) (inert_dicts inerts)
$ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts)
$ foldTyEqs ((:) . CEqCan) (inert_eqs inerts)
$ []
@@ -680,6 +711,7 @@ getUnsolvedInerts
where
ct = mk_ct thing
+
getHasGivenEqs :: TcLevel -- TcLevel of this implication
-> TcS ( HasGivenEqs -- are there Given equalities?
, InertIrreds ) -- Insoluble equalities arising from givens
@@ -825,6 +857,31 @@ for it, so TcS carries a mutable location where the binding can be
added. This is initialised from the innermost implication constraint.
-}
+-- | See Note [TcSMode]
+data TcSMode
+ = TcSVanilla -- ^ Normal constraint solving
+ | TcSEarlyAbort -- ^ Abort early on insoluble constraints
+ | TcSSpecPrag -- ^ Fully solve all constraints
+ deriving (Eq)
+
+{- Note [TcSMode]
+~~~~~~~~~~~~~~~~~
+The constraint solver can operate in different modes:
+
+* TcSVanilla: Normal constraint solving mode. This is the default.
+
+* TcSEarlyAbort: Abort (fail in the monad) as soon as we come across an
+ insoluble constraint. This is used to fail-fast when checking for hole-fits.
+ See Note [Speeding up valid hole-fits].
+
+* TcSSpecPrag: Solve constraints fully or not at all. This is described in
+ Note [TcSSpecPrag].
+
+ This mode is currently used in one place only: when solving constraints
+ arising from specialise pragmas.
+ See Note [Fully solving constraints for specialisation] in GHC.Tc.Gen.Sig.
+-}
+
data TcSEnv
= TcSEnv {
tcs_ev_binds :: EvBindsVar,
@@ -844,13 +901,11 @@ data TcSEnv
tcs_inerts :: IORef InertSet, -- Current inert set
- -- Whether to throw an exception if we come across an insoluble constraint.
- -- Used to fail-fast when checking for hole-fits. See Note [Speeding up
- -- valid hole-fits].
- tcs_abort_on_insoluble :: Bool,
+ -- | The mode of operation for the constraint solver.
+ -- See Note [TcSMode]
+ tcs_mode :: TcSMode,
- -- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet
- tcs_worklist :: IORef WorkList -- Current worklist
+ tcs_worklist :: IORef WorkList
}
---------------
@@ -921,9 +976,9 @@ addErrTcS = wrapTcS . TcM.addErr
panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc
tryEarlyAbortTcS :: TcS ()
--- Abort (fail in the monad) if the abort_on_insoluble flag is on
+-- Abort (fail in the monad) if the mode is TcSEarlyAbort
tryEarlyAbortTcS
- = mkTcS (\env -> when (tcs_abort_on_insoluble env) TcM.failM)
+ = mkTcS (\env -> when (tcs_mode env == TcSEarlyAbort) TcM.failM)
-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'.
ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS ()
@@ -993,7 +1048,59 @@ runTcS tcs
runTcSEarlyAbort :: TcS a -> TcM a
runTcSEarlyAbort tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; runTcSWithEvBinds' True True ev_binds_var tcs }
+ ; runTcSWithEvBinds' True TcSEarlyAbort ev_binds_var tcs }
+
+-- | Run the 'TcS' monad in 'TcSSpecPrag' mode, which either fully solves
+-- individual Wanted quantified constraints or leaves them alone.
+--
+-- See Note [TcSSpecPrag].
+runTcSSpecPrag :: EvBindsVar -> TcS a -> TcM a
+runTcSSpecPrag ev_binds_var tcs
+ = runTcSWithEvBinds' True TcSSpecPrag ev_binds_var tcs
+
+{- Note [TcSSpecPrag]
+~~~~~~~~~~~~~~~~~~~~~
+The TcSSpecPrag mode is a specialized constraint solving mode that guarantees
+that Wanted quantified constraints are either:
+ - Fully solved with no free evidence variables, or
+ - Left completely untouched (no simplification at all)
+
+Examples:
+
+ * [W] forall x. Eq x => Eq (f x).
+
+ In TcSSpecPrag mode, we **do not** process this quantified constraint by
+ creating a new implication constraint; we leave it alone instead.
+
+ * [W] Eq (Maybe Int).
+
+ This constraint is solved fully, using two top-level Eq instances.
+
+ * [W] forall x. Eq x => Eq [x].
+
+ This constraint is solved fully as well, using the Eq instance for lists.
+
+This functionality is crucially used by the specialiser, for which taking an
+irreversible constraint solving steps is actively harmful, as described in
+Note [Fully solving constraints for specialisation] in GHC.Tc.Gen.Sig.
+
+Note that currently we **do not** refrain from using top-level instances,
+even though we also can't run them in reverse; this isn't a problem for the
+specialiser (which is currently the sole consumer of this functionality).
+
+The implementation is as follows: in TcSFullySolveMode, when we are about to
+solve a Wanted quantified constraint by emitting an implication, we call the
+special function `solveCompletelyIfRequired`. This function recursively calls
+the solver but in TcSVanilla mode (i.e. full-blown solving, with no restrictions).
+If this recursive call manages to solve all the remaining constraints fully,
+then we proceed with that outcome (i.e. we continue with that inert set, etc).
+Otherwise, we discard everything that happened in the recursive call, and
+continue with the original quantified constraint unchanged.
+
+In the future, we could consider re-using this functionality for the short-cut
+solver (see Note [Shortcut solving] in GHC.Tc.Solver.Dict), but we would have to
+be wary of the performance implications.
+-}
-- | This can deal only with equality constraints.
runTcSEqualities :: TcS a -> TcM a
@@ -1006,7 +1113,7 @@ runTcSEqualities thing_inside
runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)
runTcSInerts inerts tcs = do
ev_binds_var <- TcM.newTcEvBinds
- runTcSWithEvBinds' False False ev_binds_var $ do
+ runTcSWithEvBinds' False TcSVanilla ev_binds_var $ do
setInertSet inerts
a <- tcs
new_inerts <- getInertSet
@@ -1015,17 +1122,17 @@ runTcSInerts inerts tcs = do
runTcSWithEvBinds :: EvBindsVar
-> TcS a
-> TcM a
-runTcSWithEvBinds = runTcSWithEvBinds' True False
+runTcSWithEvBinds = runTcSWithEvBinds' True TcSVanilla
-runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?
+runTcSWithEvBinds' :: Bool -- True <=> restore type equality cycles
-- Don't if you want to reuse the InertSet.
-- See also Note [Type equality cycles]
-- in GHC.Tc.Solver.Equality
- -> Bool
+ -> TcSMode
-> EvBindsVar
-> TcS a
-> TcM a
-runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs
+runTcSWithEvBinds' restore_cycles mode ev_binds_var tcs
= do { unified_var <- TcM.newTcRef 0
; step_count <- TcM.newTcRef 0
; inert_var <- TcM.newTcRef emptyInert
@@ -1036,7 +1143,7 @@ runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs
, tcs_unif_lvl = unif_lvl_var
, tcs_count = step_count
, tcs_inerts = inert_var
- , tcs_abort_on_insoluble = abort_on_insoluble
+ , tcs_mode = mode
, tcs_worklist = wl_var }
-- Run the computation
@@ -1098,7 +1205,7 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
, tcs_inerts = old_inert_var
, tcs_count = count
, tcs_unif_lvl = unif_lvl
- , tcs_abort_on_insoluble = abort_on_insoluble
+ , tcs_mode = mode
} ->
do { inerts <- TcM.readTcRef old_inert_var
; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack
@@ -1113,7 +1220,7 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
, tcs_ev_binds = ref
, tcs_unified = unified_var
, tcs_inerts = new_inert_var
- , tcs_abort_on_insoluble = abort_on_insoluble
+ , tcs_mode = mode
, tcs_worklist = new_wl_var }
; res <- TcM.setTcLevel inner_tclvl $
thing_inside nest_env
@@ -1128,7 +1235,7 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
#endif
; return res }
-nestTcS :: TcS a -> TcS a
+nestTcS :: TcS a -> TcS a
-- Use the current untouchables, augmenting the current
-- evidence bindings, and solved dictionaries
-- But have no effect on the InertCans, or on the inert_famapp_cache
diff --git a/compiler/GHC/Tc/Solver/Solve.hs b/compiler/GHC/Tc/Solver/Solve.hs
index 630137ff0ad..8ab06ccae5a 100644
--- a/compiler/GHC/Tc/Solver/Solve.hs
+++ b/compiler/GHC/Tc/Solver/Solve.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecursiveDo #-}
module GHC.Tc.Solver.Solve (
@@ -5,6 +6,7 @@ module GHC.Tc.Solver.Solve (
solveWanteds, -- Solves WantedConstraints
solveSimpleGivens, -- Solves [Ct]
solveSimpleWanteds, -- Solves Cts
+ solveCompletelyIfRequired,
setImplicationStatus
) where
@@ -18,7 +20,7 @@ import GHC.Tc.Solver.Rewrite( rewrite, rewriteType )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin, CtLoc )
+import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin )
import GHC.Tc.Types
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint
@@ -51,7 +53,8 @@ import GHC.Driver.Session
import Data.List( deleteFirstsBy )
import Control.Monad
-import Data.Maybe (mapMaybe)
+import Data.Foldable ( traverse_ )
+import Data.Maybe ( mapMaybe )
import qualified Data.Semigroup as S
import Data.Void( Void )
@@ -1053,7 +1056,7 @@ solveCt (CNonCanonical ev) = solveNC ev
solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev
solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel
- , eq_lhs = lhs, eq_rhs = rhs }))
+ , eq_lhs = lhs, eq_rhs = rhs }))
= solveEquality ev eq_rel (canEqLHSType lhs) rhs
solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
@@ -1062,7 +1065,8 @@ solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
-- rewrite the pieces and build a Reduction that will rewrite
-- the whole constraint
; case classifyPredType (ctEvPred ev) of
- ForAllPred tvs th p -> Stage $ solveForAll ev tvs th p pend_sc
+ ForAllPred tvs theta body_pred ->
+ Stage $ solveForAll ev tvs theta body_pred pend_sc
_ -> pprPanic "SolveCt" (ppr ev) }
solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc }))
@@ -1100,7 +1104,7 @@ solveNC ev
IrredPred {} -> solveIrred (IrredCt { ir_ev = ev, ir_reason = IrredShapeReason })
EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2
-- EqPred only happens if (say) `c` is unified with `a ~# b`,
- -- but that is rare becuase it requires c :: CONSTRAINT UnliftedRep
+ -- but that is rare because it requires c :: CONSTRAINT UnliftedRep
}}
@@ -1188,8 +1192,8 @@ type signature.
-- Precondition: the constraint has already been rewritten by the inert set.
solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType
-> TcS (StopOrContinue Void)
-solveForAllNC ev tvs theta pred
- | Just (cls,tys) <- getClassPredTys_maybe pred
+solveForAllNC ev tvs theta body_pred
+ | Just (cls,tys) <- getClassPredTys_maybe body_pred
, classHasSCs cls
= do { dflags <- getDynFlags
-- Either expand superclasses (Givens) or provide fuel to do so (Wanteds)
@@ -1199,38 +1203,37 @@ solveForAllNC ev tvs theta pred
-- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys
; emitWork (listToBag sc_cts)
- ; solveForAll ev tvs theta pred doNotExpand }
+ ; solveForAll ev tvs theta body_pred doNotExpand }
else
-- See invariants (a) and (b) in QCI.qci_pend_sc
-- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel]
-- See Note [Quantified constraints]
- do { solveForAll ev tvs theta pred (qcsFuel dflags) }
+ do { solveForAll ev tvs theta body_pred (qcsFuel dflags) }
}
| otherwise
- = solveForAll ev tvs theta pred doNotExpand
+ = solveForAll ev tvs theta body_pred doNotExpand
-- | Solve a canonical quantified constraint.
--
-- Precondition: the constraint has already been rewritten by the inert set.
solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel
-> TcS (StopOrContinue Void)
-solveForAll ev tvs theta pred fuel =
+solveForAll ev tvs theta body_pred fuel =
case ev of
CtGiven {} ->
-- See Note [Solving a Given forall-constraint]
do { addInertForAll qci
; stopWith ev "Given forall-constraint" }
- CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc } ->
+ CtWanted {} ->
-- See Note [Solving a Wanted forall-constraint]
runSolverStage $
do { tryInertQCs qci
- ; simpleStage $ solveWantedForAll_implic dest rewriters loc tvs theta pred
- ; stopWithStage ev "Wanted forall-constraint (implication)"
+ ; Stage $ solveWantedForAll_implic ev tvs theta body_pred
}
where
qci = QCI { qci_ev = ev, qci_tvs = tvs
- , qci_pred = pred, qci_pend_sc = fuel }
+ , qci_pred = body_pred, qci_pend_sc = fuel }
tryInertQCs :: QCInst -> SolverStage ()
@@ -1257,14 +1260,22 @@ try_inert_qcs (QCI { qci_ev = ev_w }) inerts =
-- | Solve a (canonical) Wanted quantified constraint by emitting an implication.
--
-- See Note [Solving a Wanted forall-constraint]
-solveWantedForAll_implic :: TcEvDest -> RewriterSet -> CtLoc -> [TcTyVar] -> TcThetaType -> PredType -> TcS ()
-solveWantedForAll_implic dest rewriters loc tvs theta pred
- = TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $
+solveWantedForAll_implic :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> TcS (StopOrContinue Void)
+solveWantedForAll_implic
+ ev@(CtWanted { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters })
+ tvs theta body_pred =
+ -- We are about to do something irreversible (turning a quantified constraint
+ -- into an implication), so wrap the inner call in solveCompletelyIfRequired
+ -- to ensure we can roll back if we can't solve the implication fully.
+ -- See Note [TcSSpecPrag] in GHC.Tc.Solver.Monad.
+ solveCompletelyIfRequired (mkNonCanonical ev) $
+
-- This setSrcSpan is important: the emitImplicationTcS uses that
-- TcLclEnv for the implication, and that in turn sets the location
-- for the Givens when solving the constraint (#21006)
+ TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $
do { let empty_subst = mkEmptySubst $ mkInScopeSet $
- tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs
+ tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs
is_qc = IsQC (ctLocOrigin loc)
-- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]
@@ -1272,7 +1283,7 @@ solveWantedForAll_implic dest rewriters loc tvs theta pred
-- Very like the code in tcSkolDFunType
; rec { skol_info <- mkSkolemInfo skol_info_anon
; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs
- ; let inst_pred = substTy subst pred
+ ; let inst_pred = substTy subst body_pred
inst_theta = substTheta subst theta
skol_info_anon = InstSkol is_qc (get_size inst_pred) }
@@ -1294,6 +1305,8 @@ solveWantedForAll_implic dest rewriters loc tvs theta pred
; setWantedEvTerm dest EvCanonical $
EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
, et_binds = ev_binds, et_body = w_id }
+
+ ; stopWith ev "Wanted forall-constraint (implication)"
}
where
-- Getting the size of the head is a bit horrible
@@ -1301,6 +1314,8 @@ solveWantedForAll_implic dest rewriters loc tvs theta pred
get_size pred = case classifyPredType pred of
ClassPred cls tys -> pSizeClassPred cls tys
_ -> pSizeType pred
+solveWantedForAll_implic (CtGiven {}) _ _ _ =
+ panic "solveWantedForAll_implic: CtGiven"
{- Note [Solving a Wanted forall-constraint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1342,7 +1357,7 @@ Note [Solving a Given forall-constraint]
For a Given constraint
[G] df :: forall ab. (Eq a, Ord b) => C x a b
we just add it to TcS's local InstEnv of known instances,
-via addInertForall. Then, if we look up (C x Int Bool), say,
+via addInertForAll. Then, if we look up (C x Int Bool), say,
we'll find a match in the InstEnv.
Note [Solving Wanted QCs from Given QCs]
@@ -1615,3 +1630,105 @@ runTcPluginSolvers solvers all_cts
CtGiven {} -> (ct:givens, wanteds)
CtWanted {} -> (givens, (ev,ct):wanteds)
+--------------------------------------------------------------------------------
+
+-- | If the mode is 'TcSSpecPrag', attempt to fully solve the Wanted
+-- constraints that arise from solving 'Ct'.
+--
+-- If not in 'TcSSpecPrag' mode, simply run 'thing_inside'.
+--
+-- See Note [TcSSpecPrag] in GHC.Tc.Solver.Monad.
+solveCompletelyIfRequired :: Ct -> TcS (StopOrContinue a) -> TcS (StopOrContinue a)
+solveCompletelyIfRequired ct (TcS thing_inside)
+ = TcS $ \ env@(TcSEnv { tcs_ev_binds = outer_ev_binds_var
+ , tcs_unified = outer_unified_var
+ , tcs_unif_lvl = outer_unif_lvl_var
+ , tcs_inerts = outer_inert_var
+ , tcs_count = outer_count
+ , tcs_mode = mode
+ }) ->
+ case mode of
+ TcSSpecPrag ->
+ do { traceTc "solveCompletelyIfRequired {" empty
+ -- Create a fresh environment for the inner computation
+ ; outer_inerts <- TcM.readTcRef outer_inert_var
+ ; let outer_givens = inertGivens outer_inerts
+ -- Keep the ambient Given inerts, but drop the Wanteds.
+ ; new_inert_var <- TcM.newTcRef outer_givens
+ ; new_wl_var <- TcM.newTcRef emptyWorkList
+ ; new_ev_binds_var <- TcM.newTcEvBinds
+
+ ; let
+ inner_env =
+ TcSEnv
+ -- KEY part: recur with TcSVanilla
+ { tcs_mode = TcSVanilla
+
+ -- Use new variables for evidence bindings, inerts; and
+ -- the work list. We may want to discard all of these if the
+ -- inner computation doesn't fully solve all the constraints.
+ , tcs_ev_binds = new_ev_binds_var
+ , tcs_inerts = new_inert_var
+ , tcs_worklist = new_wl_var
+
+ -- Inherit the other variables. In particular, inherit the
+ -- variables to do with unification, as filling metavariables
+ -- is a side-effect that we are not reverting, even when we
+ -- discard the result of the inner computation.
+ , tcs_unif_lvl = outer_unif_lvl_var
+ , tcs_unified = outer_unified_var
+ , tcs_count = outer_count
+ }
+
+ -- Solve the constraint
+ ; let wc = emptyWC { wc_simple = unitBag ct }
+ ; traceTc "solveCompletelyIfRequired solveWanteds" $
+ vcat [ text "ct:" <+> ppr ct
+ ]
+ ; solved_wc <- unTcS (solveWanteds wc) inner_env
+ -- NB: it would probably make more sense to call 'thing_inside',
+ -- collecting all constraints that were added to the work list as
+ -- a result, and calling 'solveWanteds' on that. This would avoid
+ -- restarting from the top of the solver pipeline.
+ -- For the time being, we just call 'solveWanteds' on the original
+ -- constraint, which is simpler
+
+ ; if isSolvedWC solved_wc
+ then
+ do { -- The constraint was fully solved. Continue with
+ -- the inner solver state.
+ ; traceTc "solveCompletelyIfRequired: fully solved }" $
+ vcat [ text "ct:" <+> ppr ct
+ , text "solved_wc:" <+> ppr solved_wc ]
+
+ -- Add new evidence bindings to the existing ones
+ ; inner_ev_binds <- TcM.getTcEvBindsMap new_ev_binds_var
+ ; addTcEvBinds outer_ev_binds_var inner_ev_binds
+
+ -- Keep the outer inert set and work list: the inner work
+ -- list is empty, and there are no leftover unsolved
+ -- Wanteds.
+ -- However, we **must not** drop solved implications, due
+ -- to Note [Free vars of EvFun] in GHC.Tc.Types.Evidence;
+ -- so we re-emit them here.
+ ; let re_emit_implic impl = unTcS ( TcS.emitImplication impl ) env
+ ; traverse_ re_emit_implic $ wc_impl solved_wc
+ ; return $ Stop (ctEvidence ct) (text "Fully solved:" <+> ppr ct)
+ }
+ else
+ do { traceTc "solveCompletelyIfRequired: unsolved }" $
+ vcat [ text "ct:" <+> ppr ct
+ , text "solved_wc:" <+> ppr solved_wc ]
+ -- Failed to fully solve the constraint:
+ --
+ -- - discard the inner solver state,
+ -- - add the original constraint as an inert.
+ ; unTcS (updInertIrreds (IrredCt (ctEvidence ct) IrredShapeReason)) env
+ -- NB: currently we only call 'solveCompletelyIfRequired'
+ -- from 'solveForAll'; so we just stash the unsolved quantified
+ -- constraint in the irreds.
+
+ ; return $ Stop (ctEvidence ct) (text "Not fully solved; kept as inert:" <+> ppr ct)
+ } }
+ _notFullySolveMode ->
+ thing_inside env
\ No newline at end of file
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index d4ace7b6196..a175e857a39 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -3376,7 +3376,7 @@ without treating the explicitly-quantified ones specially. Wrinkles:
no role.
See also Note [Re-quantify type variables in rules] in
-GHC.Tc.Gen.Rule, which explains a /very/ similar design when
+GHC.Tc.Gen.Sig, which explains a /very/ similar design when
generalising over the type of a rewrite rule.
-}
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 280661f2907..5f817313909 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2043,7 +2043,17 @@ tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys
tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
; global_meth_id <- addInlinePrags global_meth_id prags
- ; spec_prags <- tcSpecPrags global_meth_id prags
+ ; spec_prags <- tcExtendIdEnv1 (idName sel_id) global_meth_id $
+ -- tcExtendIdEnv1: tricky point: a SPECIALISE pragma in prags
+ -- mentions sel_name but the pragma is really for global_meth_id.
+ -- So we bind sel_name to global_meth_id, just in the pragmas.
+ -- Example:
+ -- instance C [a] where
+ -- op :: forall b. Ord b => b -> a -> a
+ -- {-# SPECIALISE op @Int #-}
+ -- The specialisation is for the `op` for this instance decl, not
+ -- for the global selector-id, of course.
+ tcSpecPrags global_meth_id prags
; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
export = ABE { abe_poly = global_meth_id
@@ -2215,7 +2225,7 @@ mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
-- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
-- These ones have the dfun inside, but [perhaps surprisingly]
-- the correct wrapper.
- -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind
+ -- See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Bind
mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
= SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
where
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index ff1886ea777..57fea9b152b 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -37,8 +37,9 @@ import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build
import GHC.Core.Multiplicity
-import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp )
+import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp )
import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
+import GHC.Core.TyCo.Tidy( tidyForAllTyBinders, tidyTypes, tidyType )
import GHC.Core.Predicate
import GHC.Types.Name
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index d505260370d..5f5d1247fc5 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -2068,6 +2068,7 @@ checkSkolInfoAnon sk1 sk2 = go sk1 sk2
go FamInstSkol FamInstSkol = True
go BracketSkol BracketSkol = True
go (RuleSkol n1) (RuleSkol n2) = n1==n2
+ go (SpecESkol n1) (SpecESkol n2) = n1==n2
go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2
-- Too tedious to compare the HsMatchContexts
go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 &&
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index b234c4627f7..032902e775c 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -15,7 +15,7 @@ module GHC.Tc.Types.Evidence (
-- * Evidence bindings
TcEvBinds(..), EvBindsVar(..),
- EvBindMap(..), emptyEvBindMap, extendEvBinds,
+ EvBindMap(..), emptyEvBindMap, extendEvBinds, unionEvBindMap,
lookupEvBind, evBindMapBinds,
foldEvBindMap, nonDetStrictFoldEvBindMap,
filterEvBindMap,
@@ -373,10 +373,15 @@ data EvBindsVar
}
instance Data.Data TcEvBinds where
- -- Placeholder; we can't travers into TcEvBinds
+ -- Placeholder; we can't traverse into TcEvBinds
toConstr _ = abstractConstr "TcEvBinds"
gunfold _ _ = error "gunfold"
dataTypeOf _ = Data.mkNoRepType "TcEvBinds"
+instance Data.Data EvBind where
+ -- Placeholder; we can't traverse into EvBind
+ toConstr _ = abstractConstr "TcEvBind"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = Data.mkNoRepType "EvBind"
{- Note [Coercion evidence only]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -428,6 +433,11 @@ extendEvBinds bs ev_bind
(eb_lhs ev_bind)
ev_bind }
+-- | Union two evidence binding maps
+unionEvBindMap :: EvBindMap -> EvBindMap -> EvBindMap
+unionEvBindMap (EvBindMap env1) (EvBindMap env2) =
+ EvBindMap { ev_bind_varenv = plusDVarEnv env1 env2 }
+
isEmptyEvBindMap :: EvBindMap -> Bool
isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 4220ef17672..4ed282188b7 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -130,8 +130,6 @@ data UserTypeCtxt
| PatSigCtxt -- Type sig in pattern
-- eg f (x::t) = ...
-- or (x::t, y) = e
- | RuleSigCtxt FastString Name -- LHS of a RULE forall
- -- RULE "foo" forall (x :: a -> a). f (Just x) = ...
| ForSigCtxt Name -- Foreign import or export signature
| DefaultDeclCtxt -- Class or types in a default declaration
| InstDeclCtxt Bool -- An instance declaration
@@ -154,6 +152,9 @@ data UserTypeCtxt
-- data <S> => T a = MkT a
| DerivClauseCtxt -- A 'deriving' clause
| TyVarBndrKindCtxt Name -- The kind of a type variable being bound
+ | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE
+ -- or SPECIALISE pragma
+ -- RULE "foo" forall (x :: a -> a). f (Just x) = ...
| DataKindCtxt Name -- The kind of a data/newtype (instance)
| TySynKindCtxt Name -- The kind of the RHS of a type synonym
| TyFamResKindCtxt Name -- The result kind of a type family
@@ -195,11 +196,10 @@ redundantConstraintsSpan _ = noSrcSpan
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
-pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n)
-pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n)
-pprUserTypeCtxt (RuleSigCtxt _ n) = text "the type signature for" <+> quotes (ppr n)
-pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature"
-pprUserTypeCtxt KindSigCtxt = text "a kind signature"
+pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n)
+pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n)
+pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature"
+pprUserTypeCtxt KindSigCtxt = text "a kind signature"
pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n)
pprUserTypeCtxt TypeAppCtxt = text "a type argument"
pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c)
@@ -218,6 +218,7 @@ pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declarati
pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n)
pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause"
pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n)
+pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n)
pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n)
@@ -299,6 +300,7 @@ data SkolemInfoAnon
| IPSkol [HsIPName] -- Binding site of an implicit parameter
| RuleSkol RuleName -- The LHS of a RULE
+ | SpecESkol Name -- A SPECIALISE pragma
| InferSkol [(Name,TcType)]
-- We have inferred a type for these (mutually recursive)
@@ -370,6 +372,7 @@ pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified context"
pprSkolInfo FamInstSkol = text "a family instance declaration"
pprSkolInfo BracketSkol = text "a Template Haskell bracket"
pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name
+pprSkolInfo (SpecESkol name) = text "a SPECIALISE pragma for" <+> quotes (ppr name)
pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl
, text "in" <+> pprMatchContext mc ]
pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of")
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index d362c37d38e..1e5da18eaa4 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -55,6 +55,7 @@ import GHC.Core.FamInstEnv
import GHC.Core ( isOrphan ) -- For the Coercion constructor
import GHC.Core.Type
import GHC.Core.TyCo.Ppr ( debugPprType )
+import GHC.Core.TyCo.Tidy ( tidyType )
import GHC.Core.Class( Class )
import GHC.Core.Coercion.Axiom
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 2458cd62bba..756649b3451 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -98,7 +98,7 @@ module GHC.Tc.Utils.Monad(
-- * Type constraints
newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
- addTcEvBind, addTopEvBinds,
+ addTcEvBind, addTcEvBinds, addTopEvBinds,
getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
chooseUniqueOccTc,
getConstraintVar, setConstraintVar,
@@ -1794,6 +1794,19 @@ addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
= pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
+addTcEvBinds :: EvBindsVar -> EvBindMap -> TcM ()
+-- ^ Add a collection of binding to the TcEvBinds by side effect
+addTcEvBinds _ new_ev_binds
+ | isEmptyEvBindMap new_ev_binds
+ = return ()
+addTcEvBinds (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) new_ev_binds
+ = do { traceTc "addTcEvBinds" $ ppr u $$
+ ppr new_ev_binds
+ ; old_bnds <- readTcRef ev_ref
+ ; writeTcRef ev_ref (old_bnds `unionEvBindMap` new_ev_binds) }
+addTcEvBinds (CoEvBindsVar { ebv_uniq = u }) new_ev_binds
+ = pprPanic "addTcEvBinds CoEvBindsVar" (ppr new_ev_binds $$ ppr u)
+
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
do { env <- getGblEnv
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index fb3d2ffcc33..0bba873b65c 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -83,7 +83,7 @@ module GHC.Tc.Utils.TcMType (
candidateQTyVarsOfType, candidateQTyVarsOfKind,
candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
- candidateQTyVarsWithBinders,
+ candidateQTyVarsWithBinders, weedOutCandidates,
CandidatesQTvs(..), delCandidates,
candidateKindVars, partitionCandidates,
@@ -123,6 +123,7 @@ import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
+import GHC.Core.TyCo.Tidy
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.Coercion
@@ -1342,6 +1343,10 @@ instance Outputable CandidatesQTvs where
, text "dv_tvs =" <+> ppr tvs
, text "dv_cvs =" <+> ppr cvs ])
+weedOutCandidates :: (DTyVarSet -> DTyVarSet) -> CandidatesQTvs -> CandidatesQTvs
+weedOutCandidates weed_out dv@(DV { dv_kvs = kvs, dv_tvs = tvs })
+ = dv { dv_kvs = weed_out kvs, dv_tvs = weed_out tvs }
+
isEmptyCandidates :: CandidatesQTvs -> Bool
isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs })
= isEmptyDVarSet kvs && isEmptyDVarSet tvs
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 1f1826b99f7..174cb33f91e 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -49,6 +49,7 @@ import GHC.Core.Predicate
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
+import GHC.Core.TyCo.Tidy
import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches
, InjectivityCheckResult(..) )
@@ -371,7 +372,6 @@ checkValidType ctxt ty
= case ctxt of
DefaultDeclCtxt-> MustBeMonoType
PatSigCtxt -> rank0
- RuleSigCtxt {} -> rank1
TySynCtxt _ -> rank0
ExprSigCtxt {} -> rank1
@@ -395,10 +395,11 @@ checkValidType ctxt ty
SpecInstCtxt -> rank1
GhciCtxt {} -> ArbitraryRank
- TyVarBndrKindCtxt _ -> rank0
- DataKindCtxt _ -> rank1
- TySynKindCtxt _ -> rank1
- TyFamResKindCtxt _ -> rank1
+ TyVarBndrKindCtxt {} -> rank0
+ RuleBndrTypeCtxt{} -> rank1
+ DataKindCtxt _ -> rank1
+ TySynKindCtxt _ -> rank1
+ TyFamResKindCtxt _ -> rank1
_ -> panic "checkValidType"
-- Can't happen; not used for *user* sigs
@@ -532,7 +533,7 @@ typeOrKindCtxt (ExprSigCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (TypeAppCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (PatSynCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (PatSigCtxt {}) = OnlyTypeCtxt
-typeOrKindCtxt (RuleSigCtxt {}) = OnlyTypeCtxt
+typeOrKindCtxt (RuleBndrTypeCtxt {})= OnlyTypeCtxt
typeOrKindCtxt (ForSigCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (DefaultDeclCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (InstDeclCtxt {}) = OnlyTypeCtxt
@@ -1454,7 +1455,7 @@ okIPCtxt (StandaloneKindSigCtxt {}) = False
okIPCtxt (ClassSCCtxt {}) = False
okIPCtxt (InstDeclCtxt {}) = False
okIPCtxt (SpecInstCtxt {}) = False
-okIPCtxt (RuleSigCtxt {}) = False
+okIPCtxt (RuleBndrTypeCtxt {}) = False
okIPCtxt DefaultDeclCtxt = False
okIPCtxt DerivClauseCtxt = False
okIPCtxt (TyVarBndrKindCtxt {}) = False
diff --git a/compiler/GHC/Tc/Zonk/Env.hs b/compiler/GHC/Tc/Zonk/Env.hs
index d31f6d30023..0f8255c4a54 100644
--- a/compiler/GHC/Tc/Zonk/Env.hs
+++ b/compiler/GHC/Tc/Zonk/Env.hs
@@ -61,10 +61,14 @@ data ZonkEnv
--
-- See Note [Un-unified unification variables]
data ZonkFlexi
- = DefaultFlexi -- ^ Default unbound unification variables to Any
- | SkolemiseFlexi -- ^ Skolemise unbound unification variables
- -- See Note [Zonking the LHS of a RULE]
+ = DefaultFlexi -- ^ Default unbound unification variables to Any
+
+ | SkolemiseFlexi -- ^ Skolemise unbound unification variables
+ (IORef [TyVar]) -- See Note [Zonking the LHS of a RULE]
+ -- Records the tyvars thus skolemised
+
| RuntimeUnkFlexi -- ^ Used in the GHCi debugger
+
| NoFlexi -- ^ Panic on unfilled meta-variables
-- See Note [Error on unconstrained meta-variables]
-- in GHC.Tc.Utils.TcMType
diff --git a/compiler/GHC/Tc/Zonk/TcType.hs b/compiler/GHC/Tc/Zonk/TcType.hs
index f6fd4c73325..68d957bac07 100644
--- a/compiler/GHC/Tc/Zonk/TcType.hs
+++ b/compiler/GHC/Tc/Zonk/TcType.hs
@@ -75,6 +75,7 @@ import GHC.Tc.Zonk.Monad
import GHC.Core.InstEnv (ClsInst(is_tys))
import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Tidy
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion
diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs
index dd77e25039c..07a70244d6e 100644
--- a/compiler/GHC/Tc/Zonk/Type.hs
+++ b/compiler/GHC/Tc/Zonk/Type.hs
@@ -381,7 +381,7 @@ zonkTyVarBinderX (Bndr tv vis)
zonkTyVarOcc :: HasDebugCallStack => TcTyVar -> ZonkTcM Type
zonkTyVarOcc tv
- = do { ZonkEnv { ze_tv_env = tv_env } <- getZonkEnv
+ = do { ZonkEnv { ze_tv_env = tv_env, ze_flexi = zonk_flexi } <- getZonkEnv
; let lookup_in_tv_env -- Look up in the env just as we do for Ids
= case lookupVarEnv tv_env tv of
@@ -395,7 +395,7 @@ zonkTyVarOcc tv
zonk_meta ref Flexi
= do { kind <- zonkTcTypeToTypeX (tyVarKind tv)
- ; ty <- commitFlexi tv kind
+ ; ty <- lift $ commitFlexi zonk_flexi tv kind
; lift $ liftZonkM $ writeMetaTyVarRef tv ref ty -- Belt and braces
; finish_meta ty }
@@ -443,50 +443,47 @@ lookupTyVarX tv
Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env)
; return res }
-commitFlexi :: TcTyVar -> Kind -> ZonkTcM Type
-commitFlexi tv zonked_kind
- = do { flexi <- ze_flexi <$> getZonkEnv
- ; lift $ case flexi of
- SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind))
-
- DefaultFlexi
- -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar
- -- But that sees only type variables that appear in, say, an inferred type.
- -- Defaulting here, in the zonker, is needed to catch e.g.
- -- y :: Bool
- -- y = (\x -> True) undefined
- -- We need *some* known RuntimeRep for the x and undefined, but no one
- -- will choose it until we get here, in the zonker.
- | isRuntimeRepTy zonked_kind
- -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
- ; return liftedRepTy }
- | isLevityTy zonked_kind
- -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv)
- ; return liftedDataConTy }
- | isMultiplicityTy zonked_kind
- -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)
- ; return manyDataConTy }
- | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
- -> do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)
- ; return (anyTypeOfKind zonked_kind) }
- | otherwise
- -> do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)
- -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)
- ; newZonkAnyType zonked_kind }
-
- RuntimeUnkFlexi
- -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
- ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }
- -- This is where RuntimeUnks are born:
- -- otherwise-unconstrained unification variables are
- -- turned into RuntimeUnks as they leave the
- -- typechecker's monad
-
- NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) }
-
- where
- name = tyVarName tv
-
+commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
+commitFlexi NoFlexi tv zonked_kind
+ = pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind)
+
+commitFlexi (SkolemiseFlexi tvs_ref) tv zonked_kind
+ = do { let skol_tv = mkTyVar (tyVarName tv) zonked_kind
+ ; updTcRef tvs_ref (skol_tv :)
+ ; return (mkTyVarTy skol_tv) }
+
+commitFlexi RuntimeUnkFlexi tv zonked_kind
+ = do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
+ ; return (mkTyVarTy (mkTcTyVar (tyVarName tv) zonked_kind RuntimeUnk)) }
+ -- This is where RuntimeUnks are born:
+ -- otherwise-unconstrained unification variables are
+ -- turned into RuntimeUnks as they leave the
+ -- typechecker's monad
+
+commitFlexi DefaultFlexi tv zonked_kind
+ -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar
+ -- But that sees only type variables that appear in, say, an inferred type.
+ -- Defaulting here, in the zonker, is needed to catch e.g.
+ -- y :: Bool
+ -- y = (\x -> True) undefined
+ -- We need *some* known RuntimeRep for the x and undefined, but no one
+ -- will choose it until we get here, in the zonker.
+ | isRuntimeRepTy zonked_kind
+ = do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
+ ; return liftedRepTy }
+ | isLevityTy zonked_kind
+ = do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv)
+ ; return liftedDataConTy }
+ | isMultiplicityTy zonked_kind
+ = do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)
+ ; return manyDataConTy }
+ | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
+ = do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin)
+ ; return (anyTypeOfKind zonked_kind) }
+ | otherwise
+ = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv)
+ -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4)
+ ; newZonkAnyType zonked_kind }
zonkCoVarOcc :: CoVar -> ZonkTcM Coercion
zonkCoVarOcc cv
@@ -855,9 +852,25 @@ zonkLTcSpecPrags ps
= mapM zonk_prag ps
where
zonk_prag (L loc (SpecPrag id co_fn inl))
- = do { co_fn' <- don'tBind $ zonkCoFn co_fn
- ; id' <- zonkIdOcc id
- ; return (L loc (SpecPrag id' co_fn' inl)) }
+ = do { co_fn' <- don'tBind $ zonkCoFn co_fn
+ ; id' <- zonkIdOcc id
+ ; return (L loc (SpecPrag id' co_fn' inl)) }
+ zonk_prag (L loc prag@(SpecPragE { spe_fn_id = poly_id
+ , spe_bndrs = bndrs
+ , spe_call = spec_e }))
+ = do { poly_id' <- zonkIdOcc poly_id
+
+ ; skol_tvs_ref <- lift $ newTcRef []
+ ; setZonkType (SkolemiseFlexi skol_tvs_ref) $
+ -- SkolemiseFlexi: see Note [Free tyvars on rule LHS]
+ runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' ->
+ do { spec_e' <- zonkLExpr spec_e
+ ; skol_tvs <- lift $ readTcRef skol_tvs_ref
+ ; return (L loc (prag { spe_fn_id = poly_id'
+ , spe_bndrs = skol_tvs ++ bndrs'
+ , spe_call = spec_e'
+ }))
+ }}
{-
************************************************************************
@@ -1671,30 +1684,73 @@ zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc]
zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs
zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc)
-zonkRule rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
+zonkRule rule@(HsRule { rd_bndrs = bndrs
, rd_lhs = lhs
, rd_rhs = rhs })
- = runZonkBndrT (traverse zonk_tm_bndr tm_bndrs) $ \ new_tm_bndrs ->
- do { -- See Note [Zonking the LHS of a RULE]
- ; new_lhs <- setZonkType SkolemiseFlexi $ zonkLExpr lhs
- ; new_rhs <- zonkLExpr rhs
- ; return $ rule { rd_tmvs = new_tm_bndrs
- , rd_lhs = new_lhs
- , rd_rhs = new_rhs } }
+ = do { skol_tvs_ref <- lift $ newTcRef []
+ ; setZonkType (SkolemiseFlexi skol_tvs_ref) $
+ -- setZonkType: see Note [Free tyvars on rule LHS]
+ zonkRuleBndrs bndrs $ \ new_bndrs ->
+ do { new_lhs <- zonkLExpr lhs
+ ; skol_tvs <- lift $ readTcRef skol_tvs_ref
+ ; new_rhs <- setZonkType DefaultFlexi $ zonkLExpr rhs
+ ; return $ rule { rd_bndrs = add_tvs skol_tvs new_bndrs
+ , rd_lhs = new_lhs
+ , rd_rhs = new_rhs } } }
+ where
+ add_tvs :: [TyVar] -> RuleBndrs GhcTc -> RuleBndrs GhcTc
+ add_tvs tvs rbs@(RuleBndrs { rb_ext = bndrs }) = rbs { rb_ext = tvs ++ bndrs }
+
+
+zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a
+zonkRuleBndrs rb@(RuleBndrs { rb_ext = bndrs }) thing_inside
+ = runZonkBndrT (traverse zonk_it bndrs) $ \ new_bndrs ->
+ thing_inside (rb { rb_ext = new_bndrs })
where
- zonk_tm_bndr :: LRuleBndr GhcTc -> ZonkBndrTcM (LRuleBndr GhcTc)
- zonk_tm_bndr (L l (RuleBndr x (L loc v)))
- = do { v' <- zonk_it v
- ; return (L l (RuleBndr x (L loc v'))) }
- zonk_tm_bndr (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
-
- zonk_it v
- | isId v = zonkIdBndrX v
- | otherwise = assert (isImmutableTyVar v)
- zonkTyBndrX v
- -- DV: used to be "return v", but that is plain
- -- wrong because we may need to go inside the kind
- -- of v and zonk there!
+ zonk_it v
+ | isId v = zonkIdBndrX v
+ | otherwise = assert (isImmutableTyVar v) $
+ zonkTyBndrX v
+ -- We may need to go inside the kind of v and zonk there!
+
+{- Note [Free tyvars on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ data T a = C
+
+ foo :: T a -> Int
+ foo C = 1
+
+ {-# RULES "myrule" foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)), where alpha
+is an unbound meta-tyvar. The zonker in GHC.Tc.Zonk.Type is careful not to
+turn the free alpha into Any (as it usually does). Instead we want to quantify
+over it. Here is how:
+
+* We set the ze_flexi field of ZonkEnv to (SkolemiseFlexi ref), to tell the
+ zonker to zonk a Flexi meta-tyvar to a TyVar, not to Any. See the
+ SkolemiseFlexi case of `commitFlexi`.
+
+* Here (ref :: TcRef [TyVar]) collects the type variables thus skolemised;
+ again see `commitFlexi`.
+
+* When zonking a RULE, in `zonkRule` we
+ - make a fresh ref-cell to collect the skolemised type variables,
+ - zonk the binders and LHS with ze_flexi = SkolemiseFlexi ref
+ - read the ref-cell to get all the skolemised TyVars
+ - add them to the binders
+
+All this applies for SPECIALISE pragmas too.
+
+Wrinkles:
+
+(FTV1) We just add the new tyvars to the front of the binder-list, but
+ that may make the list not be in dependency order. Example (T12925):
+ the existing list is [k:Type, b:k], and we add (a:k) to the front.
+ Also we just collect the new skolemised type variables in any old order,
+ so they may not be ordered with respect to each other.
+-}
{-
************************************************************************
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 58da4b053b9..e8d3a878aa2 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -913,21 +913,7 @@ cvtPragmaD (OpaqueP nm)
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
- ; let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE"
- src TH.Inline = fsLit "{-# SPECIALISE INLINE"
- src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"
- ; let (inline', dflt, srcText) = case inline of
- Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
- toSrcTxt inline1)
- Nothing -> (NoUserInlinePrag, AlwaysActive,
- SourceText $ fsLit "{-# SPECIALISE")
- where
- toSrcTxt a = SourceText $ src a
- ; let ip = InlinePragma { inl_src = srcText
- , inl_inline = inline'
- , inl_rule = Hs.FunLike
- , inl_act = cvtPhases phases dflt
- , inl_sat = Nothing }
+ ; let ip = cvtInlinePhases inline phases
; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
@@ -935,6 +921,16 @@ cvtPragmaD (SpecialiseInstP ty)
; returnJustLA $ Hs.SigD noExtField $
SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' }
+cvtPragmaD (SpecialiseEP ty_bndrs tm_bndrs exp inline phases)
+ = do { ty_bndrs' <- traverse cvtTvs ty_bndrs
+ ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
+ ; let ip = cvtInlinePhases inline phases
+ ; exp' <- cvtl exp
+ ; let bndrs' = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }
+ ; returnJustLA $ Hs.SigD noExtField $
+ SpecSigE noAnn bndrs' exp' ip
+ }
+
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
; rd_name' <- returnLA nm'
@@ -947,8 +943,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
HsRule { rd_ext = (noAnn, quotedSourceText nm)
, rd_name = rd_name'
, rd_act = act
- , rd_tyvs = ty_bndrs'
- , rd_tmvs = tm_bndrs'
+ , rd_bndrs = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }
, rd_lhs = lhs'
, rd_rhs = rhs' }
; returnJustLA $ Hs.RuleD noExtField
@@ -1016,6 +1011,24 @@ cvtRuleBndr (TypedRuleVar n ty)
; ty' <- cvtType ty
; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
+cvtInlinePhases :: Maybe Inline -> Phases -> InlinePragma
+cvtInlinePhases inline phases =
+ let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE"
+ src TH.Inline = fsLit "{-# SPECIALISE INLINE"
+ src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"
+ (inline', dflt, srcText) = case inline of
+ Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
+ toSrcTxt inline1)
+ Nothing -> (NoUserInlinePrag, AlwaysActive,
+ SourceText $ fsLit "{-# SPECIALISE")
+ where
+ toSrcTxt a = SourceText $ src a
+ in InlinePragma { inl_src = srcText
+ , inl_inline = inline'
+ , inl_rule = Hs.FunLike
+ , inl_act = cvtPhases phases dflt
+ , inl_sat = Nothing }
+
---------------------------------------------------
-- Declarations
---------------------------------------------------
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 5e542cf6662..efe560cb76e 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -1785,12 +1785,7 @@ inlinePragmaSpec :: InlinePragma -> InlineSpec
inlinePragmaSpec = inl_inline
inlinePragmaSource :: InlinePragma -> SourceText
-inlinePragmaSource prag = case inl_inline prag of
- Inline x -> x
- Inlinable y -> y
- NoInline z -> z
- Opaque q -> q
- NoUserInlinePrag -> NoSourceText
+inlinePragmaSource prag = inlineSpecSource (inl_inline prag)
inlineSpecSource :: InlineSpec -> SourceText
inlineSpecSource spec = case spec of
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 0b68e4cf8fa..c2c09c04bf5 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -31,15 +31,17 @@ import GHC.Core.InstEnv ( LookupInstanceErrReason )
import GHC.Hs.Extension ( GhcRn )
import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..)
, diagnosticCode, UnknownDiagnosticFor )
-import GHC.Unit.Module.Warnings ( WarningTxt )
-import GHC.Utils.Panic.Plain
--- Import all the structured error data types
-import GHC.Driver.Errors.Types ( DriverMessage, GhcMessage )
-import GHC.HsToCore.Errors.Types ( DsMessage )
import GHC.Iface.Errors.Types
+import GHC.Driver.Errors.Types ( DriverMessage )
import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage )
+import GHC.HsToCore.Errors.Types ( DsMessage, UselessSpecialisePragmaReason )
import GHC.Tc.Errors.Types
+import GHC.Unit.Module.Warnings ( WarningTxt )
+import GHC.Utils.Panic.Plain
+
+-- Import all the structured error data types
+import GHC.Driver.Errors.Types ( GhcMessage )
import Data.Kind ( Type, Constraint )
import GHC.Exts ( proxy# )
@@ -220,8 +222,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DsMaxPmCheckModelsReached" = 61505
GhcDiagnosticCode "DsNonExhaustivePatterns" = 62161
GhcDiagnosticCode "DsTopLevelBindsNotAllowed" = 48099
- GhcDiagnosticCode "DsUselessSpecialiseForClassMethodSelector" = 93315
- GhcDiagnosticCode "DsUselessSpecialiseForNoInlineFunction" = 38524
GhcDiagnosticCode "DsOrphanRule" = 58181
GhcDiagnosticCode "DsRuleLhsTooComplicated" = 69441
GhcDiagnosticCode "DsRuleIgnoredDueToConstructor" = 00828
@@ -238,6 +238,10 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DsAnotherRuleMightFireFirst" = 87502
GhcDiagnosticCode "DsIncompleteRecordSelector" = 17335
+ -- Constructors of 'UselessSpecialisePragmaReason'
+ GhcDiagnosticCode "UselessSpecialiseForClassMethodSelector" = 93315
+ GhcDiagnosticCode "UselessSpecialiseForNoInlineFunction" = 38524
+ GhcDiagnosticCode "UselessSpecialiseNoSpecialisation" = 66582
-- Parser diagnostic codes
GhcDiagnosticCode "PsErrParseLanguagePragma" = 68686
@@ -363,6 +367,8 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "PsErrInvalidPun" = 52943
GhcDiagnosticCode "PsErrIllegalOrPat" = 29847
GhcDiagnosticCode "PsErrTypeSyntaxInPat" = 32181
+ GhcDiagnosticCode "PsErrSpecExprMultipleTypeAscription" = 62037
+ GhcDiagnosticCode "PsWarnSpecMultipleTypeAscription" = 73026
-- Driver diagnostic codes
GhcDiagnosticCode "DriverMissingHomeModules" = 32850
@@ -598,6 +604,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnMisplacedSigDecl" = 87866
GhcDiagnosticCode "TcRnUnexpectedDefaultSig" = 40700
GhcDiagnosticCode "TcRnDuplicateMinimalSig" = 85346
+ GhcDiagnosticCode "TcRnSpecSigShape" = 93944
GhcDiagnosticCode "TcRnLoopySuperclassSolve" = Outdated 36038
GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl" = 95159
GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl" = 65669
@@ -1050,6 +1057,11 @@ type family ConRecursInto con where
ConRecursInto "PsUnknownMessage" = 'Just (UnknownDiagnosticFor PsMessage)
ConRecursInto "PsHeaderMessage" = 'Just PsHeaderMessage
+ ----------------------------------
+ -- Constructors of DsMessage
+
+ ConRecursInto "DsUselessSpecialisePragma" = 'Just UselessSpecialisePragmaReason
+
----------------------------------
-- Constructors of TcRnMessage
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 33bfc23db4e..2c5db7b1815 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -504,6 +504,11 @@ data GhcHint
{-| Suggest add parens to pattern `e -> p :: t` -}
| SuggestParenthesizePatternRHS
+ {-| Suggest splitting up a SPECIALISE pragmas with multiple type ascriptions
+ into several individual SPECIALISE pragmas.
+ -}
+ | SuggestSplittingIntoSeveralSpecialisePragmas
+
-- | The deriving strategy that was assumed when not explicitly listed in the
-- source. This is used solely by the missing-deriving-strategies warning.
-- There's no `Via` case because we never assume that.
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 25a17e32a07..a20fe7475cd 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -288,6 +288,8 @@ instance Outputable GhcHint where
(hsep [text "deriving", ppr strat, text "instance", ppr deriv_sig])
SuggestParenthesizePatternRHS
-> text "Parenthesize the RHS of the view pattern"
+ SuggestSplittingIntoSeveralSpecialisePragmas
+ -> text "Split the SPECIALISE pragma into multiple pragmas, one for each type signature"
perhapsAsPat :: SDoc
perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs
index 51000d7ccfd..b337f82d2d5 100644
--- a/compiler/GHC/Types/Var.hs
+++ b/compiler/GHC/Types/Var.hs
@@ -572,7 +572,7 @@ information. In (FunTy { ft_af = af, ft_arg = t1, ft_res = t2 })
False True FTF_T_C
True False FTF_C_T
True True FTF_C_C
-where isPredTy is defined in GHC.Core.Type, and sees if t1's
+where isPredTy is defined in GHC.Core.Predicate, and sees if t1's
kind is Constraint. See GHC.Core.Type.chooseFunTyFlag, and
GHC.Core.TyCo.Rep Note [Types for coercions, predicates, and evidence]
diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
index ef917518093..b298916c8e9 100644
--- a/compiler/Language/Haskell/Syntax/Binds.hs
+++ b/compiler/Language/Haskell/Syntax/Binds.hs
@@ -355,9 +355,11 @@ data Sig pass
(LIdP pass) -- Function name
InlinePragma -- Never defaultInlinePragma
- -- | A specialisation pragma
+ -- | An old-form specialisation pragma
--
-- > {-# SPECIALISE f :: Int -> Int #-}
+ --
+ -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540)
| SpecSig (XSpecSig pass)
(LIdP pass) -- Specialise a function or datatype ...
[LHsSigType pass] -- ... to these types
@@ -365,6 +367,17 @@ data Sig pass
-- If it's just defaultInlinePragma, then we said
-- SPECIALISE, not SPECIALISE_INLINE
+ -- | A new-form specialisation pragma (see GHC Proposal #493)
+ -- e.g. {-# SPECIALISE f @Int 1 :: Int -> Int #-}
+ -- See Note [Overview of SPECIALISE pragmas]
+ | SpecSigE (XSpecSigE pass)
+ (RuleBndrs pass)
+ (LHsExpr pass) -- Expression to specialise
+ InlinePragma
+ -- The expression should be of form
+ -- f a1 ... an [ :: sig ]
+ -- with an optional type signature
+
-- | A specialisation pragma for instance declarations only
--
-- > {-# SPECIALISE instance Eq [Int] #-}
@@ -419,8 +432,9 @@ isTypeLSig (unXRec @p -> XSig {}) = True
isTypeLSig _ = False
isSpecLSig :: forall p. UnXRec p => LSig p -> Bool
-isSpecLSig (unXRec @p -> SpecSig {}) = True
-isSpecLSig _ = False
+isSpecLSig (unXRec @p -> SpecSig {}) = True
+isSpecLSig (unXRec @p -> SpecSigE {}) = True
+isSpecLSig _ = False
isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool
isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True
@@ -429,6 +443,7 @@ isSpecInstLSig _ = False
isPragLSig :: forall p. UnXRec p => LSig p -> Bool
-- Identifies pragmas
isPragLSig (unXRec @p -> SpecSig {}) = True
+isPragLSig (unXRec @p -> SpecSigE {}) = True
isPragLSig (unXRec @p -> InlineSig {}) = True
isPragLSig (unXRec @p -> SCCFunSig {}) = True
isPragLSig (unXRec @p -> CompleteMatchSig {}) = True
@@ -451,6 +466,40 @@ isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool
isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True
isCompleteMatchSig _ = False
+{- *********************************************************************
+* *
+ Rule binders
+* *
+********************************************************************* -}
+
+data RuleBndrs pass = RuleBndrs
+ { rb_ext :: XCRuleBndrs pass
+ -- After typechecking rb_ext contains /all/ the quantified variables
+ -- both term variables and type varibles
+ , rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
+ -- ^ User-written forall'd type vars; preserved for pretty-printing
+ , rb_tmvs :: [LRuleBndr (NoGhcTc pass)]
+ -- ^ User-written forall'd term vars; preserved for pretty-printing
+ }
+ | XRuleBndrs !(XXRuleBndrs pass)
+
+-- | Located Rule Binder
+type LRuleBndr pass = XRec pass (RuleBndr pass)
+
+-- | Rule Binder
+data RuleBndr pass
+ = RuleBndr (XCRuleBndr pass) (LIdP pass)
+ | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)
+ | XRuleBndr !(XXRuleBndr pass)
+ -- ^
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
+ -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose'
+
+ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
+
+collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]
+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
+
{-
************************************************************************
* *
diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs
index 84e14b427ff..7d9a6adb04b 100644
--- a/compiler/Language/Haskell/Syntax/Decls.hs
+++ b/compiler/Language/Haskell/Syntax/Decls.hs
@@ -1477,29 +1477,13 @@ data RuleDecl pass
-- ^ After renamer, free-vars from the LHS and RHS
, rd_name :: XRec pass RuleName
-- ^ Note [Pragma source text] in "GHC.Types.SourceText"
- , rd_act :: Activation
- , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
- -- ^ Forall'd type vars
- , rd_tmvs :: [LRuleBndr pass]
- -- ^ Forall'd term vars, before typechecking; after typechecking
- -- this includes all forall'd vars
- , rd_lhs :: XRec pass (HsExpr pass)
- , rd_rhs :: XRec pass (HsExpr pass)
+ , rd_act :: Activation
+ , rd_bndrs :: RuleBndrs pass
+ , rd_lhs :: XRec pass (HsExpr pass)
+ , rd_rhs :: XRec pass (HsExpr pass)
}
| XRuleDecl !(XXRuleDecl pass)
--- | Located Rule Binder
-type LRuleBndr pass = XRec pass (RuleBndr pass)
-
--- | Rule Binder
-data RuleBndr pass
- = RuleBndr (XCRuleBndr pass) (LIdP pass)
- | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)
- | XRuleBndr !(XXRuleBndr pass)
-
-collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]
-collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
-
{-
************************************************************************
* *
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 4d8fbaec0f3..8cd02485265 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -208,6 +208,7 @@ type family XIdSig x
type family XFixSig x
type family XInlineSig x
type family XSpecSig x
+type family XSpecSigE x
type family XSpecInstSig x
type family XMinimalSig x
type family XSCCFunSig x
@@ -363,6 +364,11 @@ type family XXRuleDecls x
type family XHsRule x
type family XXRuleDecl x
+-- -------------------------------------
+-- RuleBndrs type families
+type family XCRuleBndrs x
+type family XXRuleBndrs x
+
-- -------------------------------------
-- RuleBndr type families
type family XCRuleBndr x
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 97918c7242f..138963cbfff 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -824,7 +824,6 @@ Library
GHC.Tc.Gen.HsType
GHC.Tc.Gen.Match
GHC.Tc.Gen.Pat
- GHC.Tc.Gen.Rule
GHC.Tc.Gen.Sig
GHC.Tc.Gen.Splice
GHC.Tc.Instance.Class
diff --git a/docs/users_guide/9.14.1-notes.rst b/docs/users_guide/9.14.1-notes.rst
index af991ef04c2..de757db1a4a 100644
--- a/docs/users_guide/9.14.1-notes.rst
+++ b/docs/users_guide/9.14.1-notes.rst
@@ -11,6 +11,23 @@ for specific guidance on migrating programs to this release.
Language
~~~~~~~~
+* `GHC proposal 493: allow expressions in SPECIALISE pragmas <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0493-specialise-expressions.rst>`_
+ has been implemented. SPECIALISE pragmas now allow arbitrary expressions such as: ::
+
+ {-# SPECIALISE f @Int False :: Int -> Char #-}
+
+ The ability to specify multiple specialisations in a single SPECIALISE pragma,
+ with syntax of the form (note the comma between the type signatures): ::
+
+ {-# SPECIALISE g : Int -> Int, Float -> Float #-}
+
+ has been deprecated, and is scheduled to be removed in GHC 9.18.
+ This deprecation is controlled by the newly introduced ``-Wdeprecated-pragmas``
+ flag in ``-Wdefault``.
+
+* A new flag, `-Wuseless-specialisations`, controls warnings emitted when GHC
+ determines that a SPECIALISE pragma would have no effect.
+
* ``-Wincomplete-record-selectors`` is now part of `-Wall`, as specified
by `GHC Proposal 516: add warning for incomplete record selectors <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0516-incomplete-record-selectors.rst>`_.
Hence, if a library is compiled with ``-Werror``, compilation may now fail. Solution: fix the library.
@@ -102,6 +119,11 @@ Cmm
- The `ParStmtBlock` list argument of the `ParStmt` constructor of `StmtLR` is now `NonEmpty`.
+* As part of the implementation of `GHC proposal 493 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0493-specialise-expressions.rst>`_,
+ the `SpecSig` constructor of `Sig` has been deprecated. It is replaced by
+ the constructor `SpecSigE` which supports expressions at the head, rather than
+ a lone variable.
+
``ghc-heap`` library
~~~~~~~~~~~~~~~~~~~~
@@ -126,6 +148,13 @@ Cmm
``template-haskell`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+- As part of the implementation of `GHC proposal 493 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0493-specialise-expressions.rst>`_,
+ the ``SpecialiseP`` constructor of the Template Haskell ``Pragma`` type, as
+ well as the helpers ``pragSpecD`` and ``pragSpecInlD``, have been deprecated.
+
+ They are replaced, respectively, by ``SpecialiseEP``, ``pragSpecED`` and
+ ``pragSpecInlED``.
+
Included libraries
~~~~~~~~~~~~~~~~~~
diff --git a/docs/users_guide/exts/pragmas.rst b/docs/users_guide/exts/pragmas.rst
index 749b52a1578..545e339ebb8 100644
--- a/docs/users_guide/exts/pragmas.rst
+++ b/docs/users_guide/exts/pragmas.rst
@@ -692,24 +692,32 @@ The :pragma:`RULES` pragma lets you specify rewrite rules. It is described in
single: pragma, SPECIALIZE
single: overloading, death to
-.. pragma:: SPECIALIZE ⟨name⟩ :: ⟨type⟩
+.. pragma:: SPECIALIZE ⟨expr⟩
- Ask that GHC specialize a polymorphic value to a particular type.
+ Ask that GHC create a copy of a function with specific arguments; most
+ commonly, a copy of an overloaded function with specific class
+ dictionary arguments.
(UK spelling also accepted.) For key overloaded functions, you can
-create extra versions (NB: at the cost of larger code) specialised to particular
-types. Thus, if you have an overloaded function:
+create extra versions (NB: at the cost of larger code), specialised to specific
+arguments. Thus, if you have an overloaded function:
::
hammeredLookup :: Ord key => [(key, value)] -> key -> value
If it is heavily used on lists with ``Widget`` keys, you could
-specialise it as follows:
+specialise it with either of the following forms (the second syntax,
+introduced in GHC 9.14, additionally requires :extension:`TypeApplications`):
::
{-# SPECIALIZE hammeredLookup :: [(Widget, value)] -> Widget -> value #-}
+ {-# SPECIALIZE hammeredLookup @Widget #-}
+
+Instead of taking an unknown ``Ord key`` dictionary at runtime, the specialised
+version of ``hammeredLookup`` will use the specific implementation of ``Ord Widget``,
+which is likely to produce more efficient code.
- A ``SPECIALIZE`` pragma for a function can be put anywhere its type
signature could be put. Moreover, you can also ``SPECIALIZE`` an
@@ -755,15 +763,14 @@ specialise it as follows:
specialisation is done too early, the optimisation rules might fail
to fire.
-- The type in a ``SPECIALIZE`` pragma can be any type that is less
- polymorphic than the type of the original function. In concrete
- terms, if the original function is ``f`` then the pragma
+- The ``SPECIALIZE`` pragma is valid only if the expression is well-typed.
+ For example, a specialize pragma of the form
::
{-# SPECIALIZE f :: <type> #-}
- is valid if and only if the definition
+ is valid only if the definition
::
@@ -777,6 +784,7 @@ specialise it as follows:
f :: Eq a => a -> b -> b
{-# SPECIALISE f :: Int -> b -> b #-}
+ {-# SPECIALISE f @Float #-}
g :: (Eq a, Ix b) => a -> b -> b
{-# SPECIALISE g :: (Eq a) => a -> Int -> Int #-}
@@ -789,12 +797,28 @@ specialise it as follows:
fire very well. If you use this kind of specialisation, let us know
how well it works.
+- Since GHC 9.14, it is also possible to specialise a function at specific
+ value arguments, e.g.: ::
+
+ fn :: Bool -> Int -> Double
+ fn b i = ...
+ where
+ ... = if b then helper1 else helper2
+ {-# SPECIALISE fn True #-}
+ {-# SPECIALISE fn False #-}
+
+ This will make two copies of ``fn``, one for ``True`` and one for ``False``.
+ These will then be optimised to make direct calls to ``helper1`` or ``helper2``,
+ respectively, instead of dispatching on ``b`` at runtime.
+ Call sites (that use a literal ``True`` or ``False``) will be rewritten
+ to use the specialised versions.
+
.. _specialize-inline:
``SPECIALIZE INLINE``
~~~~~~~~~~~~~~~~~~~~~
-.. pragma:: SPECIALIZE INLINE ⟨name⟩ :: ⟨type⟩
+.. pragma:: SPECIALIZE INLINE ⟨expr⟩
:where: top-level
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index df5738ef3f5..299276ef6b3 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -422,6 +422,20 @@ of ``-W(no-)*``.
such as a `LANGUAGE` or `OPTIONS_GHC` pragma, appears in the body of
the module instead.
+.. ghc-flag:: -Wdeprecated-pragmas
+ :shortdesc: warn about deprecated pragmas
+ :type: dynamic
+ :reverse: -Wno-deprecated-pragmas
+ :category:
+
+ :since: 9.14
+
+ :default: on
+
+ Emits a warning when using a deprecated form of a SPECIALISE pragma which
+ uses multiple comma-separated type signatures (deprecated and scheduled
+ to be removed in GHC 9.18).
+
.. ghc-flag:: -Wmissed-specialisations
:shortdesc: warn when specialisation of an imported, overloaded function
fails.
@@ -476,6 +490,27 @@ of ``-W(no-)*``.
Alias for :ghc-flag:`-Wall-missed-specialisations`
+.. ghc-flag:: -Wuseless-specialisations
+ :shortdesc: warn on useless SPECIALISE pragmas
+ :type: dynamic
+ :reverse: -Wno-useless-specialisations
+ :category:
+
+ :since: 9.14
+
+ :default: on
+
+ Emits a warning if GHC detects a useless SPECIALISE pragma, such as a
+ SPECIALISE pragma on a non-overloaded function, for example
+ ``{-# SPECIALISE id :: Int -> Int #-}``.
+
+.. ghc-flag:: -Wuseless-specializations
+ :shortdesc: alias for :ghc-flag:`-Wuseless-specialisations`
+ :type: dynamic
+ :reverse: -Wno-useless-specializations
+
+ Alias for :ghc-flag:`-Wuseless-specialisations`
+
.. ghc-flag:: -Wextended-warnings
:shortdesc: warn about uses of functions & types that have WARNING or
DEPRECATED pragmas, across all categories
diff --git a/libraries/array b/libraries/array
index e7ffb82fd40..b362edee437 160000
--- a/libraries/array
+++ b/libraries/array
@@ -1 +1 @@
-Subproject commit e7ffb82fd40134da21d7642a41568f32c77c1a04
+Subproject commit b362edee437c88f2ac38971b66631ed782caa275
diff --git a/libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs b/libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
index ce3b1d44aad..f1d1471ba0a 100644
--- a/libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
+++ b/libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
@@ -653,21 +653,20 @@ instance Ppr Pragma where
<+> sep [ pprName' Applied n <+> dcolon
, nest 2 $ ppr ty ]
<+> text "#-}"
+ ppr (SpecialiseEP ty_bndrs tm_bndrs spec_e inline phases)
+ = sep [ text "{-# SPECIALISE"
+ <+> maybe empty ppr inline
+ <+> ppr phases
+ , nest 2 $ sep [ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs tm_bndrs
+ , nest 2 (ppr spec_e) ]
+ <+> text "#-}" ]
ppr (SpecialiseInstP inst)
= text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)
= sep [ text "{-# RULES" <+> pprString n <+> ppr phases
- , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs
+ , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs tm_bndrs
<+> ppr lhs
, nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
- where ppr_ty_forall Nothing = empty
- ppr_ty_forall (Just bndrs) = text "forall"
- <+> fsep (map ppr bndrs)
- <+> char '.'
- ppr_tm_forall Nothing | null tm_bndrs = empty
- ppr_tm_forall _ = text "forall"
- <+> fsep (map ppr tm_bndrs)
- <+> char '.'
ppr (AnnP tgt expr)
= text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
where target1 ModuleAnnotation = text "module"
@@ -681,6 +680,17 @@ instance Ppr Pragma where
ppr (SCCP nm str)
= text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}"
+ppr_ty_forall :: Maybe [TyVarBndr ()] -> Doc
+ppr_ty_forall Nothing = empty
+ppr_ty_forall (Just bndrs) = text "forall"
+ <+> fsep (map ppr bndrs)
+ <+> char '.'
+
+ppr_tm_forall :: Maybe [TyVarBndr ()] -> [RuleBndr] -> Doc
+ppr_tm_forall Nothing [] = empty
+ppr_tm_forall _ tm_bndrs = text "forall"
+ <+> fsep (map ppr tm_bndrs)
+ <+> char '.'
------------------------------
instance Ppr Inline where
ppr NoInline = text "NOINLINE"
diff --git a/libraries/ghc-internal/src/GHC/Internal/Float.hs b/libraries/ghc-internal/src/GHC/Internal/Float.hs
index 626ae94d9cc..0e5883428ba 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Float.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Float.hs
@@ -1217,8 +1217,8 @@ floatToDigits base x =
-- Converting from an Integer to a RealFloat
------------------------------------------------------------------------
-{-# SPECIALISE integerToBinaryFloat' :: Integer -> Float,
- Integer -> Double #-}
+{-# SPECIALISE integerToBinaryFloat' :: Integer -> Float #-}
+{-# SPECIALISE integerToBinaryFloat' :: Integer -> Double #-}
-- | Converts a positive integer to a floating-point value.
--
-- The value nearest to the argument will be returned.
@@ -1386,8 +1386,8 @@ Float or Double exploiting the known floatRadix and avoiding
divisions as much as possible.
-}
-{-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float,
- Int -> Int -> Integer -> Integer -> Double #-}
+{-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float #-}
+{-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Double #-}
fromRat'' :: RealFloat a => Int -> Int -> Integer -> Integer -> a
-- Invariant: n and d strictly positive
fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d =
diff --git a/libraries/ghc-internal/src/GHC/Internal/Numeric.hs b/libraries/ghc-internal/src/GHC/Internal/Numeric.hs
index 9e9c5da6a15..7650e08ad7c 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Numeric.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Numeric.hs
@@ -174,13 +174,16 @@ showInt n0 cs0
-- mutual module deps.
{-# SPECIALIZE showEFloat ::
- Maybe Int -> Float -> ShowS,
+ Maybe Int -> Float -> ShowS #-}
+{-# SPECIALIZE showEFloat ::
Maybe Int -> Double -> ShowS #-}
{-# SPECIALIZE showFFloat ::
- Maybe Int -> Float -> ShowS,
+ Maybe Int -> Float -> ShowS #-}
+{-# SPECIALIZE showFFloat ::
Maybe Int -> Double -> ShowS #-}
{-# SPECIALIZE showGFloat ::
- Maybe Int -> Float -> ShowS,
+ Maybe Int -> Float -> ShowS #-}
+{-# SPECIALIZE showGFloat ::
Maybe Int -> Double -> ShowS #-}
-- | Show a signed 'RealFloat' value
diff --git a/libraries/ghc-internal/src/GHC/Internal/Real.hs b/libraries/ghc-internal/src/GHC/Internal/Real.hs
index 7855911de3b..e6f668b8fa9 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Real.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Real.hs
@@ -746,10 +746,9 @@ x0 ^ y0 | y0 < 0 = errorWithoutStackTrace "Negative exponent"
| y0 == 0 = 1
| otherwise = powImpl x0 y0
-{-# SPECIALISE powImpl ::
- Integer -> Integer -> Integer,
- Integer -> Int -> Integer,
- Int -> Int -> Int #-}
+{-# SPECIALISE powImpl :: Integer -> Integer -> Integer #-}
+{-# SPECIALISE powImpl :: Integer -> Int -> Integer #-}
+{-# SPECIALISE powImpl :: Int -> Int -> Int #-}
{-# INLINABLE powImpl #-} -- See Note [Inlining (^)]
powImpl :: (Num a, Integral b) => a -> b -> a
-- powImpl : x0 ^ y0 = (x ^ y)
@@ -757,10 +756,9 @@ powImpl x y | even y = powImpl (x * x) (y `quot` 2)
| y == 1 = x
| otherwise = powImplAcc (x * x) (y `quot` 2) x -- See Note [Half of y - 1]
-{-# SPECIALISE powImplAcc ::
- Integer -> Integer -> Integer -> Integer,
- Integer -> Int -> Integer -> Integer,
- Int -> Int -> Int -> Int #-}
+{-# SPECIALISE powImplAcc :: Integer -> Integer -> Integer -> Integer #-}
+{-# SPECIALISE powImplAcc :: Integer -> Int -> Integer -> Integer #-}
+{-# SPECIALISE powImplAcc :: Int -> Int -> Int -> Int #-}
{-# INLINABLE powImplAcc #-} -- See Note [Inlining (^)]
powImplAcc :: (Num a, Integral b) => a -> b -> a -> a
-- powImplAcc : x0 ^ y0 = (x ^ y) * z
diff --git a/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs b/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
index 89cfad79313..063ed3db28b 100644
--- a/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
@@ -555,18 +555,45 @@ pragInlD name inline rm phases
pragOpaqueD :: Quote m => Name -> m Dec
pragOpaqueD name = pure $ PragmaD $ OpaqueP name
+{-# DEPRECATED pragSpecD "Please use 'pragSpecED' instead. 'pragSpecD' will be removed in GHC 9.18." #-}
pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec
pragSpecD n ty phases
= do
ty1 <- ty
pure $ PragmaD $ SpecialiseP n ty1 Nothing phases
+{-# DEPRECATED pragSpecInlD "Please use 'pragSpecInlED' instead. 'pragSpecInlD' will be removed in GHC 9.18." #-}
pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec
pragSpecInlD n ty inline phases
= do
ty1 <- ty
pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
+pragSpecED :: Quote m
+ => Maybe [m (TyVarBndr ())] -> [m RuleBndr]
+ -> m Exp
+ -> Phases
+ -> m Dec
+pragSpecED ty_bndrs tm_bndrs expr phases
+ = do
+ ty_bndrs1 <- traverse sequenceA ty_bndrs
+ tm_bndrs1 <- sequenceA tm_bndrs
+ expr1 <- expr
+ pure $ PragmaD $ SpecialiseEP ty_bndrs1 tm_bndrs1 expr1 Nothing phases
+
+pragSpecInlED :: Quote m
+ => Maybe [m (TyVarBndr ())] -> [m RuleBndr]
+ -> m Exp
+ -> Inline
+ -> Phases
+ -> m Dec
+pragSpecInlED ty_bndrs tm_bndrs expr inl phases
+ = do
+ ty_bndrs1 <- traverse sequenceA ty_bndrs
+ tm_bndrs1 <- sequenceA tm_bndrs
+ expr1 <- expr
+ pure $ PragmaD $ SpecialiseEP ty_bndrs1 tm_bndrs1 expr1 (Just inl) phases
+
pragSpecInstD :: Quote m => m Type -> m Dec
pragSpecInstD ty
= do
diff --git a/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs b/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
index a2e2e1ebd84..e77e37db7ef 100644
--- a/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
@@ -2165,7 +2165,11 @@ data Pragma = InlineP Name Inline RuleMatch Phases
| OpaqueP Name
-- ^ @{ {\-\# OPAQUE T #-} }@
| SpecialiseP Name Type (Maybe Inline) Phases
- -- ^ @{ {\-\# SPECIALISE [INLINE] [phases] T #-} }@
+ -- ^ @{ {\-\# SPECIALISE [INLINE] [phases] nm :: ty #-} }@
+ --
+ -- NB: this constructor is deprecated and will be removed in GHC 9.18
+ | SpecialiseEP (Maybe [TyVarBndr ()]) [RuleBndr] Exp (Maybe Inline) Phases
+ -- ^ @{ {\-\# SPECIALISE [INLINE] [phases] exp #-} }@
| SpecialiseInstP Type
-- ^ @{ {\-\# SPECIALISE instance I #-} }@
| RuleP String (Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 21f1c47e9a5..7e45b40b76b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -122,7 +122,9 @@ module Language.Haskell.TH.Lib (
-- **** Pragmas
ruleVar, typedRuleVar,
valueAnnotation, typeAnnotation, moduleAnnotation,
- pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
+ pragInlD, pragSpecD, pragSpecInlD,
+ pragSpecED, pragSpecInlED,
+ pragSpecInstD, pragRuleD, pragAnnD,
pragLineD, pragCompleteD,
-- **** Pattern Synonyms
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 9b9d9bb082d..62959eae085 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -4,6 +4,13 @@
* Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively.
+ * As part of the implementation of [GHC proposal 493](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0493-specialise-expressions.rst),
+ the ``SpecialiseP`` constructor of `Pragma`, as well as the helper functions
+ `pragSpecD` and `pragSpecInlD`, have been deprecated.
+
+ They are replaced, respectively, by `SpecialiseEP`, `pragSpecED` and
+ `pragSpecInlED`.
+
## 2.23.0.0
* Extend `Exp` with `ForallE`, `ForallVisE`, `ConstraintedE`,
diff --git a/testsuite/tests/deSugar/should_compile/T10251.stderr b/testsuite/tests/deSugar/should_compile/T10251.stderr
new file mode 100644
index 00000000000..60804a72fe1
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T10251.stderr
@@ -0,0 +1,5 @@
+T10251.hs:19:5: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+ Dubious SPECIALISE instance pragma.
+ The pragma does not specialise away any class dictionaries,
+ and neither is there any value specialisation.
+
diff --git a/testsuite/tests/diagnostic-codes/codes.stdout b/testsuite/tests/diagnostic-codes/codes.stdout
index f76653c468c..4f70f801859 100644
--- a/testsuite/tests/diagnostic-codes/codes.stdout
+++ b/testsuite/tests/diagnostic-codes/codes.stdout
@@ -9,10 +9,10 @@
- add test cases to exercise any newly uncovered diagnostic codes,
- accept the expected output of the 'codes' test by passing the '-a' flag to Hadrian.
-[GHC-93315] is untested (constructor = DsUselessSpecialiseForClassMethodSelector)
[GHC-58181] is untested (constructor = DsOrphanRule)
[GHC-69441] is untested (constructor = DsRuleLhsTooComplicated)
[GHC-19551] is untested (constructor = DsAggregatedViewExpressions)
+[GHC-93315] is untested (constructor = UselessSpecialiseForClassMethodSelector)
[GHC-09848] is untested (constructor = PsErrCmmParser)
[GHC-95644] is untested (constructor = PsErrBangPatWithoutSpace)
[GHC-45106] is untested (constructor = PsErrInvalidInfixHole)
@@ -61,6 +61,7 @@
[GHC-01570] is untested (constructor = TcRnExpectedValueId)
[GHC-96665] is untested (constructor = TcRnMultipleInlinePragmas)
[GHC-88293] is untested (constructor = TcRnUnexpectedPragmas)
+[GHC-35827] is untested (constructor = TcRnNonOverloadedSpecialisePragma)
[GHC-85337] is untested (constructor = TcRnSpecialiseNotVisible)
[GHC-91382] is untested (constructor = TcRnIllegalKindSignature)
[GHC-72520] is untested (constructor = TcRnIgnoreSpecialisePragmaOnDefMethod)
@@ -119,3 +120,5 @@
[GHC-75721] is untested (constructor = CannotRepresentType)
[GHC-17599] is untested (constructor = AddTopDeclsUnexpectedDeclarationSplice)
[GHC-86934] is untested (constructor = ClassPE)
+
+
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
index a683eb9ea87..e02a56c1b74 100644
--- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -20,6 +20,7 @@ import GHC
import qualified GHC.LanguageExtensions as LangExt
import Data.Either (fromRight)
+import Data.IORef
import Control.Monad.IO.Class (liftIO)
import System.Environment (getArgs)
@@ -46,8 +47,9 @@ main = do
let exts = extensionFlags dflags
hs_t = fromRight (error "convertToHsType") $
convertToHsType exts (Generated OtherExpansion SkipPmc) noSrcSpan th_t
+ skol_tv_ref <- liftIO (newIORef [])
(messages, mres) <-
- tcRnType hsc_env SkolemiseFlexi True hs_t
+ tcRnType hsc_env (SkolemiseFlexi skol_tv_ref) True hs_t
let (warnings, errors) = partitionMessages messages
case mres of
Nothing -> do
diff --git a/testsuite/tests/interface-stability/template-haskell-exports.stdout b/testsuite/tests/interface-stability/template-haskell-exports.stdout
index ba10b03b241..4104320282d 100644
--- a/testsuite/tests/interface-stability/template-haskell-exports.stdout
+++ b/testsuite/tests/interface-stability/template-haskell-exports.stdout
@@ -345,7 +345,7 @@ module Language.Haskell.TH where
ppr_list :: [a] -> GHC.Boot.TH.PprLib.Doc
{-# MINIMAL ppr #-}
type Pragma :: *
- data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseP Name Type (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)
+ data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseP Name Type (GHC.Internal.Maybe.Maybe Inline) Phases | 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 PredQ :: *
@@ -612,7 +612,9 @@ module Language.Haskell.TH where
pragLineD :: forall (m :: * -> *). Quote m => GHC.Internal.Types.Int -> GHC.Internal.Base.String -> m Dec
pragRuleD :: forall (m :: * -> *). Quote m => GHC.Internal.Base.String -> [m RuleBndr] -> m Exp -> m Exp -> Phases -> m Dec
pragSpecD :: forall (m :: * -> *). Quote m => Name -> m Type -> Phases -> m Dec
+ pragSpecED :: forall (m :: * -> *). Quote m => GHC.Internal.Maybe.Maybe [m (TyVarBndr ())] -> [m RuleBndr] -> m Exp -> Phases -> m Dec
pragSpecInlD :: forall (m :: * -> *). Quote m => Name -> m Type -> Inline -> Phases -> m Dec
+ pragSpecInlED :: forall (m :: * -> *). Quote m => GHC.Internal.Maybe.Maybe [m (TyVarBndr ())] -> [m RuleBndr] -> m Exp -> Inline -> Phases -> m Dec
pragSpecInstD :: forall (m :: * -> *). Quote m => m Type -> m Dec
prefixPatSyn :: forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prim :: Callconv
@@ -1117,7 +1119,9 @@ module Language.Haskell.TH.Lib where
pragLineD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.Types.Int -> GHC.Internal.Base.String -> m GHC.Internal.TH.Syntax.Dec
pragRuleD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.Base.String -> [m GHC.Internal.TH.Syntax.RuleBndr] -> m GHC.Internal.TH.Syntax.Exp -> m GHC.Internal.TH.Syntax.Exp -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
pragSpecD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.TH.Syntax.Name -> m GHC.Internal.TH.Syntax.Type -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
+ pragSpecED :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.Maybe.Maybe [m (GHC.Internal.TH.Syntax.TyVarBndr ())] -> [m GHC.Internal.TH.Syntax.RuleBndr] -> m GHC.Internal.TH.Syntax.Exp -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
pragSpecInlD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.TH.Syntax.Name -> m GHC.Internal.TH.Syntax.Type -> GHC.Internal.TH.Syntax.Inline -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
+ pragSpecInlED :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.Maybe.Maybe [m (GHC.Internal.TH.Syntax.TyVarBndr ())] -> [m GHC.Internal.TH.Syntax.RuleBndr] -> m GHC.Internal.TH.Syntax.Exp -> GHC.Internal.TH.Syntax.Inline -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
pragSpecInstD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => m GHC.Internal.TH.Syntax.Type -> m GHC.Internal.TH.Syntax.Dec
prefixPatSyn :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => [GHC.Internal.TH.Syntax.Name] -> m GHC.Internal.TH.Syntax.PatSynArgs
prim :: GHC.Internal.TH.Syntax.Callconv
@@ -1459,7 +1463,9 @@ module Language.Haskell.TH.Lib.Internal where
pragSCCFunD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.TH.Syntax.Name -> m GHC.Internal.TH.Syntax.Dec
pragSCCFunNamedD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.TH.Syntax.Name -> GHC.Internal.Base.String -> m GHC.Internal.TH.Syntax.Dec
pragSpecD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.TH.Syntax.Name -> m GHC.Internal.TH.Syntax.Type -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
+ pragSpecED :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.Maybe.Maybe [m (GHC.Internal.TH.Syntax.TyVarBndr ())] -> [m GHC.Internal.TH.Syntax.RuleBndr] -> m GHC.Internal.TH.Syntax.Exp -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
pragSpecInlD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.TH.Syntax.Name -> m GHC.Internal.TH.Syntax.Type -> GHC.Internal.TH.Syntax.Inline -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
+ pragSpecInlED :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => GHC.Internal.Maybe.Maybe [m (GHC.Internal.TH.Syntax.TyVarBndr ())] -> [m GHC.Internal.TH.Syntax.RuleBndr] -> m GHC.Internal.TH.Syntax.Exp -> GHC.Internal.TH.Syntax.Inline -> GHC.Internal.TH.Syntax.Phases -> m GHC.Internal.TH.Syntax.Dec
pragSpecInstD :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => m GHC.Internal.TH.Syntax.Type -> m GHC.Internal.TH.Syntax.Dec
prefixPatSyn :: forall (m :: * -> *). GHC.Internal.TH.Syntax.Quote m => [GHC.Internal.TH.Syntax.Name] -> m GHC.Internal.TH.Syntax.PatSynArgs
prim :: GHC.Internal.TH.Syntax.Callconv
@@ -2023,7 +2029,7 @@ module Language.Haskell.TH.Syntax where
type PkgName :: *
newtype PkgName = PkgName GHC.Internal.Base.String
type Pragma :: *
- data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseP Name Type (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)
+ data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseP Name Type (GHC.Internal.Maybe.Maybe Inline) Phases | 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
diff --git a/testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr b/testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr
index 01f62eb39d1..a3b566f42ad 100644
--- a/testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr
+++ b/testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr
@@ -1,3 +1,3 @@
-
-OpaqueParseWarn1.hs:6:1: warning: [GHC-38524]
+OpaqueParseWarn1.hs:6:1: warning: [GHC-38524] [-Wuseless-specialisations (in -Wdefault)]
Ignoring useless SPECIALISE pragma for NOINLINE function: ‘f’
+
diff --git a/testsuite/tests/parser/should_fail/T7848.stderr b/testsuite/tests/parser/should_fail/T7848.stderr
index ff24ae7b375..8ff99b1f1ab 100644
--- a/testsuite/tests/parser/should_fail/T7848.stderr
+++ b/testsuite/tests/parser/should_fail/T7848.stderr
@@ -1,11 +1,10 @@
-
-T7848.hs:10:9: error: [GHC-25897]
- • Couldn't match expected type ‘Char’ with actual type ‘a’
+T7848.hs:10:24: error: [GHC-25897]
+ • Couldn't match expected type ‘a’ with actual type ‘Char’
‘a’ is a rigid type variable bound by
- the type signature for:
- (&) :: forall a. a
- at T7848.hs:10:9-35
- • In the pragma: {-# SPECIALIZE (&) :: a #-}
+ an expression type signature:
+ forall a. a
+ at T7848.hs:10:31
+ • In the expression: (&) :: a
In an equation for ‘x’:
x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)
= y
@@ -15,3 +14,4 @@ T7848.hs:10:9: error: [GHC-25897]
{-# INLINE (&) #-}
{-# SPECIALIZE (&) :: a #-}
(&) = 'c'
+
diff --git a/testsuite/tests/simplCore/should_compile/DsSpecPragmas.hs b/testsuite/tests/simplCore/should_compile/DsSpecPragmas.hs
new file mode 100644
index 00000000000..9cd4fcfef7d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/DsSpecPragmas.hs
@@ -0,0 +1,147 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+
+module DsSpecPragmas where
+
+import Control.Monad.ST
+ ( ST )
+import Data.Kind
+ ( Constraint, Type )
+import Data.Proxy
+ ( Proxy(..) )
+
+-- Some specialise pragmas that are tricky to generate the correct RULE for.
+
+--------------------------------------------------------------------------------
+
+f1 :: ( Num a, Eq b ) => a -> b -> Int
+f1 _ _ = 111
+-- Make sure we don't generate a rule with an LHS of the form
+--
+-- forall @e (d :: Eq e). f1 @[e] ($fEqList d) = ...
+--
+-- but rather
+--
+-- forall @e (d :: Eq [e]). f1 @[e] d = ...
+{-# SPECIALISE f1 :: Eq [e] => Word -> [e] -> Int #-}
+
+f1_qc :: ( forall x. Eq x => Eq ( f x ), Eq a, Num b ) => Proxy f -> a -> b -> Char
+f1_qc _ _ _ = 'q'
+
+-- Like 'f1', but with a local instance (quantified constraint).
+{-# SPECIALISE f1_qc :: ( forall y. Eq y => Eq ( g y ), Eq ( g e ) ) => Proxy g -> g e -> Word -> Char #-}
+
+--------------------------------------------------------------------------------
+
+f2 :: ( Eq a, Eq b, Num c ) => a -> b -> c -> Int
+f2 _ _ _ = 2
+
+-- Make sure the rule LHS is of the form
+--
+-- f2 @c @c d1 d2 and not f2 @c @c d d
+{-# SPECIALISE f2 :: Eq c => c -> c -> Word -> Int #-}
+
+--------------------------------------------------------------------------------
+
+f3 :: ( Eq a, forall x. Eq x => Eq ( f x ) ) => f a -> Bool
+f3 z = z == z
+
+-- Discharge the quantified constraint but keep the 'Eq' constraint
+{-# SPECIALISE f3 :: Eq c => [ c ] -> Bool #-}
+
+-- Discharge the 'Eq' constraint but keep the quantified constraint
+{-# SPECIALISE f3 :: ( forall y. Eq y => Eq ( g y ) ) => g Int -> Bool #-}
+
+--------------------------------------------------------------------------------
+
+f4 :: (Eq a, Monad m) => a -> m a
+f4 = return
+
+-- Check we can deal with locally quantified variables in constraints,
+-- in this case 'Monad (ST s)'.
+{-# SPECIALISE f4 :: forall s b. Eq b => b -> ST s b #-}
+
+f4_qc :: (Eq a, forall m. Monad m => Monad (t m)) => t m a -> ()
+f4_qc _ = ()
+
+-- Like 'f4' but with a quantified constraint.
+{-# SPECIALISE f4_qc :: forall r n b. (forall m. Monad m => Monad (r m)) => r n Int -> () #-}
+
+--------------------------------------------------------------------------------
+
+type family T a where
+ T Int = Word
+data D a = D a (T a)
+deriving stock instance (Eq a, Eq (T a)) => Eq (D a)
+
+f5 :: Eq a => a -> Bool
+f5 x = x == x
+
+-- Discharge a dictionary constraint using a top-level instance
+-- whose context contains a type family application.
+{-# SPECIALISE f5 :: D Int -> Bool #-}
+
+
+f5_qc :: ( Eq a, Eq ( T a ), forall x. ( Eq x, Eq ( T x ) ) => Eq ( f x ) ) => f a -> Bool
+f5_qc z = z == z
+
+-- Discharge a quantified constraint using a top-level instance
+-- whose context includes a type family application.
+{-# SPECIALISE f5_qc :: D Int -> Bool #-}
+
+-- Quantify over this same quantified constraint, but discharge the
+-- other dictionary constraints.
+{-# SPECIALISE f5_qc :: ( forall y. ( Eq y, Eq ( T y ) ) => Eq ( g y ) ) => g Int -> Bool #-}
+
+--------------------------------------------------------------------------------
+
+f6 :: ( Eq a, Ord b, Num c ) => a -> b -> c -> Char
+f6 _ _ _ = 'c'
+
+-- Check that we do perform simplification among Wanteds that we quantify over.
+{-# SPECIALISE f6 :: Ord c => c -> c -> Word -> Char #-}
+
+
+f6_qc :: ( forall x. Eq x => Eq ( f x ), forall y. Eq y => Ord ( g y ), Num c ) => Proxy f -> Proxy g -> c -> Char
+f6_qc _ _ _ = 'd'
+
+-- Like 'f6', but with quantified constraints.
+{-# SPECIALISE f6_qc :: ( forall z. Eq z => Ord ( h z ) ) => Proxy h -> Proxy h -> Word -> Char #-}
+
+--------------------------------------------------------------------------------
+
+type Cls :: Type -> Constraint
+class Cls a where {}
+
+type TF :: Type -> Type
+type family TF a = r | r -> a where
+ TF Int = Bool
+
+f7 :: ( Cls ( TF a ), Eq a ) => a -> a
+f7 x = x
+{-# SPECIALISE f7 :: Cls Bool => Int -> Int #-}
+
+--------------------------------------------------------------------------------
+-- An example taken from the Cabal library (buildInfoFieldGrammar).
+
+type F :: ( Type -> Constraint ) -> ( Type -> Type ) -> Constraint
+class F c g | g -> c where {}
+
+type C :: Type -> Constraint
+class C a where
+instance C (a, b) where {}
+
+type G :: Type -> Type
+data G a where
+
+instance F C G
+
+qcfd :: ( F c g, forall a b. c (a, b) ) => g ()
+qcfd = let x = x in x
+{-# SPECIALISE qcfd :: G () #-}
+
+--------------------------------------------------------------------------------
diff --git a/testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr b/testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr
new file mode 100644
index 00000000000..194810d914a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr
@@ -0,0 +1,75 @@
+
+==================== Tidy Core rules ====================
+"USPEC f1 @Word @[e]"
+ forall (@e) ($dEq :: Eq [e]) ($dNum :: Num Word).
+ f1 @Word @[e] $dNum $dEq
+ = \ _ [Occ=Dead] _ [Occ=Dead] -> I# 111#
+"USPEC f1_qc @_ @(g e) @Word"
+ forall (@e)
+ (@(g :: * -> *))
+ ($dNum :: Num Word)
+ ($dEq :: Eq (g e))
+ (df :: forall x. Eq x => Eq (g x)).
+ f1_qc @g @(g e) @Word df $dEq $dNum
+ = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> C# 'q'#
+"USPEC f2 @_ @_ @Word"
+ forall (@c) ($dNum :: Num Word) ($dEq :: Eq c) ($dEq1 :: Eq c).
+ f2 @c @c @Word $dEq1 $dEq $dNum
+ = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> I# 2#
+"USPEC f3 @Int @_"
+ forall (@(g :: * -> *))
+ (df :: forall x. Eq x => Eq (g x))
+ ($dEq :: Eq Int).
+ f3 @Int @g $dEq df
+ = f3_$sf3 @g df
+"USPEC f3 @_ @[]"
+ forall (@c) (df :: forall x. Eq x => Eq [x]) ($dEq :: Eq c).
+ f3 @c @[] $dEq df
+ = f3_$sf1 @c $dEq
+"USPEC f4 @_ @(ST s)"
+ forall (@s) (@b) ($dMonad :: Monad (ST s)) ($dEq :: Eq b).
+ f4 @b @(ST s) $dEq $dMonad
+ = $fApplicativeST_$cpure @s @b
+"USPEC f4_qc @Int @_ @_"
+ forall (@(n :: * -> *))
+ (@(r :: (* -> *) -> * -> *))
+ (df :: forall (m :: * -> *). Monad m => Monad (r m))
+ ($dEq :: Eq Int).
+ f4_qc @Int @r @n $dEq df
+ = \ _ [Occ=Dead] -> ()
+"USPEC f5 @(D Int)"
+ forall ($dEq :: Eq (D Int)). f5 @(D Int) $dEq = f5_$sf5
+"USPEC f5_qc @Int @D"
+ forall (df :: forall x. (Eq x, Eq (T x)) => Eq (D x))
+ ($dEq :: Eq (T Int))
+ ($dEq1 :: Eq Int).
+ f5_qc @Int @D $dEq1 $dEq df
+ = f5_$sf5
+"USPEC f5_qc @Int @_"
+ forall (@(g :: * -> *))
+ (df :: forall x. (Eq x, Eq (T x)) => Eq (g x))
+ ($dEq :: Eq (T Int))
+ ($dEq1 :: Eq Int).
+ f5_qc @Int @g $dEq1 $dEq df
+ = f5_qc_$sf5_qc @g df
+"USPEC f6 @_ @_ @Word"
+ forall (@c) ($dNum :: Num Word) ($dOrd :: Ord c) ($dEq :: Eq c).
+ f6 @c @c @Word $dEq $dOrd $dNum
+ = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> C# 'c'#
+"USPEC f6_qc @_ @_ @Word"
+ forall (@(h :: * -> *))
+ ($dNum :: Num Word)
+ (df :: forall y. Eq y => Ord (h y))
+ (df1 :: forall x. Eq x => Eq (h x)).
+ f6_qc @h @h @Word df1 df $dNum
+ = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> C# 'd'#
+"USPEC f7 @Int"
+ forall ($dEq :: Eq Int) ($dCls :: Cls (TF Int)).
+ f7 @Int $dCls $dEq
+ = \ (x [Occ=Once1] :: Int) -> x
+"USPEC qcfd @C @G"
+ forall (df :: forall a b. C (a, b)) ($dF :: F C G).
+ qcfd @C @G $dF df
+ = qcfd_x
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T12603.stdout b/testsuite/tests/simplCore/should_compile/T12603.stdout
index b5423adf1a2..229db972cf9 100644
--- a/testsuite/tests/simplCore/should_compile/T12603.stdout
+++ b/testsuite/tests/simplCore/should_compile/T12603.stdout
@@ -1 +1 @@
- = case GHC.Internal.Real.$w$spowImpl1 2# 8# of v { __DEFAULT ->
+ = case GHC.Internal.Real.$w$spowImpl 2# 8# of v { __DEFAULT ->
diff --git a/testsuite/tests/simplCore/should_compile/T15445.stderr b/testsuite/tests/simplCore/should_compile/T15445.stderr
index 7aab8340496..eaa4f2aee3a 100644
--- a/testsuite/tests/simplCore/should_compile/T15445.stderr
+++ b/testsuite/tests/simplCore/should_compile/T15445.stderr
@@ -8,6 +8,7 @@ Rule fired: Class op show (BUILTIN)
Rule fired: USPEC plusTwoRec @Int (T15445a)
Rule fired: Class op enumFromTo (BUILTIN)
Rule fired: Class op show (BUILTIN)
+Rule fired: USPEC plusTwoRec @Int (T15445a)
Rule fired: Class op enumFromTo (BUILTIN)
Rule fired: eftIntList (GHC.Internal.Enum)
Rule fired: ># (BUILTIN)
diff --git a/testsuite/tests/simplCore/should_compile/T24359a.hs b/testsuite/tests/simplCore/should_compile/T24359a.hs
new file mode 100644
index 00000000000..cf2513f63f5
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T24359a.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TypeApplications, ExplicitForAll #-}
+
+module T24359a where
+
+data UA i = UA !i
+
+class IArray a where
+ bounds :: a i -> i
+
+showsIArray :: (IArray a, Show i) => a i -> String
+showsIArray a = show (bounds a)
+
+{-# SPECIALISE
+ showsIArray :: (Show i) => UA i -> String
+ #-}
+
+instance IArray UA where
+ bounds (UA u) = u
diff --git a/testsuite/tests/simplCore/should_compile/T24359a.stderr b/testsuite/tests/simplCore/should_compile/T24359a.stderr
new file mode 100644
index 00000000000..6d7905155cf
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T24359a.stderr
@@ -0,0 +1,7 @@
+
+==================== Tidy Core rules ====================
+"USPEC showsIArray @UA @_"
+ forall (@i) ($dShow :: Show i) ($dIArray :: IArray UA).
+ showsIArray @UA @i $dIArray $dShow
+ = showsIArray_$sshowsIArray @i $dShow
+
diff --git a/testsuite/tests/simplCore/should_compile/T25389.hs b/testsuite/tests/simplCore/should_compile/T25389.hs
new file mode 100644
index 00000000000..d248f5b1a03
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T25389.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+
+{-# OPTIONS_GHC -Wno-useless-specialisations #-}
+
+module T25389 where
+
+data Example (b :: Bool) where
+ Ex1 :: Int -> Example True
+ Ex2 :: Example False
+
+expensive :: Int -> Int
+expensive = (*2)
+
+{-# SPECIALISE INLINE op :: Example False -> Int #-}
+op :: Example b -> Int
+op e = case e of
+ Ex1 i -> expensive i
+ Ex2 -> 0
diff --git a/testsuite/tests/simplCore/should_compile/T25389.stderr b/testsuite/tests/simplCore/should_compile/T25389.stderr
new file mode 100644
index 00000000000..26db8c66e45
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T25389.stderr
@@ -0,0 +1,103 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 34, types: 46, coercions: 2, joins: 0/0}
+
+-- RHS size: {terms: 3, types: 2, coercions: 1, joins: 0/0}
+T25389.$WEx1 [InlPrag=INLINE[final] CONLIKE]
+ :: Int %1 -> Example True
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<L>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
+ Tmpl= \ (conrep [Occ=Once1] :: Int) ->
+ T25389.Ex1
+ @True @~(<True>_N :: True GHC.Internal.Prim.~# True) conrep}]
+T25389.$WEx1
+ = \ (conrep [Occ=Once1] :: Int) ->
+ T25389.Ex1
+ @True @~(<True>_N :: True GHC.Internal.Prim.~# True) conrep
+
+-- RHS size: {terms: 1, types: 1, coercions: 1, joins: 0/0}
+T25389.$WEx2 [InlPrag=INLINE[final] CONLIKE] :: Example False
+[GblId[DataConWrapper],
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)
+ Tmpl= T25389.Ex2
+ @False @~(<False>_N :: False GHC.Internal.Prim.~# False)}]
+T25389.$WEx2
+ = T25389.Ex2
+ @False @~(<False>_N :: False GHC.Internal.Prim.~# False)
+
+-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
+expensive :: Int -> Int
+[GblId,
+ Arity=1,
+ Str=<1!P(L)>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (v [Occ=Once1!] :: Int) ->
+ case v of { GHC.Internal.Types.I# x [Occ=Once1] ->
+ GHC.Internal.Types.I# (GHC.Internal.Prim.*# x 2#)
+ }}]
+expensive
+ = \ (v :: Int) ->
+ case v of { GHC.Internal.Types.I# x ->
+ GHC.Internal.Types.I# (GHC.Internal.Prim.*# x 2#)
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T25389.op1 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+T25389.op1 = GHC.Internal.Types.I# 0#
+
+-- RHS size: {terms: 5, types: 9, coercions: 0, joins: 0/0}
+T25389.op_$sop [InlPrag=INLINE (sat-args=1)]
+ :: Example False -> Int
+[GblId,
+ Arity=1,
+ Str=<1L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
+ Tmpl= \ (e [Occ=Once1!] :: Example False) ->
+ case e of { Ex2 _ [Occ=Dead] -> T25389.op1 }}]
+T25389.op_$sop
+ = \ (e :: Example False) ->
+ case e of { Ex2 co [Dmd=B] -> T25389.op1 }
+
+-- RHS size: {terms: 9, types: 16, coercions: 0, joins: 0/0}
+op :: forall (b :: Bool). Example b -> Int
+[GblId,
+ Arity=1,
+ Str=<1L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@(b :: Bool)) (e [Occ=Once1!] :: Example b) ->
+ case e of {
+ Ex1 _ [Occ=Dead] i [Occ=Once1] -> expensive i;
+ Ex2 _ [Occ=Dead] -> T25389.op1
+ }}]
+op
+ = \ (@(b :: Bool)) (e :: Example b) ->
+ case e of {
+ Ex1 co [Dmd=B] i -> expensive i;
+ Ex2 co [Dmd=B] -> T25389.op1
+ }
+
+
+------ Local rules for imported ids --------
+"USPEC op @'False" forall. op @False = T25389.op_$sop
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T4398.stderr b/testsuite/tests/simplCore/should_compile/T4398.stderr
index 04b2db98e60..575703df874 100644
--- a/testsuite/tests/simplCore/should_compile/T4398.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4398.stderr
@@ -1,6 +1,6 @@
-
T4398.hs:6:11: warning: [GHC-40548]
Forall'd constraint ‘Ord a’ is not bound in RULE lhs
Orig bndrs: [a, $dOrd, x, y]
Orig lhs: f @a ((\ ($dOrd :: Ord a) -> x) $dOrd) y
- optimised lhs: f @a x y
+ Optimised lhs: f @a x y
+
diff --git a/testsuite/tests/simplCore/should_compile/T5821.hs b/testsuite/tests/simplCore/should_compile/T5821.hs
index 762254cb548..5fceb605a4d 100644
--- a/testsuite/tests/simplCore/should_compile/T5821.hs
+++ b/testsuite/tests/simplCore/should_compile/T5821.hs
@@ -9,3 +9,6 @@ foo :: Num a => a -> T a
foo = undefined
{-# SPECIALISE foo :: Int -> Bool #-}
+{- # SPECIALISE (foo :: Int -> Bool) # -}
+{- # SPECIALISE forall x. foo (x::Int) :: Bool # -}
+{- # SPECIALISE forall x. (foo :: Int -> Bool) x # -}
diff --git a/testsuite/tests/simplCore/should_compile/T8537.stderr b/testsuite/tests/simplCore/should_compile/T8537.stderr
index 8d85318f06d..805d9bd5e2e 100644
--- a/testsuite/tests/simplCore/should_compile/T8537.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8537.stderr
@@ -1,3 +1,5 @@
+T8537.hs:20:5: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+ Dubious SPECIALISE pragma for ‘fmap’.
+ The pragma does not specialise away any class dictionaries,
+ and neither is there any value specialisation.
-T8537.hs:20:5: warning: [GHC-35827]
- SPECIALISE pragma for non-overloaded function ‘fmap’
diff --git a/testsuite/tests/simplCore/should_compile/T9578b.hs b/testsuite/tests/simplCore/should_compile/T9578b.hs
new file mode 100644
index 00000000000..05534c1b803
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T9578b.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RoleAnnotations #-}
+
+module Main where
+
+import Data.Array.Byte
+ ( ByteArray(..) )
+import Data.Ix
+ ( Ix, range, index, rangeSize )
+import GHC.Show
+ ( appPrec )
+import GHC.Exts
+ ( Int(..), ByteArray#, indexWord64Array# )
+import GHC.IsList
+ ( fromList )
+import GHC.Word
+ ( Word8, Word64(..) )
+
+data UArray i e = UArray !i !i !Int ByteArray#
+type role UArray nominal nominal
+
+class IArray a e where
+ bounds :: Ix i => a i e -> (i,i)
+ numElements :: Ix i => a i e -> Int
+ unsafeAt :: Ix i => a i e -> Int -> e
+
+{-# INLINE safeRangeSize #-}
+safeRangeSize :: Ix i => (i, i) -> Int
+safeRangeSize (l,u) = let r = rangeSize (l, u)
+ in if r < 0 then error "Negative range size"
+ else r
+
+{-# INLINE safeIndex #-}
+safeIndex :: Ix i => (i, i) -> Int -> i -> Int
+safeIndex (l,u) n i = let i' = index (l,u) i
+ in if (0 <= i') && (i' < n)
+ then i'
+ else error ("Error in array index; " ++ show i' ++
+ " not in range [0.." ++ show n ++ ")")
+
+{-# INLINE (!) #-}
+-- | Returns the element of an immutable array at the specified index,
+-- or throws an exception if the index is out of bounds.
+(!) :: (IArray a e, Ix i) => a i e -> i -> e
+(!) arr i = case bounds arr of
+ (l,u) -> unsafeAt arr $ safeIndex (l,u) (numElements arr) i
+
+
+{-# INLINE assocs #-}
+-- | Returns the contents of an array as a list of associations.
+assocs :: (IArray a e, Ix i) => a i e -> [(i, e)]
+assocs arr = case bounds arr of
+ (l,u) -> [(i, arr ! i) | i <- range (l,u)]
+
+showsIArray :: (IArray a e, Ix i, Show i, Show e) => Int -> a i e -> ShowS
+showsIArray p a =
+ showParen (p > appPrec) $
+ showString "array " .
+ shows (bounds a) .
+ showChar ' ' .
+ shows (assocs a)
+
+{-# SPECIALISE
+ showsIArray :: (IArray UArray e, Ix i, Show i, Show e) =>
+ Int -> UArray i e -> ShowS
+ #-}
+
+instance IArray UArray Word64 where
+ {-# INLINE bounds #-}
+ bounds (UArray l u _ _) = (l,u)
+ {-# INLINE numElements #-}
+ numElements (UArray _ _ n _) = n
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#)
+
+instance (Ix ix, Show ix, Show e, IArray UArray e) => Show (UArray ix e) where
+ showsPrec = showsIArray
+
+
+main :: IO ()
+main = do
+ let ba :: ByteArray#
+ ByteArray ba = fromList ( replicate (2 * 8) 0 :: [ Word8 ] )
+ print (UArray 0 1 2 ba :: UArray Int Word64)
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 9fb64293a68..8a2d21c8c42 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -502,6 +502,7 @@ test('T23491d', [extra_files(['T23491.hs']), grep_errmsg(r'Static argument')], m
test('T23074', normal, compile, ['-O -ddump-rules'])
test('T23272', [only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -O')], ghci_script, ['T23272.script'])
test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -v0'])
+test('DsSpecPragmas', normal, compile, ['-O -ddump-rules'])
# The -ddump-simpl of T22404 should have no let-bindings
test('T22404', [only_ways(['optasm']), check_errmsg(r'let') ], compile, ['-ddump-simpl -dsuppress-uniques'])
@@ -532,4 +533,6 @@ test('T24725a', [ grep_errmsg(r'testedRule')], compile, ['-O -ddump-rule-firings
test('T25033', normal, compile, ['-O'])
test('T25160', normal, compile, ['-O -ddump-rules'])
test('T25197', [req_th, extra_files(["T25197_TH.hs"]), only_ways(['optasm'])], multimod_compile, ['T25197', '-O2 -v0'])
+test('T25389', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
+test('T24359a', normal, compile, ['-O -ddump-rules'])
test('T25713', [grep_errmsg('W:::')], compile, ['-O -ddump-simpl'])
diff --git a/testsuite/tests/simplCore/should_compile/simpl016.stderr b/testsuite/tests/simplCore/should_compile/simpl016.stderr
deleted file mode 100644
index 2c6e508c73e..00000000000
--- a/testsuite/tests/simplCore/should_compile/simpl016.stderr
+++ /dev/null
@@ -1,10 +0,0 @@
-simpl016.hs:7:1: warning: [GHC-40548]
- Forall'd constraint ‘Num b’ is not bound in RULE lhs
- Orig bndrs: [b, $dNum]
- Orig lhs: let {
- $dEq :: Eq Int
- [LclId]
- $dEq = GHC.Internal.Classes.$fEqInt } in
- delta' @Int @b $dEq
- optimised lhs: delta' @Int @b $dEq
-
diff --git a/testsuite/tests/simplCore/should_fail/T25117a.hs b/testsuite/tests/simplCore/should_fail/T25117a.hs
new file mode 100644
index 00000000000..3ab2bce9ebe
--- /dev/null
+++ b/testsuite/tests/simplCore/should_fail/T25117a.hs
@@ -0,0 +1,6 @@
+module T25117a where
+
+f :: Ord a => a -> a
+f = f
+
+{-# SPECIALISE let x = 2 in f x #-}
diff --git a/testsuite/tests/simplCore/should_fail/T25117a.stderr b/testsuite/tests/simplCore/should_fail/T25117a.stderr
new file mode 100644
index 00000000000..f4131cb7a28
--- /dev/null
+++ b/testsuite/tests/simplCore/should_fail/T25117a.stderr
@@ -0,0 +1,2 @@
+T25117a.hs:6:1: error: [GHC-93944]
+ Illegal form of SPECIALISE pragma: let x = 2 in f x
diff --git a/testsuite/tests/simplCore/should_fail/T25117b.hs b/testsuite/tests/simplCore/should_fail/T25117b.hs
new file mode 100644
index 00000000000..8d89c5c4908
--- /dev/null
+++ b/testsuite/tests/simplCore/should_fail/T25117b.hs
@@ -0,0 +1,7 @@
+module T25117b where
+
+f :: Num a => a -> a
+f = f
+
+-- We don't allow old-form multiple type ascriptions
+{-# SPECIALISE forall . f :: Int->Int, Float->Float #-}
diff --git a/testsuite/tests/simplCore/should_fail/T25117b.stderr b/testsuite/tests/simplCore/should_fail/T25117b.stderr
new file mode 100644
index 00000000000..b68403c0348
--- /dev/null
+++ b/testsuite/tests/simplCore/should_fail/T25117b.stderr
@@ -0,0 +1,5 @@
+T25117b.hs:7:27: error: [GHC-62037]
+ SPECIALISE expression doesn't support multiple type ascriptions
+ Suggested fix:
+ Split the SPECIALISE pragma into multiple pragmas, one for each type signature
+
diff --git a/testsuite/tests/simplCore/should_fail/all.T b/testsuite/tests/simplCore/should_fail/all.T
index 85411e69dbb..87781924811 100644
--- a/testsuite/tests/simplCore/should_fail/all.T
+++ b/testsuite/tests/simplCore/should_fail/all.T
@@ -2,5 +2,7 @@ test('T7411', [expect_broken_for(7411, ['optasm', 'optllvm',
'threaded2', 'dyn']),
exit_code(1)], compile_and_run, [''])
+test('T25117a', normal, compile_fail, [''])
+test('T25117b', normal, compile_fail, [''])
# This one produces a warning
test('T25672', normal, compile, ['-O'])
diff --git a/testsuite/tests/simplCore/should_run/T24359b.hs b/testsuite/tests/simplCore/should_run/T24359b.hs
new file mode 100644
index 00000000000..c742d8c9822
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T24359b.hs
@@ -0,0 +1,24 @@
+-- At some point when developing the new capability for
+-- #24359 (SEPECIALISE pragmas on values), this program
+-- went into a in infinite loop. So just keeping it here
+-- as a rgression test
+
+module Main where
+
+data UA i = UA !i
+
+class IArray a where
+ bounds :: a i -> i
+
+showsIArray :: (IArray a, Show i) => a i -> String
+showsIArray a = show (bounds a)
+
+{-# SPECIALISE
+ showsIArray :: (Show i) => UA i -> String
+ #-}
+
+instance IArray UA where
+ bounds (UA u) = u
+
+main :: IO ()
+main = putStrLn $ showsIArray (UA 1 :: UA Int)
diff --git a/testsuite/tests/simplCore/should_run/T24359b.stdout b/testsuite/tests/simplCore/should_run/T24359b.stdout
new file mode 100644
index 00000000000..d00491fd7e5
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T24359b.stdout
@@ -0,0 +1 @@
+1
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index f662cdf9dfa..8857537c403 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -118,3 +118,4 @@ test('T23056', [only_ways(['ghci-opt'])], ghci_script, ['T23056.script'])
test('T24725', normal, compile_and_run, ['-O -dcore-lint'])
test('T25096', normal, compile_and_run, ['-O -dcore-lint'])
test('AppIsHNF', normal, compile_and_run, ['-O'])
+test('T24359b', normal, compile_and_run, ['-O'])
diff --git a/testsuite/tests/th/T13123.stderr b/testsuite/tests/th/T13123.stderr
new file mode 100644
index 00000000000..df56637b0c9
--- /dev/null
+++ b/testsuite/tests/th/T13123.stderr
@@ -0,0 +1,5 @@
+T13123.hs:15:2: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+ Dubious SPECIALISE pragma for ‘id2’.
+ The pragma does not specialise away any class dictionaries,
+ and neither is there any value specialisation.
+
diff --git a/testsuite/tests/th/T19363.stdout b/testsuite/tests/th/T19363.stdout
index a6f3fee5b59..555ef4eeeed 100644
--- a/testsuite/tests/th/T19363.stdout
+++ b/testsuite/tests/th/T19363.stdout
@@ -9,9 +9,9 @@ infix 5 `f_6`
(%%_7) :: [a_8] -> [a_8] -> [a_8]
(%%_7) = (GHC.Internal.Base.++)
{-# INLINE (%%_7) #-}
-{-# SPECIALISE (%%_7) ::
- GHC.Internal.Base.String ->
- GHC.Internal.Base.String -> GHC.Internal.Base.String #-}
+{-# SPECIALISE
+ (%%_7) :: GHC.Internal.Base.String ->
+ GHC.Internal.Base.String -> GHC.Internal.Base.String #-}
{-# ANN (%%_7) "blah" #-}
g_9 ((:**_2) {(^**_3) = x_10}) = x_10
pattern a_11 `H_12` b_13 = (a_11, b_13)
diff --git a/testsuite/tests/th/T7064.stdout b/testsuite/tests/th/T7064.stdout
index 0d37f3cd108..e6dd25ab715 100644
--- a/testsuite/tests/th/T7064.stdout
+++ b/testsuite/tests/th/T7064.stdout
@@ -7,12 +7,12 @@ f3_0 x_1 = 3
g1_0 x_1 = 1
g2_0 x_1 = 2
g3_0 x_1 = 3
-{-# SPECIALISE g1_0 ::
- GHC.Internal.Types.Int -> GHC.Internal.Types.Int #-}
-{-# SPECIALISE [2] g2_0 ::
- GHC.Internal.Types.Int -> GHC.Internal.Types.Int #-}
-{-# SPECIALISE INLINE [~2] g3_0 ::
- GHC.Internal.Types.Int -> GHC.Internal.Types.Int #-}
+{-# SPECIALISE
+ g1_0 :: GHC.Internal.Types.Int -> GHC.Internal.Types.Int #-}
+{-# SPECIALISE [2]
+ g2_0 :: GHC.Internal.Types.Int -> GHC.Internal.Types.Int #-}
+{-# SPECIALISE INLINE [~2]
+ g3_0 :: GHC.Internal.Types.Int -> GHC.Internal.Types.Int #-}
data T_0 a_1 = T_2 a_1
instance GHC.Internal.Classes.Eq a_0 => GHC.Internal.Classes.Eq (T_1 a_0)
where {{-# SPECIALISE instance GHC.Internal.Classes.Eq (T_1 GHC.Internal.Types.Int) #-};
diff --git a/testsuite/tests/th/TH_pragma.hs b/testsuite/tests/th/TH_pragma.hs
index a78b5483fe5..6f53a896c58 100644
--- a/testsuite/tests/th/TH_pragma.hs
+++ b/testsuite/tests/th/TH_pragma.hs
@@ -10,3 +10,7 @@ $( [d| foo :: Int -> Int
$( [d| bar :: Num a => a -> a
{-# SPECIALISE INLINE [~1] bar :: Float -> Float #-}
bar x = x * 10 |] )
+
+$( [d| baz :: Num a => a -> a
+ {-# SPECIALISE INLINE [~1] baz @Double #-}
+ baz x = x * 10 |] )
diff --git a/testsuite/tests/th/TH_pragma.stderr b/testsuite/tests/th/TH_pragma.stderr
index 0baf21c564c..978d333bde7 100644
--- a/testsuite/tests/th/TH_pragma.stderr
+++ b/testsuite/tests/th/TH_pragma.stderr
@@ -14,3 +14,11 @@ TH_pragma.hs:(10,2)-(12,33): Splicing declarations
bar :: Num a => a -> a
{-# SPECIALISE INLINE [~1] bar :: Float -> Float #-}
bar x = (x * 10)
+TH_pragma.hs:(14,2)-(16,33): Splicing declarations
+ [d| baz :: Num a => a -> a
+ {-# SPECIALISE INLINE [~1] baz @Double #-}
+ baz x = x * 10 |]
+ ======>
+ baz :: Num a => a -> a
+ {-# SPECIALISE INLINE [~1] baz @Double #-}
+ baz x = (x * 10)
diff --git a/testsuite/tests/typecheck/should_compile/T10504.stderr b/testsuite/tests/typecheck/should_compile/T10504.stderr
index ed8b83514b6..8eb4f037a63 100644
--- a/testsuite/tests/typecheck/should_compile/T10504.stderr
+++ b/testsuite/tests/typecheck/should_compile/T10504.stderr
@@ -1,3 +1,5 @@
+T10504.hs:5:1: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+ Dubious SPECIALISE pragma for ‘myfun’.
+ The pragma does not specialise away any class dictionaries,
+ and neither is there any value specialisation.
-T10504.hs:5:1: warning: [GHC-35827]
- SPECIALISE pragma for non-overloaded function ‘myfun’
diff --git a/testsuite/tests/typecheck/should_compile/T2494.stderr b/testsuite/tests/typecheck/should_compile/T2494.stderr
index 931cd5874f8..06457c45301 100644
--- a/testsuite/tests/typecheck/should_compile/T2494.stderr
+++ b/testsuite/tests/typecheck/should_compile/T2494.stderr
@@ -1,4 +1,3 @@
-
T2494.hs:15:14: error: [GHC-25897]
• Couldn't match type ‘b’ with ‘a’
Expected: Maybe (m a) -> Maybe (m a)
@@ -13,11 +12,11 @@ T2494.hs:15:14: error: [GHC-25897]
In the second argument of ‘foo’, namely ‘(foo g x)’
In the expression: foo f (foo g x)
• Relevant bindings include
- f :: forall (m :: * -> *). Monad m => Maybe (m a) -> Maybe (m a)
- (bound at T2494.hs:13:11)
+ x :: Maybe a (bound at T2494.hs:14:65)
g :: forall (m :: * -> *). Monad m => Maybe (m b) -> Maybe (m b)
(bound at T2494.hs:14:11)
- x :: Maybe a (bound at T2494.hs:14:65)
+ f :: forall (m :: * -> *). Monad m => Maybe (m a) -> Maybe (m a)
+ (bound at T2494.hs:13:11)
T2494.hs:15:30: error: [GHC-25897]
• Couldn't match type ‘b’ with ‘a’
@@ -33,8 +32,9 @@ T2494.hs:15:30: error: [GHC-25897]
In the first argument of ‘foo’, namely ‘(f . g)’
In the expression: foo (f . g) x
• Relevant bindings include
- f :: forall (m :: * -> *). Monad m => Maybe (m a) -> Maybe (m a)
- (bound at T2494.hs:13:11)
+ x :: Maybe a (bound at T2494.hs:14:65)
g :: forall (m :: * -> *). Monad m => Maybe (m b) -> Maybe (m b)
(bound at T2494.hs:14:11)
- x :: Maybe a (bound at T2494.hs:14:65)
+ f :: forall (m :: * -> *). Monad m => Maybe (m a) -> Maybe (m a)
+ (bound at T2494.hs:13:11)
+
diff --git a/testsuite/tests/typecheck/should_compile/TcSpecPragmas.hs b/testsuite/tests/typecheck/should_compile/TcSpecPragmas.hs
new file mode 100644
index 00000000000..67e7e23e63c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/TcSpecPragmas.hs
@@ -0,0 +1,56 @@
+
+{-# LANGUAGE GADTs, NamedWildCards, PartialTypeSignatures #-}
+
+module SpecPragmas where
+
+import Data.Proxy
+ ( Proxy(..) )
+import Data.Type.Equality
+ ( (:~~:)(HRefl) )
+import Data.Typeable
+ ( Typeable, heqT )
+
+--------------------------------------------------------------------------------
+
+foo :: Num a => a -> a
+foo x = x + 1
+
+{-# SPECIALISE foo @Int #-}
+
+{-# SPECIALISE foo @Float :: Float -> Float #-}
+
+{-# SPECIALISE foo (3 :: Int) #-}
+{-# SPECIALISE foo @Int 4 #-}
+
+
+{-# SPECIALISE INLINE foo @Double #-}
+
+bar :: ( Num a, Integral i ) => a -> i -> a
+bar x y = x + fromIntegral y
+
+{-# SPECIALISE bar @Float :: Float -> Int -> Float #-}
+
+{-# SPECIALISE bar @Double 3 :: Integer -> Double #-}
+
+{-# SPECIALISE [1] bar @_ @Int #-}
+
+{-# SPECIALISE bar @_a @_a #-}
+
+baz :: (Real a, Integral b, Fractional c) => a -> b -> c
+baz a b = realToFrac a + fromIntegral b
+
+{-# SPECIALISE [~1] forall a. forall. baz @a @_ @a #-}
+
+--------------------------------------------------------------------------------
+
+tyEq :: ( Typeable a, Typeable b ) => Proxy a -> Proxy b -> Float
+tyEq ( _ :: Proxy a ) ( _ :: Proxy b ) =
+ case heqT @a @b of
+ Nothing -> 17.9
+ Just HRefl -> 1.1
+
+-- Check that we don't emit a "useless specialisation" warning, as the
+-- specialisation allows us to drop dead code in the body of 'tyEq'.
+{-# SPECIALISE tyEq :: Typeable c => Proxy c -> Proxy c -> Float #-}
+
+--------------------------------------------------------------------------------
diff --git a/testsuite/tests/typecheck/should_compile/TcSpecPragmas.stderr b/testsuite/tests/typecheck/should_compile/TcSpecPragmas.stderr
new file mode 100644
index 00000000000..b39e35fd274
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/TcSpecPragmas.stderr
@@ -0,0 +1,15 @@
+TcSpecPragmas.hs:37:1: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+ Dubious SPECIALISE pragma for ‘bar’.
+ The pragma does not specialise away any class dictionaries,
+ and neither is there any value specialisation.
+
+TcSpecPragmas.hs:42:1: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+ Dubious SPECIALISE pragma for ‘baz’.
+ The pragma does not specialise away any class dictionaries,
+ and neither is there any value specialisation.
+
+TcSpecPragmas.hs:54:1: warning: [GHC-66582] [-Wuseless-specialisations (in -Wdefault)]
+ Dubious SPECIALISE pragma for ‘tyEq’.
+ The pragma does not specialise away any class dictionaries,
+ and neither is there any value specialisation.
+
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 2958e845fb9..1b68ab6de76 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -738,6 +738,7 @@ test('T19042', normal, compile, [''])
test('ExplicitSpecificityA1', normal, compile, [''])
test('ExplicitSpecificityA2', normal, compile, [''])
test('ExplicitSpecificity4', normal, compile, [''])
+test('TcSpecPragmas', normal, compile, [''])
test('T17775-viewpats-a', normal, compile, [''])
test('T17775-viewpats-b', normal, compile_fail, [''])
test('T17775-viewpats-c', normal, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_compile/tc186.hs b/testsuite/tests/typecheck/should_compile/tc186.hs
index a99b956098f..b1db254080e 100644
--- a/testsuite/tests/typecheck/should_compile/tc186.hs
+++ b/testsuite/tests/typecheck/should_compile/tc186.hs
@@ -2,7 +2,7 @@
-- Killed 6.2.2
-- The trouble was that 1 was instantiated to a type (t::?)
-- and the constraint (Foo (t::? -> s::*)) didn't match Foo (a::* -> b::*).
--- Solution is to zap the expected type in TcEpxr.tc_expr(HsOverLit).
+-- Solution is to zap the expected type in TcExpr.tc_expr(HsOverLit).
module ShouldCompile where
diff --git a/testsuite/tests/typecheck/should_compile/tc212.hs b/testsuite/tests/typecheck/should_compile/tc212.hs
index ad408fbdaf4..1903fd3961c 100644
--- a/testsuite/tests/typecheck/should_compile/tc212.hs
+++ b/testsuite/tests/typecheck/should_compile/tc212.hs
@@ -4,5 +4,6 @@
module ShouldCompile where
-- A specialise pragma with no type signature
+-- fac :: Num a => a -> a
fac n = fac (n + 1)
{-# SPECIALISE fac :: Int -> Int #-}
diff --git a/testsuite/tests/typecheck/should_fail/SpecPragmasFail.hs b/testsuite/tests/typecheck/should_fail/SpecPragmasFail.hs
new file mode 100644
index 00000000000..f403876a0df
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/SpecPragmasFail.hs
@@ -0,0 +1,14 @@
+
+module SpecPragmasFail where
+
+foo :: Num a => a -> a
+foo x = x + 1
+
+{-# SPECIALISE foo @Integer :: Int -> Int #-}
+
+{-# SPECIALISE foo @Bool #-}
+
+bar :: a ~ Int => a
+bar = 3
+
+{-# SPECIALISE bar @Char #-}
diff --git a/testsuite/tests/typecheck/should_fail/SpecPragmasFail.stderr b/testsuite/tests/typecheck/should_fail/SpecPragmasFail.stderr
new file mode 100644
index 00000000000..ef4c4d22c0b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/SpecPragmasFail.stderr
@@ -0,0 +1,6 @@
+SpecPragmasFail.hs:7:16: error: [GHC-83865]
+ • Couldn't match type ‘Integer’ with ‘Int’
+ Expected: Int -> Int
+ Actual: Integer -> Integer
+ • In the expression: foo @Integer :: Int -> Int
+
diff --git a/testsuite/tests/typecheck/should_fail/T5853.stderr b/testsuite/tests/typecheck/should_fail/T5853.stderr
index 1e71808b4ec..857147a7de7 100644
--- a/testsuite/tests/typecheck/should_fail/T5853.stderr
+++ b/testsuite/tests/typecheck/should_fail/T5853.stderr
@@ -1,4 +1,3 @@
-
T5853.hs:15:52: error: [GHC-25897]
• Could not deduce ‘Subst fa2 (Elem fb) ~ fb’
arising from a use of ‘<$>’
@@ -13,6 +12,7 @@ T5853.hs:15:52: error: [GHC-25897]
• In the expression: (f . g) <$> xs
When checking the rewrite rule "map/map"
• Relevant bindings include
- f :: Elem fa1 -> Elem fb (bound at T5853.hs:15:19)
- g :: Elem fa2 -> Elem fa1 (bound at T5853.hs:15:21)
xs :: fa2 (bound at T5853.hs:15:23)
+ g :: Elem fa2 -> Elem fa1 (bound at T5853.hs:15:21)
+ f :: Elem fa1 -> Elem fb (bound at T5853.hs:15:19)
+
diff --git a/testsuite/tests/warnings/should_compile/SpecMultipleTys.hs b/testsuite/tests/warnings/should_compile/SpecMultipleTys.hs
new file mode 100644
index 00000000000..233949bcf2c
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/SpecMultipleTys.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+
+module SpecMultipleTys where
+
+-- NB: this program should be rejected starting from GHC 9.18.
+-- See GHC ticket #25540.
+
+foo :: Num a => a -> a
+foo x = 2 * ( x + 1 )
+
+{-# SPECIALISE foo :: Float -> Float, Double -> Double #-}
diff --git a/testsuite/tests/warnings/should_compile/SpecMultipleTys.stderr b/testsuite/tests/warnings/should_compile/SpecMultipleTys.stderr
new file mode 100644
index 00000000000..848a98c9a3f
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/SpecMultipleTys.stderr
@@ -0,0 +1,5 @@
+SpecMultipleTys.hs:12:20: warning: [GHC-73026] [-Wdeprecated-pragmas (in -Wdefault)]
+ SPECIALISE pragmas with multiple type ascriptions are deprecated, and will be removed in GHC 9.18
+ Suggested fix:
+ Split the SPECIALISE pragma into multiple pragmas, one for each type signature
+
diff --git a/testsuite/tests/warnings/should_compile/T19296.stderr b/testsuite/tests/warnings/should_compile/T19296.stderr
index cfa7cb31324..e8eaa754d77 100644
--- a/testsuite/tests/warnings/should_compile/T19296.stderr
+++ b/testsuite/tests/warnings/should_compile/T19296.stderr
@@ -24,24 +24,11 @@ T19296.hs:13:6: warning: [GHC-30606] [-Wredundant-constraints]
13 | h :: (Eq a, Ord b) => a -> b -> b
| ^^^^^^^^^^^^^
-T19296.hs:21:1: warning: [GHC-40548]
- Forall'd constraint ‘Eq a’ is not bound in RULE lhs
- Orig bndrs: [a, $dEq]
- Orig lhs: let {
- $dOrd :: Ord Int
- [LclId]
- $dOrd = GHC.Internal.Classes.$fOrdInt } in
- spec @Int @a $dOrd
- optimised lhs: spec @Int @a $dOrd
- |
-21 | {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
- | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
T19296.hs:21:24: warning: [GHC-30606] [-Wredundant-constraints]
• Redundant constraint: Eq a
- In the type signature for:
- spec :: forall a. Eq a => a -> Int -> Int
- • In the pragma: {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
+ In an expression type signature:
+ forall a. Eq a => a -> Int -> Int
+ • In the expression: spec :: Eq a => a -> Int -> Int
|
21 | {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
| ^^^^
diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T
index daed779ae82..9d321516f36 100644
--- a/testsuite/tests/warnings/should_compile/all.T
+++ b/testsuite/tests/warnings/should_compile/all.T
@@ -71,3 +71,4 @@ test('T23573', [extra_files(["T23573.hs", "T23573A.hs", "T23573B.hs"])], multimo
test('T23465', normal, compile, ['-ddump-parsed'])
test('WarnNoncanonical', normal, compile, [''])
test('T24396', [extra_files(["T24396a.hs", "T24396b.hs"])], multimod_compile, ['T24396b', ''])
+test('SpecMultipleTys', normal, compile, ['']) # compile_fail from GHC 9.18
diff --git a/testsuite/tests/warnings/should_fail/SpecEMultipleTys.hs b/testsuite/tests/warnings/should_fail/SpecEMultipleTys.hs
new file mode 100644
index 00000000000..66312775ac8
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/SpecEMultipleTys.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+
+module SpecEMultipleTys where
+
+bar :: Num a => a -> a -> a
+bar x y = 2 * ( x + y )
+
+-- The "specialise expression" syntax doesn't support multiple type ascriptions.
+{-# SPECIALISE bar 3 :: Float -> Float, Double -> Double #-}
diff --git a/testsuite/tests/warnings/should_fail/SpecEMultipleTys.stderr b/testsuite/tests/warnings/should_fail/SpecEMultipleTys.stderr
new file mode 100644
index 00000000000..95faf254dc1
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/SpecEMultipleTys.stderr
@@ -0,0 +1,5 @@
+SpecEMultipleTys.hs:10:22: error: [GHC-62037]
+ SPECIALISE expression doesn't support multiple type ascriptions
+ Suggested fix:
+ Split the SPECIALISE pragma into multiple pragmas, one for each type signature
+
diff --git a/testsuite/tests/warnings/should_fail/all.T b/testsuite/tests/warnings/should_fail/all.T
index aafc92e6dca..4f08dffd1f8 100644
--- a/testsuite/tests/warnings/should_fail/all.T
+++ b/testsuite/tests/warnings/should_fail/all.T
@@ -27,3 +27,4 @@ test('WarningCategory6', [extra_files(['WarningCategory1.hs', 'WarningCategory1_
test('WarningCategory7', [extra_files(['WarningCategory1.hs', 'WarningCategory1_B.hs', 'WarningCategoryModule.hs'])], multimod_compile_fail, ['WarningCategory1', '-v0 -Werror -w -Wall'])
test('WarningCategoryInvalid', normal, compile_fail, [''])
test('T24396c', normal, compile_fail, [''])
+test('SpecEMultipleTys', normal, compile_fail, [''])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 74979771158..451cb7cde84 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -330,7 +330,7 @@ instance HasTrailing AnnSig where
trailing _ = []
setTrailing a _ = a
-instance HasTrailing HsRuleAnn where
+instance HasTrailing HsRuleBndrsAnn where
trailing _ = []
setTrailing a _ = a
@@ -1140,17 +1140,15 @@ lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new })
-- ---------------------------------------------------------------------
--- data HsRuleAnn
--- = HsRuleAnn
--- { ra_tyanns :: Maybe (TokForall, EpToken ".")
--- , ra_tmanns :: Maybe (TokForall, EpToken ".")
--- , ra_equal :: EpToken "="
--- , ra_rest :: ActivationAnn
--- } deriving (Data, Eq)
+-- data HsRuleBndrsAnn
+-- = HsRuleBndrsAnn
+-- { rb_tyanns :: Maybe (TokForall, EpToken ".")
+-- , rb_tmanns :: Maybe (TokForall, EpToken ".")
+-- }
-lra_tyanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken "."))
-lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new })
- (k (ra_tyanns parent))
+lrb_tyanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))
+lrb_tyanns k parent = fmap (\new -> parent { rb_tyanns = new })
+ (k (rb_tyanns parent))
ff :: Maybe (a,b) -> (Maybe a,Maybe b)
ff Nothing = (Nothing, Nothing)
@@ -1167,30 +1165,21 @@ lff k parent = fmap (\new -> gg new)
(k (ff parent))
-- (.) :: Lens' a b -> Lens' b c -> Lens' a c
-lra_tyanns_fst :: Lens HsRuleAnn (Maybe TokForall)
-lra_tyanns_fst = lra_tyanns . lff . lfst
+lrb_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)
+lrb_tyanns_fst = lrb_tyanns . lff . lfst
-lra_tyanns_snd :: Lens HsRuleAnn (Maybe (EpToken "."))
-lra_tyanns_snd = lra_tyanns . lff . lsnd
+lrb_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))
+lrb_tyanns_snd = lrb_tyanns . lff . lsnd
-lra_tmanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken "."))
-lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new })
- (k (ra_tmanns parent))
+lrb_tmanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))
+lrb_tmanns k parent = fmap (\new -> parent { rb_tmanns = new })
+ (k (rb_tmanns parent))
-lra_tmanns_fst :: Lens HsRuleAnn (Maybe TokForall)
-lra_tmanns_fst = lra_tmanns . lff . lfst
-
-lra_tmanns_snd :: Lens HsRuleAnn (Maybe (EpToken "."))
-lra_tmanns_snd = lra_tmanns . lff . lsnd
-
-lra_equal :: Lens HsRuleAnn (EpToken "=")
-lra_equal k parent = fmap (\new -> parent { ra_equal = new })
- (k (ra_equal parent))
-
-lra_rest :: Lens HsRuleAnn ActivationAnn
-lra_rest k parent = fmap (\new -> parent { ra_rest = new })
- (k (ra_rest parent))
+lrb_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)
+lrb_tmanns_fst = lrb_tmanns . lff . lfst
+lrb_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))
+lrb_tmanns_snd = lrb_tmanns . lff . lsnd
-- ---------------------------------------------------------------------
-- data GrhsAnn
@@ -2016,33 +2005,14 @@ instance ExactPrint (RuleDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do
+ exact (HsRule ((ann_act, ann_eq),nsrc) (L ln n) act bndrs lhs rhs) = do
(L ln' _) <- markAnnotated (L ln (nsrc, n))
- an0 <- markActivationL an lra_rest act
- (an1, mtybndrs') <-
- case mtybndrs of
- Nothing -> return (an0, Nothing)
- Just bndrs -> do
- an1 <- markLensFun an0 lra_tyanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall
- bndrs' <- mapM markAnnotated bndrs
- an2 <- markLensFun an1 lra_tyanns_snd (\mt -> mapM markEpToken mt) -- AnnDot
- return (an2, Just bndrs')
-
- an2 <- markLensFun an1 lra_tmanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall
- termbndrs' <- mapM markAnnotated termbndrs
- an3 <- markLensFun an2 lra_tmanns_snd (\mt -> mapM markEpToken mt) -- AnnDot
-
+ ann_act' <- markActivation ann_act act
+ bndrs' <- markAnnotated bndrs
lhs' <- markAnnotated lhs
- an4 <- markLensFun an3 lra_equal markEpToken
+ ann_eq' <- markEpToken ann_eq
rhs' <- markAnnotated rhs
- return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs')
-
-
-markActivationL :: (Monad m, Monoid w)
- => a -> Lens a ActivationAnn -> Activation -> EP w m a
-markActivationL a l act = do
- new <- markActivation (view l a) act
- return (set l new a)
+ return (HsRule ((ann_act', ann_eq'),nsrc) (L ln' n) act bndrs' lhs' rhs')
markActivation :: (Monad m, Monoid w)
=> ActivationAnn -> Activation -> EP w m ActivationAnn
@@ -2113,6 +2083,26 @@ instance ExactPrint Role where
-- ---------------------------------------------------------------------
+instance ExactPrint (RuleBndrs GhcPs) where
+ getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
+ exact (RuleBndrs an0 mtybndrs termbndrs) = do
+ (an2, mtybndrs') <-
+ case mtybndrs of
+ Nothing -> return (an0, Nothing)
+ Just bndrs -> do
+ an1 <- markLensFun an0 lrb_tyanns_fst (traverse markEpUniToken) -- AnnForall
+ bndrs' <- mapM markAnnotated bndrs
+ an2 <- markLensFun an1 lrb_tyanns_snd (traverse markEpToken) -- AnnDot
+ return (an2, Just bndrs')
+
+ an3 <- markLensFun an2 lrb_tmanns_fst (traverse markEpUniToken) -- AnnForall
+ termbndrs' <- mapM markAnnotated termbndrs
+ an4 <- markLensFun an3 lrb_tmanns_snd (traverse markEpToken) -- AnnDot
+ return (RuleBndrs an4 mtybndrs' termbndrs')
+
+-- ---------------------------------------------------------------------
+
instance ExactPrint (RuleBndr GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
@@ -2676,11 +2666,20 @@ instance ExactPrint (Sig GhcPs) where
o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
act' <- markActivation act (inl_act inl)
ln' <- markAnnotated ln
- dc' <- markEpUniToken dc
+ dc' <- traverse markEpUniToken dc
typs' <- markAnnotated typs
c' <- markEpToken c
return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl)
+ exact (SpecSigE (AnnSpecSig o c dc act) bndrs expr inl) = do
+ o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+ act' <- markActivation act (inl_act inl)
+ bndrs' <- markAnnotated bndrs
+ dc' <- traverse markEpUniToken dc
+ expr' <- markAnnotated expr
+ c' <- markEpToken c
+ return (SpecSigE (AnnSpecSig o' c' dc' act') bndrs' expr' inl)
+
exact (SpecInstSig ((o,i,c),src) typ) = do
o' <- markAnnOpen'' o src "{-# SPECIALISE"
i' <- markEpToken i
--
GitLab