[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Show an error when we cannot default a concrete tyvar
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Apr 16 17:41:48 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00
Show an error when we cannot default a concrete tyvar
Fixes #23153
- - - - -
bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00
Handle ConcreteTvs in inferResultToType
inferResultToType was discarding the ir_frr information, which meant
some metavariables ended up being MetaTvs instead of ConcreteTvs.
This function now creates new ConcreteTvs as necessary, instead of
always creating MetaTvs.
Fixes #23154
- - - - -
55b1afd4 by Simon Peyton Jones at 2023-04-16T13:41:31-04:00
Transfer DFunId_ness onto specialised bindings
Whether a binding is a DFunId or not has consequences for the `-fdicts-strict`
flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does
not apply because the constraint solver can create recursive groups of dictionaries.
In #22549 this was fixed for the "normal" case, see
Note [Do not strictify the argument dictionaries of a dfun].
However the loop still existed if the DFunId was being specialised.
The problem was that the specialiser would specialise a DFunId and
turn it into a VanillaId and so the demand analyser didn't know to
apply special treatment to the binding anymore and the whole recursive
group was optimised to bottom.
The solution is to transfer over the DFunId-ness of the binding in the specialiser so
that the demand analyser knows not to apply the `-fstrict-dicts`.
Fixes #22549
- - - - -
2c2f984f by Oleg Grenrus at 2023-04-16T13:41:37-04:00
Add import lists to few GHC.Driver.Session imports
Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261.
There are a lot of GHC.Driver.Session which only use DynFlags,
but not the parsing code.
- - - - -
22 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/Types/Error/Codes.hs
- testsuite/tests/rep-poly/RepPolyInferPatBind.stderr
- testsuite/tests/rep-poly/RepPolyInferPatSyn.stderr
- testsuite/tests/rep-poly/RepPolyPatBind.stderr
- + testsuite/tests/rep-poly/T23153.hs
- + testsuite/tests/rep-poly/T23153.stderr
- + testsuite/tests/rep-poly/T23154.hs
- + testsuite/tests/rep-poly/T23154.stderr
- testsuite/tests/rep-poly/all.T
- testsuite/tests/typecheck/should_fail/VtaFail.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -48,10 +48,11 @@ import GHC.Types.Unique.DFM
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
-import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg )
+import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
+import GHC.Types.Id.Info
import GHC.Types.Error
import GHC.Utils.Error ( mkMCDiagnostic )
@@ -59,6 +60,7 @@ import GHC.Utils.Monad ( foldlM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain( assert )
import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
@@ -1748,12 +1750,44 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
| otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
join_arity_decr = length rule_lhs_args - length spec_bndrs
- spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
- = Just (orig_join_arity - join_arity_decr)
- | otherwise
- = Nothing
- ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity
+ --------------------------------------
+ -- Add a suitable unfolding; see Note [Inline specialisations]
+ -- The wrap_unf_body applies the original unfolding to the specialised
+ -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
+ simpl_opts = initSimpleOpts dflags
+ wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
+ spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
+ rule_lhs_args fn_unf
+
+ --------------------------------------
+ -- Adding arity information just propagates it a bit faster
+ -- See Note [Arity decrease] in GHC.Core.Opt.Simplify
+ -- Copy InlinePragma information from the parent Id.
+ -- So if f has INLINE[1] so does spec_fn
+ arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
+
+ spec_inl_prag
+ | not is_local -- See Note [Specialising imported functions]
+ , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
+ = neverInlinePragma
+ | otherwise
+ = inl_prag
+
+ spec_fn_info
+ = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr)
+ `setInlinePragInfo` spec_inl_prag
+ `setUnfoldingInfo` spec_unf
+
+ -- Compute the IdDetails of the specialise Id
+ -- See Note [Transfer IdDetails during specialisation]
+ spec_fn_details
+ = case idDetails fn of
+ JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing
+ DFunId is_nt -> DFunId is_nt
+ _ -> VanillaId
+
+ ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info
; let
-- The rule to put in the function's specialisation is:
-- forall x @b d1' d2'.
@@ -1768,33 +1802,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
herald fn rule_bndrs rule_lhs_args
(mkVarApps (Var spec_fn) spec_bndrs)
- simpl_opts = initSimpleOpts dflags
-
- --------------------------------------
- -- Add a suitable unfolding; see Note [Inline specialisations]
- -- The wrap_unf_body applies the original unfolding to the specialised
- -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
- wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
- spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
- rule_lhs_args fn_unf
-
- spec_inl_prag
- | not is_local -- See Note [Specialising imported functions]
- , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
- = neverInlinePragma
- | otherwise
- = inl_prag
-
- --------------------------------------
- -- Adding arity information just propagates it a bit faster
- -- See Note [Arity decrease] in GHC.Core.Opt.Simplify
- -- Copy InlinePragma information from the parent Id.
- -- So if f has INLINE[1] so does spec_fn
- arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
- spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)
- `setInlinePragma` spec_inl_prag
- `setIdUnfolding` spec_unf
- `asJoinId_maybe` spec_join_arity
+ spec_f_w_arity = spec_fn
_rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type
, ppr spec_fn <+> dcolon <+> ppr spec_fn_ty
@@ -1824,7 +1832,7 @@ specLookupRule env fn args phase rules
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-DFuns have a special sort of unfolding (DFunUnfolding), and these are
+DFuns have a special sort of unfolding (DFunUnfolding), and it is
hard to specialise a DFunUnfolding to give another DFunUnfolding
unless the DFun is fully applied (#18120). So, in the case of DFunIds
we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,
@@ -1833,6 +1841,36 @@ so that we'll generate a rule that completely saturates the DFun.
There is an ASSERT that checks this, in the DFunUnfolding case of
GHC.Core.Unfold.Make.specUnfolding.
+Note [Transfer IdDetails during specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When specialising a function, `newSpecIdSM` comes up with a fresh Id the
+specialised RHS will be bound to. It is critical that we get the `IdDetails` of
+the specialised Id correct:
+
+* JoinId: We want the specialised Id to be a join point, too. But
+ we have to carefully adjust the arity
+
+* DFunId: It is crucial that we also make the new Id a DFunId.
+ - First, because it obviously /is/ a DFun, having a DFunUnfolding and
+ all that; see Note [Specialising DFuns]
+
+ - Second, DFuns get very delicate special treatment in the demand analyser;
+ see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't
+ also a DFunId, this special treatment doesn't happen, so the demand
+ analyser makes a too-strict DFun, and we get an infinite loop. See Note
+ [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.
+ #22549 describes the loop, and (lower down) a case where a /specialised/
+ DFun caused a loop.
+
+* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come
+ up when specialising imports. We must keep them as VanillaIds because WW
+ will detect them as WorkerLikeIds again. That is, unless specialisation
+ allows unboxing of all previous CBV args, in which case sticking to
+ VanillaIds was the only correct choice to begin with.
+
+* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:
+ Never specialised.
+
Note [Specialisation Must Preserve Sharing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a function:
@@ -3439,15 +3477,14 @@ newDictBndr env@(SE { se_subst = subst }) b
env' = env { se_subst = subst `Core.extendSubstInScope` b' }
; pure (env', b') }
-newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
+newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id
-- Give the new Id a similar occurrence name to the old one
-newSpecIdSM old_id new_ty join_arity_maybe
+newSpecIdSM old_name new_ty details info
= do { uniq <- getUniqueM
- ; let name = idName old_id
- new_occ = mkSpecOcc (nameOccName name)
- new_id = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name)
- `asJoinId_maybe` join_arity_maybe
- ; return new_id }
+ ; let new_occ = mkSpecOcc (nameOccName old_name)
+ new_name = mkInternalName uniq new_occ (getSrcSpan old_name)
+ ; return (assert (not (isCoVarType new_ty)) $
+ mkLocalVar details new_name ManyTy new_ty info) }
{-
Old (but interesting) stuff about unboxed bindings
=====================================
compiler/GHC/Driver/Errors/Types.hs
=====================================
@@ -25,7 +25,8 @@ import GHC.Prelude
import Data.Bifunctor
import Data.Typeable
-import GHC.Driver.Session
+import GHC.Driver.Session (DynFlags, PackageArg, gopt)
+import GHC.Driver.Flags (GeneralFlag (Opt_BuildingCabalPackage))
import GHC.Types.Error
import GHC.Unit.Module
import GHC.Unit.State
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -82,7 +82,7 @@ import GHC.Types.SrcLoc
import GHC.Data.Bag -- collect ev vars from pats
import GHC.Data.Maybe
import GHC.Types.Name (Name, dataName)
-import GHC.Driver.Session
+import GHC.Driver.Session (DynFlags, xopt)
import qualified GHC.LanguageExtensions as LangExt
import Data.Data
=====================================
compiler/GHC/HsToCore/Errors/Types.hs
=====================================
@@ -9,7 +9,8 @@ import GHC.Prelude
import GHC.Core (CoreRule, CoreExpr, RuleName)
import GHC.Core.DataCon
import GHC.Core.Type
-import GHC.Driver.Session
+import GHC.Driver.Session (DynFlags, xopt)
+import GHC.Driver.Flags (WarningFlag)
import GHC.Hs
import GHC.HsToCore.Pmc.Solver.Types
import GHC.Types.Basic (Activation)
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1728,6 +1728,11 @@ instance Diagnostic TcRnMessage where
in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc)
<+> text "from external module"
+ TcRnCannotDefaultConcrete frr
+ -> mkSimpleDecorated $
+ ppr (frr_context frr) $$
+ text "cannot be assigned a fixed runtime representation," <+>
+ text "not even by defaulting."
diagnosticReason = \case
TcRnUnknownMessage m
@@ -2300,6 +2305,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnTypeSynonymCycle{}
-> ErrorWithoutFlag
+ TcRnCannotDefaultConcrete{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2899,6 +2906,8 @@ instance Diagnostic TcRnMessage where
-> [suggestExtension LangExt.DataKinds]
TcRnTypeSynonymCycle{}
-> noHints
+ TcRnCannotDefaultConcrete{}
+ -> [SuggestAddTypeSignatures UnnamedBinding]
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3473,6 +3473,15 @@ data TcRnMessage where
-> ![LIdP GhcRn] -- ^ The LHS args
-> !PatSynInvalidRhsReason -- ^ The number of equation arguments
-> TcRnMessage
+ {-| TcRnCannotDefaultConcrete is an error occurring when a concrete
+ type variable cannot be defaulted.
+
+ Test cases:
+ T23153
+ -}
+ TcRnCannotDefaultConcrete
+ :: !FixedRuntimeRepOrigin
+ -> TcRnMessage
{-| TcRnMultiAssocTyFamDefaults is an error indicating that multiple default
declarations were specified for an associated type family.
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -883,7 +883,7 @@ tcExprWithSig expr hs_ty
loc = getLocA (dropWildCards hs_ty)
ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty)
-tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
= setSrcSpan loc $ -- Sets the location for the implication constraint
do { let poly_ty = idType poly_id
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -2119,14 +2119,17 @@ checkTouchableTyVarEq ev lhs_tv rhs
; if not (cterHasNoProblem reason) -- Failed to promote free vars
then failCheckWith reason
else
- do { let tv_info | isConcreteInfo lhs_tv_info = lhs_tv_info
- | otherwise = TauTv
- -- Make a concrete tyvar if lhs_tv is concrete
- -- e.g. alpha[2,conc] ~ Maybe (F beta[4])
- -- We want to flatten to
- -- alpha[2,conc] ~ Maybe gamma[2,conc]
- -- gamma[2,conc] ~ F beta[4]
- ; new_tv_ty <- TcM.newMetaTyVarTyWithInfo lhs_tv_lvl tv_info fam_app_kind
+ do { new_tv_ty <-
+ case lhs_tv_info of
+ ConcreteTv conc_info ->
+ -- Make a concrete tyvar if lhs_tv is concrete
+ -- e.g. alpha[2,conc] ~ Maybe (F beta[4])
+ -- We want to flatten to
+ -- alpha[2,conc] ~ Maybe gamma[2,conc]
+ -- gamma[2,conc] ~ F beta[4]
+ TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind
+ _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind
+
; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty
; hole <- TcM.newCoercionHole pty
; let new_ev = CtWanted { ctev_pred = pty
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -117,7 +117,7 @@ import GHC.Core
import GHC.Core.TyCo.Ppr
import GHC.Utils.FV
import GHC.Types.Var.Set
-import GHC.Driver.Session
+import GHC.Driver.Session (DynFlags(reductionDepth))
import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Types.Unique.Set
=====================================
compiler/GHC/Tc/Utils/Concrete.hs
=====================================
@@ -8,9 +8,6 @@ module GHC.Tc.Utils.Concrete
( -- * Ensuring that a type has a fixed runtime representation
hasFixedRuntimeRep
, hasFixedRuntimeRep_syntactic
-
- -- * Making a type concrete
- , makeTypeConcrete
)
where
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -24,7 +25,7 @@ module GHC.Tc.Utils.TcMType (
newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,
newOpenBoxedTypeKind,
newMetaKindVar, newMetaKindVars,
- newMetaTyVarTyAtLevel, newMetaTyVarTyWithInfo,
+ newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel,
newAnonMetaTyVar, newConcreteTyVar,
cloneMetaTyVar, cloneMetaTyVarWithInfo,
newCycleBreakerTyVar,
@@ -482,7 +483,16 @@ newInferExpType :: TcM ExpType
newInferExpType = new_inferExpType Nothing
newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR
-newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig)
+newInferExpTypeFRR frr_orig
+ = do { th_stage <- getStage
+ ; if
+ -- See [Wrinkle: Typed Template Haskell]
+ -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
+ | Brack _ (TcPending {}) <- th_stage
+ -> new_inferExpType Nothing
+
+ | otherwise
+ -> new_inferExpType (Just frr_orig) }
new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType
new_inferExpType mb_frr_orig
@@ -538,20 +548,28 @@ expTypeToType (Infer inf_res) = inferResultToType inf_res
inferResultToType :: InferResult -> TcM Type
inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
- , ir_ref = ref })
+ , ir_ref = ref
+ , ir_frr = mb_frr })
= do { mb_inferred_ty <- readTcRef ref
; tau <- case mb_inferred_ty of
Just ty -> do { ensureMonoType ty
-- See Note [inferResultToType]
; return ty }
- Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
- ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
- -- See Note [TcLevel of ExpType]
+ Nothing -> do { tau <- new_meta
; writeMutVar ref (Just tau)
; return tau }
; traceTc "Forcing ExpType to be monomorphic:"
(ppr u <+> text ":=" <+> ppr tau)
; return tau }
+ where
+ -- See Note [TcLevel of ExpType]
+ new_meta = case mb_frr of
+ Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
+ ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) }
+ Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy
+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
+ ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
+ ; return tau }
{- Note [inferResultToType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -874,6 +892,13 @@ newTauTvDetailsAtLevel tclvl
, mtv_ref = ref
, mtv_tclvl = tclvl }) }
+newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails
+newConcreteTvDetailsAtLevel conc_orig tclvl
+ = do { ref <- newMutVar Flexi
+ ; return (MetaTv { mtv_info = ConcreteTv conc_orig
+ , mtv_ref = ref
+ , mtv_tclvl = tclvl }) }
+
cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
cloneMetaTyVar tv
= assert (isTcTyVar tv) $
@@ -931,7 +956,7 @@ isUnfilledMetaTyVar tv
--------------------
-- Works with both type and kind variables
-writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
+writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM ()
-- Write into a currently-empty MetaTyVar
writeMetaTyVar tyvar ty
@@ -949,7 +974,7 @@ writeMetaTyVar tyvar ty
= massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)
--------------------
-writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
+writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
-- Here the tyvar is for error checking only;
-- the ref cell must be for the same tyvar
writeMetaTyVarRef tyvar ref ty
@@ -1114,13 +1139,10 @@ newMetaTyVarTyAtLevel tc_lvl kind
; name <- newMetaTyVarName (fsLit "p")
; return (mkTyVarTy (mkTcTyVar name kind details)) }
-newMetaTyVarTyWithInfo :: TcLevel -> MetaInfo -> TcKind -> TcM TcType
-newMetaTyVarTyWithInfo tc_lvl info kind
- = do { ref <- newMutVar Flexi
- ; let details = MetaTv { mtv_info = info
- , mtv_ref = ref
- , mtv_tclvl = tc_lvl }
- ; name <- newMetaTyVarName (fsLit "p")
+newConcreteTyVarTyAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType
+newConcreteTyVarTyAtLevel conc_orig tc_lvl kind
+ = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl
+ ; name <- newMetaTyVarName (fsLit "c")
; return (mkTyVarTy (mkTcTyVar name kind details)) }
{- *********************************************************************
@@ -2258,7 +2280,7 @@ a \/\a in the final result but all the occurrences of a will be zonked to ()
* *
********************************************************************* -}
-promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool
+promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool
-- When we float a constraint out of an implication we must restore
-- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType
-- Return True <=> we did some promotion
@@ -2276,7 +2298,7 @@ promoteMetaTyVarTo tclvl tv
= return False
-- Returns whether or not *any* tyvar is defaulted
-promoteTyVarSet :: TcTyVarSet -> TcM Bool
+promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool
promoteTyVarSet tvs
= do { tclvl <- getTcLevel
; bools <- mapM (promoteMetaTyVarTo tclvl) $
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -56,6 +56,7 @@ import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
import GHC.Tc.Types.Evidence
+import GHC.Tc.Errors.Types
import GHC.Core.TyCo.Ppr ( pprTyVar )
import GHC.Core.TyCon
@@ -1737,7 +1738,7 @@ change. But in some cases it makes a HUGE difference: see test
T9198 and #19668. So yes, it seems worth it.
-}
-zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type
+zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type
zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
, ze_tv_env = tv_env
, ze_meta_tv_env = mtv_env_ref }) tv
@@ -1810,6 +1811,9 @@ commitFlexi flexi tv zonked_kind
| isMultiplicityTy zonked_kind
-> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)
; return manyDataConTy }
+ | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
+ -> do { addErr $ TcRnCannotDefaultConcrete origin
+ ; return (anyTypeOfKind zonked_kind) }
| otherwise
-> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
; return (anyTypeOfKind zonked_kind) }
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -480,8 +480,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006
GhcDiagnosticCode "TcRnHsigFixityMismatch" = 93007
- GhcDiagnosticCode "HsigShapeSortMismatch" = 93008
- GhcDiagnosticCode "HsigShapeNotUnifiable" = 93009
GhcDiagnosticCode "TcRnHsigNoIface" = 93010
GhcDiagnosticCode "TcRnHsigMissingModuleExport" = 93011
GhcDiagnosticCode "TcRnBadGenericMethod" = 59794
@@ -551,8 +549,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnPatSynEscapedCoercion" = 88986
GhcDiagnosticCode "TcRnPatSynExistentialInResult" = 33973
GhcDiagnosticCode "TcRnPatSynArityMismatch" = 18365
- GhcDiagnosticCode "PatSynNotInvertible" = 69317
- GhcDiagnosticCode "PatSynUnboundVar" = 28572
+ GhcDiagnosticCode "TcRnCannotDefaultConcrete" = 52083
GhcDiagnosticCode "TcRnMultiAssocTyFamDefaults" = 59128
GhcDiagnosticCode "TcRnTyFamDepsDisabled" = 43991
GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl" = 60012
@@ -580,6 +577,10 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnTyFamNameMismatch" = 88221
GhcDiagnosticCode "TcRnTypeSynonymCycle" = 97522
+ -- PatSynInvalidRhsReason
+ GhcDiagnosticCode "PatSynNotInvertible" = 69317
+ GhcDiagnosticCode "PatSynUnboundVar" = 28572
+
-- TcRnBadFieldAnnotation/BadFieldAnnotationReason
GhcDiagnosticCode "LazyFieldsDisabled" = 81601
GhcDiagnosticCode "UnpackWithoutStrictness" = 10107
@@ -601,6 +602,10 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnPrecedenceParsingError" = 88747
GhcDiagnosticCode "TcRnSectionPrecedenceError" = 46878
+ -- HsigShapeMismatchReason
+ GhcDiagnosticCode "HsigShapeSortMismatch" = 93008
+ GhcDiagnosticCode "HsigShapeNotUnifiable" = 93009
+
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
GhcDiagnosticCode "IsNonLinear" = 38291
=====================================
testsuite/tests/rep-poly/RepPolyInferPatBind.stderr
=====================================
@@ -8,7 +8,7 @@ RepPolyInferPatBind.hs:21:2: error: [GHC-55287]
• The pattern binding does not have a fixed runtime representation.
Its type is:
T :: TYPE R
- Cannot unify ‘R’ with the type variable ‘p0’
+ Cannot unify ‘R’ with the type variable ‘c0’
because it is not a concrete ‘RuntimeRep’.
• When checking that the pattern signature: T
fits the type of its context: T
=====================================
testsuite/tests/rep-poly/RepPolyInferPatSyn.stderr
=====================================
@@ -4,7 +4,7 @@ RepPolyInferPatSyn.hs:22:16: error: [GHC-55287]
does not have a fixed runtime representation.
Its type is:
T :: TYPE R
- Cannot unify ‘R’ with the type variable ‘p0’
+ Cannot unify ‘R’ with the type variable ‘c0’
because it is not a concrete ‘RuntimeRep’.
• When checking that the pattern signature: T
fits the type of its context: T
=====================================
testsuite/tests/rep-poly/RepPolyPatBind.stderr
=====================================
@@ -1,4 +1,20 @@
+RepPolyPatBind.hs:18:5: error: [GHC-55287]
+ • The pattern binding does not have a fixed runtime representation.
+ Its type is:
+ p0 :: TYPE c0
+ Cannot unify ‘TupleRep [rep, rep]’ with the type variable ‘c0’
+ because it is not a concrete ‘RuntimeRep’.
+ • In the pattern: (# x, y #)
+ In a pattern binding: (# x, y #) = undefined
+ In the expression:
+ let
+ x, y :: a
+ (# x, y #) = undefined
+ in x
+ • Relevant bindings include
+ foo :: () -> a (bound at RepPolyPatBind.hs:15:1)
+
RepPolyPatBind.hs:18:5: error: [GHC-55287]
• • The binder ‘y’ does not have a fixed runtime representation.
Its type is:
=====================================
testsuite/tests/rep-poly/T23153.hs
=====================================
@@ -0,0 +1,8 @@
+module T23153 where
+
+import GHC.Exts
+
+f :: forall r s (a :: TYPE (r s)). a -> ()
+f = f
+
+g h = f (h ())
=====================================
testsuite/tests/rep-poly/T23153.stderr
=====================================
@@ -0,0 +1,15 @@
+
+T23153.hs:8:1: error: [GHC-52083]
+ The argument ‘(h ())’ of ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
+
+T23153.hs:8:1: error: [GHC-52083]
+ The argument ‘(h ())’ of ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
+
+T23153.hs:8:1: error: [GHC-52083]
+ The argument ‘(h ())’ of ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
=====================================
testsuite/tests/rep-poly/T23154.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+
+module T23154 where
+
+import GHC.Exts
+
+f x = x :: (_ :: (TYPE (_ _)))
=====================================
testsuite/tests/rep-poly/T23154.stderr
=====================================
@@ -0,0 +1,10 @@
+
+T23154.hs:7:1: error: [GHC-52083]
+ The first pattern in the equation for ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
+
+T23154.hs:7:1: error: [GHC-52083]
+ The first pattern in the equation for ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -116,3 +116,5 @@ test('T21650_b', normal, compile_fail, ['-Wno-deprecated-flags']) ##
test('T23051', normal, compile_fail, [''])
+test('T23153', normal, compile_fail, [''])
+test('T23154', normal, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_fail/VtaFail.stderr
=====================================
@@ -7,7 +7,7 @@ VtaFail.hs:7:16: error: [GHC-95781]
answer_nosig = pairup_nosig @Int @Bool 5 True
VtaFail.hs:14:17: error: [GHC-95781]
- • Cannot apply expression of type ‘p1 -> p1’
+ • Cannot apply expression of type ‘p0 -> p0’
to a visible type argument ‘Int’
• In the expression: (\ x -> x) @Int 12
In an equation for ‘answer_lambda’:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f39dbaf6b11a82291ccdec4f627413376f296bba...2c2f984f56b5b3b38800b1c971aa1b45b0fb9814
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f39dbaf6b11a82291ccdec4f627413376f296bba...2c2f984f56b5b3b38800b1c971aa1b45b0fb9814
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230416/1478bfc0/attachment-0001.html>
More information about the ghc-commits
mailing list