[Git][ghc/ghc][wip/T23153] Handle ConcreteTvs in inferResultToType
Krzysztof Gogolewski (@monoidal)
gitlab at gitlab.haskell.org
Thu Mar 23 13:17:56 UTC 2023
Krzysztof Gogolewski pushed to branch wip/T23153 at Glasgow Haskell Compiler / GHC
Commits:
307ca52b by sheaf at 2023-03-23T14:16:11+01:00
Handle ConcreteTvs in inferResultToType
This patch fixes two issues.
1. 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.
2. startSolvingByUnification can make some type variables concrete.
However, it didn't return an updated type, so callers of this
function, if they don't zonk, might miss this and accidentally
perform a double update of a metavariable.
We now return the updated type from this function, which avoids
this issue.
Fixes #23154
- - - - -
11 changed files:
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- testsuite/tests/rep-poly/RepPolyPatBind.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/Tc/Gen/Head.hs
=====================================
@@ -908,7 +908,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/Equality.hs
=====================================
@@ -1651,7 +1651,7 @@ canEqTyVarFunEq :: CtEvidence -- :: lhs ~ (rhs |> mco)
-> MCoercion -- :: kind(rhs) ~N kind(lhs)
-> TcS (StopOrContinue Ct)
canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
- = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs
+ = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv1 rhs
; if | case is_touchable of { Untouchable -> False; _ -> True }
, cterHasNoProblem $
checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily
@@ -2440,7 +2440,7 @@ tryToSolveByUnification tv
; dont_unify }
| otherwise
- = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs
+ = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs
; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs
, ppr is_touchable ])
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1326,35 +1326,37 @@ instance Outputable TouchabilityTestResult where
ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)
ppr Untouchable = text "Untouchable"
-touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult
--- This is the key test for untouchability:
+touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS (TouchabilityTestResult, TcType)
+-- ^ This is the key test for untouchability:
-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify
-- and Note [Solve by unification] in GHC.Tc.Solver.Interact
+--
+-- Returns a new rhs type, as this function can turn make some metavariables concrete.
touchabilityTest flav tv1 rhs
| flav /= Given -- See Note [Do not unify Givens]
, MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1
- = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs
- ; if not can_continue_solving
- then return Untouchable
- else
- do { ambient_lvl <- getTcLevel
+ = do { continue_solving <- wrapTcS $ startSolvingByUnification info rhs
+ ; case continue_solving of
+ { Nothing -> return (Untouchable, rhs)
+ ; Just rhs ->
+ do { let (free_metas, free_skols) = partition isPromotableMetaTyVar $
+ nonDetEltsUniqSet $
+ tyCoVarsOfType rhs
+ ; ambient_lvl <- getTcLevel
; given_eq_lvl <- getInnermostGivenEqLevel
; if | tv_lvl `sameDepthAs` ambient_lvl
- -> return TouchableSameLevel
+ -> return (TouchableSameLevel, rhs)
| tv_lvl `deeperThanOrSame` given_eq_lvl -- No intervening given equalities
, all (does_not_escape tv_lvl) free_skols -- No skolem escapes
- -> return (TouchableOuterLevel free_metas tv_lvl)
+ -> return (TouchableOuterLevel free_metas tv_lvl, rhs)
| otherwise
- -> return Untouchable } }
+ -> return (Untouchable, rhs) } } }
| otherwise
- = return Untouchable
+ = return (Untouchable, rhs)
where
- (free_metas, free_skols) = partition isPromotableMetaTyVar $
- nonDetEltsUniqSet $
- tyCoVarsOfType rhs
does_not_escape tv_lvl fv
| isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv
@@ -2165,23 +2167,21 @@ breakTyEqCycle_maybe ev cte_result lhs rhs
-- See Detail (8) of the Note.
= do { should_break <- final_check
- ; if should_break then do { redn <- go rhs
- ; return (Just redn) }
- else return Nothing }
+ ; mapM go should_break }
where
flavour = ctEvFlavour ev
eq_rel = ctEvEqRel ev
final_check = case flavour of
- Given -> return True
+ Given -> return $ Just rhs
Wanted -- Wanteds work only with a touchable tyvar on the left
-- See "Wanted" section of the Note.
| TyVarLHS lhs_tv <- lhs ->
- do { result <- touchabilityTest Wanted lhs_tv rhs
+ do { (result, rhs) <- touchabilityTest Wanted lhs_tv rhs
; return $ case result of
- Untouchable -> False
- _ -> True }
- | otherwise -> return False
+ Untouchable -> Nothing
+ _ -> Just rhs }
+ | otherwise -> return Nothing
-- This could be considerably more efficient. See Detail (5) of Note.
go :: TcType -> TcS ReductionN
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -480,7 +481,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
@@ -536,20 +546,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 <- newConcreteTyVarAtLevel conc_orig tc_lvl runtimeRepTy
+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
+ ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
+ ; return tau }
{- Note [inferResultToType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -872,6 +890,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) $
@@ -917,7 +942,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
@@ -935,7 +960,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
@@ -1100,6 +1125,13 @@ newMetaTyVarTyAtLevel tc_lvl kind
; name <- newMetaTyVarName (fsLit "p")
; return (mkTyVarTy (mkTcTyVar name kind details)) }
+newConcreteTyVarAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType
+newConcreteTyVarAtLevel conc_orig tc_lvl kind
+ = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl
+ ; name <- newMetaTyVarName (fsLit "c")
+ ; return (mkTyVarTy (mkTcTyVar name kind details)) }
+
+
{- *********************************************************************
* *
Finding variables to quantify over
@@ -2235,7 +2267,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
@@ -2253,7 +2285,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/Unify.hs
=====================================
@@ -2072,10 +2072,10 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
-- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
, cterHasNoProblem (checkTyVarEq tv1 ty2)
-- See Note [Prevent unification with type families]
- = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2
- ; if not can_continue_solving
- then not_ok_so_defer
- else
+ = do { mb_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2
+ ; case mb_continue_solving of
+ { Nothing -> not_ok_so_defer
+ ; Just ty2 ->
do { co_k <- uType KindLevel kind_origin (typeKind ty2) (tyVarKind tv1)
; traceTc "uUnfilledVar2 ok" $
vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
@@ -2089,9 +2089,9 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
then do { writeMetaTyVar tv1 ty2
; return (mkNomReflCo ty2) }
- else defer }} -- This cannot be solved now. See GHC.Tc.Solver.Canonical
- -- Note [Equalities with incompatible kinds] for how
- -- this will be dealt with in the solver
+ else defer }}} -- This cannot be solved now. See GHC.Tc.Solver.Canonical
+ -- Note [Equalities with incompatible kinds] for how
+ -- this will be dealt with in the solver
| otherwise
= not_ok_so_defer
@@ -2111,39 +2111,38 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
-- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of
-- Note [Unification preconditions]; returns True if these conditions
-- are satisfied. But see the Note for other preconditions, too.
-startSolvingByUnification :: MetaInfo -> TcType -- zonked
- -> TcM Bool
+startSolvingByUnification :: MetaInfo -> TcType -- zonked
+ -> TcM (Maybe TcType)
startSolvingByUnification _ xi
| hasCoercionHoleTy xi -- (COERCION-HOLE) check
- = return False
+ = return Nothing
startSolvingByUnification info xi
= case info of
- CycleBreakerTv -> return False
+ CycleBreakerTv -> return Nothing
ConcreteTv conc_orig ->
- do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi
+ do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi
-- NB: makeTypeConcrete has the side-effect of turning
-- some TauTvs into ConcreteTvs, e.g.
-- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ])
-- will write `beta[tau] := beta[conc]`.
--
- -- We don't need to track these unifications for the purposes
- -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl),
- -- as they don't unlock any further progress.
+ -- We return the new type, so that callers of this function
+ -- aren't required to zonk.
; case not_conc_reasons of
- [] -> return True
- _ -> return False }
+ [] -> return $ Just xi
+ _ -> return Nothing }
TyVarTv ->
case getTyVar_maybe xi of
- Nothing -> return False
+ Nothing -> return Nothing
Just tv ->
case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle
- SkolemTv {} -> return True
- RuntimeUnk -> return True
+ SkolemTv {} -> return $ Just xi
+ RuntimeUnk -> return $ Just xi
MetaTv { mtv_info = info } ->
case info of
- TyVarTv -> return True
- _ -> return False
- _ -> return True
+ TyVarTv -> return $ Just xi
+ _ -> return Nothing
+ _ -> return $ Just xi
swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool
swapOverTyVars is_given tv1 tv2
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -1738,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
=====================================
testsuite/tests/rep-poly/RepPolyPatBind.stderr
=====================================
@@ -17,3 +17,36 @@ RepPolyPatBind.hs:18:5: error: [GHC-55287]
x, y :: a
(# x, y #) = undefined
in x
+
+RepPolyPatBind.hs:18:8: error: [GHC-55287]
+ • The pattern binding does not have a fixed runtime representation.
+ Its type is:
+ (# a0, b0 #) :: TYPE (TupleRep [k00, k10])
+ Cannot unify ‘rep’ with the type variable ‘k00’
+ 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:11: error: [GHC-55287]
+ • The pattern binding does not have a fixed runtime representation.
+ Its type is:
+ (# a0, b0 #) :: TYPE (TupleRep [k00, k10])
+ Cannot unify ‘rep’ with the type variable ‘k10’
+ 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
+ x :: a (bound at RepPolyPatBind.hs:18:8)
+ foo :: () -> a (bound at RepPolyPatBind.hs:15:1)
=====================================
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,15 @@
+
+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.
+
+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
=====================================
@@ -117,3 +117,4 @@ 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/-/commit/307ca52badaa72fba06a3f4db006c5204f5b3035
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/307ca52badaa72fba06a3f4db006c5204f5b3035
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/20230323/74ac839a/attachment-0001.html>
More information about the ghc-commits
mailing list