Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 3ab8c71c by Simon Peyton Jones at 2025-09-25T17:40:20+01:00 Stop putting QLInstVar into the tc_lvl environment [skip ci] This is really a bug! See (TCAPP2) Not done yet - - - - - 5 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -719,7 +719,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args , let no_tvs = null tvs no_theta = null theta , not (no_tvs && no_theta) - = do { (_inst_tvs, wrap, fun_rho) <- + = do { (wrap, fun_rho) <- -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma addHeadCtxt fun_ctxt $ @@ -786,7 +786,8 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args -- not defer in any way, because this is a QL instantiation variable. -- It's easier just to do the job directly here. do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..] - ; res_ty <- newOpenFlexiTyVarTy + ; rr_ty <- newFlexiTyVarTyQL do_ql runtimeRepTy + ; res_ty <- newFlexiTyVarTyQL do_ql (mkTYPEapp rr_ty) ; let fun_ty' = mkScaledFunTys arg_tys res_ty -- Fill in kappa := nu_1 -> .. -> nu_n -> res_nu @@ -831,7 +832,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], -- thereby ensuring that the arguments have concrete runtime representations - ; mult_ty <- newFlexiTyVarTy multiplicityTy + ; mult_ty <- newFlexiTyVarTyQL do_ql multiplicityTy -- mult_ty: e need variables for argument multiplicities (#18731) -- Otherwise, 'undefined x' wouldn't be linear in x @@ -912,6 +913,96 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated thing_inside } +{- ********************************************************************* +* * + Instantiating fresh type variables +* * +********************************************************************* -} + +getTcLevelQL :: DoQL -> TcM TcLevel +getTcLevelQL DoQL = return QLInstVar +getTcLevelQL NoQL = getTcLevel + +newFlexiTyVarTyQL :: DoQL -> TcKind -> TcM TcType +newFlexiTyVarTyQL do_ql kind + = do { lvl <- getTcLevelQL do_ql + ; newMetaTyVarTyAtLevel lvl kind } + +{- +newArgTyVarQL do_ql frr_ctxt + = do { th_lvl <- getThLevel + ; rr_ty <- case th_lvl of + TypedBrack {} -> newFlexiTyVarTyQL do_ql runtimeRepTy + _ -> mdo { + ; rr_ty <- + ; newFlexiTyVarTyQL do_ql (mkTYPEapp rr_ty) } +-} + +instantiateSigma :: CtOrigin + -> QLFlag + -> ConcreteTyVars -- ^ concreteness information + -> [TyVar] + -> TcThetaType -> TcSigmaType + -> TcM (HsWrapper, TcSigmaType) +-- (instantiate orig tvs theta ty) +-- instantiates the type variables tvs, emits the (instantiated) +-- constraints theta, and returns the (instantiated) type ty +instantiateSigma orig do_ql concs tvs theta body_ty + = do { tv_lvl <- getTcLevelQL do_ql + ; rec (subst, inst_tvs) <- mapAccumLM (new_meta tv_lvl subst) empty_subst tvs + ; let inst_theta = substTheta subst theta + inst_body = substTy subst body_ty + + ; wrap <- instCall orig (mkTyVarTys inst_tvs) inst_theta + ; traceTc "Instantiating" + (vcat [ text "origin" <+> pprCtOrigin orig + , text "tvs" <+> ppr tvs + , text "theta" <+> ppr theta + , text "type" <+> debugPprType body_ty + , text "with" <+> vcat (map debugPprType inst_tv_tys) + , text "theta:" <+> ppr inst_theta ]) + + ; return (wrap, inst_body) } + where + in_scope = mkInScopeSet (tyCoVarsOfType (mkSpecSigmaTy tvs theta body_ty)) + -- mkSpecSigmaTy: Inferred vs Specified is not important here; + -- We just want an accurate free-var set + empty_subst = mkEmptySubst in_scope + + new_meta :: TcLevel -> Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar) + new_meta tv_lvl final_subst subst tv + = do { name <- cloneMetaTyVarName (tyVarName tv) + ; ref <- newMutVar Flexi + ; info <- get_info tv + ; let details = MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tv_lvl } + ; let substd_kind = substTy subst (tyVarKind tv) + new_tv = mkTcTyVar name substd_kind details + new_subst = extendTvSubstWithClone subst tv new_tv + ; return (new_subst, new_tv) } + + get_info :: Subst -> TyVar -> TcM MetaInfo + get_info concs final_subst tv + -- Is this a type variable that must be instantiated to a concrete type? + -- If so, create a ConcreteTv metavariable instead of a plain TauTv. + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + -- + -- But check TH level: see [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv) + , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0 + -- See Note [substConcreteTvOrigin]. + = do { th_lvl <- getThLevel + ; case th_lvl of + TypedBrack {} -> return TauTv + _ -> return (ConcreteTv conc) } + + -- The vastly common case + | otherwise + = return TauTv + {- ********************************************************************* * * Visible type application ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1799,12 +1799,20 @@ reportCoarseGrainUnifications (TcS thing_inside) ; unless (inner_ul `deeperThanOrSame` outer_ul) $ TcM.writeTcRef outer_ul_ref inner_ul ; let unif_happened = ambient_lvl `deeperThanOrSame` inner_ul + ; TcM.traceTc "reportCoarse(Coarse)" $ + vcat [ text "ambient" <+> ppr ambient_lvl + , text "outer_ul" <+> ppr outer_ul + , text "inner_ul" <+> ppr inner_ul + , text "unif_happened" <+> ppr unif_happened ] ; return (unif_happened, res) } WU_Fine outer_tvs_ref -> do { (unif_tvs,res) <- report_fine_grain_unifs env thing_inside ; let unif_happened = not (isEmptyVarSet unif_tvs) ; when unif_happened $ TcM.updTcRef outer_tvs_ref (`unionVarSet` unif_tvs) + ; TcM.traceTc "reportCoarse(Fine)" $ + vcat [ text "unif_tvs" <+> ppr unif_tvs + , text "unif_happened" <+> ppr unif_happened ] ; return (unif_happened, res) } report_fine_grain_unifs :: TcSEnv -> (TcSEnv -> TcM a) -> TcM (TcTyVarSet, a) ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -359,7 +359,7 @@ solveNestedImplications :: Bag Implication -- to be converted to givens before we go inside a nested implication. solveNestedImplications implics | isEmptyBag implics - = return (emptyBag) + = return emptyBag | otherwise = do { traceTcS "solveNestedImplications starting {" empty ; unsolved_implics <- mapBagM solveImplication implics ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -13,7 +13,6 @@ module GHC.Tc.Utils.Instantiate ( topSkolemise, skolemiseRequired, topInstantiate, - instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, newWanted, newWanteds, @@ -283,38 +282,24 @@ topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -- NB: returns a type with no (=>), -- and no invisible forall at the top topInstantiate orig sigma - | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma - , (theta, body2) <- tcSplitPhiTy body1 + | (tvs, phi_ty) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma + , (theta, body_ty) <- tcSplitPhiTy phi_ty , not (null tvs && null theta) - = do { (_, wrap1, body3) <- instantiateSigma orig noConcreteTyVars tvs theta body2 - -- Why 'noConcreteTyVars' here? + = do { (subst, inst_tvs) <- newMetaTyVarsX empty_subst tvs + -- No need to worry about concrete tyvars here (c.f. instantiateSigma) -- See Note [Representation-polymorphism checking built-ins] -- in GHC.Tc.Utils.Concrete. + ; let inst_theta = substTheta subst theta + inst_body = substTy subst body_ty + + ; wrap1 <- instCall orig (mkTyVarTys inst_tvs) inst_theta + -- Loop, to account for types like -- forall a. Num a => forall b. Ord b => ... - ; (wrap2, body4) <- topInstantiate orig body3 - - ; return (wrap2 <.> wrap1, body4) } - - | otherwise = return (idHsWrapper, sigma) - -instantiateSigma :: CtOrigin - -> ConcreteTyVars -- ^ concreteness information - -> [TyVar] - -> TcThetaType -> TcSigmaType - -> TcM ([TcTyVar], HsWrapper, TcSigmaType) --- (instantiate orig tvs theta ty) --- instantiates the type variables tvs, emits the (instantiated) --- constraints theta, and returns the (instantiated) type ty -instantiateSigma orig concs tvs theta body_ty - = do { rec (subst, inst_tvs) <- mapAccumLM (new_meta subst) empty_subst tvs - ; let inst_theta = substTheta subst theta - inst_body = substTy subst body_ty - inst_tv_tys = mkTyVarTys inst_tvs - - ; wrap <- instCall orig inst_tv_tys inst_theta - ; traceTc "Instantiating" + ; (wrap2, inner_body) <- topInstantiate orig inst_body + + ; traceTc "topInstantiate" (vcat [ text "origin" <+> pprCtOrigin orig , text "tvs" <+> ppr tvs , text "theta" <+> ppr theta @@ -322,23 +307,14 @@ instantiateSigma orig concs tvs theta body_ty , text "with" <+> vcat (map debugPprType inst_tv_tys) , text "theta:" <+> ppr inst_theta ]) - ; return (inst_tvs, wrap, inst_body) } + ; return (wrap2 <.> wrap1, inner_body) } + + | otherwise + = return (idHsWrapper, sigma) + where - in_scope = mkInScopeSet (tyCoVarsOfType (mkSpecSigmaTy tvs theta body_ty)) - -- mkSpecSigmaTy: Inferred vs Specified is not important here; - -- We just want an accurate free-var set - empty_subst = mkEmptySubst in_scope - new_meta :: Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar) - new_meta final_subst subst tv - -- Is this a type variable that must be instantiated to a concrete type? - -- If so, create a ConcreteTv metavariable instead of a plain TauTv. - -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. - | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv) - , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0 - -- See Note [substConcreteTvOrigin]. - = newConcreteTyVarX conc_orig subst tv - | otherwise - = newMetaTyVarX subst tv + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType sigma)) + instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM Subst -- Use this when you want to instantiate (forall a b c. ty) with ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -1032,18 +1032,6 @@ newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- an existing TyVar. We substitute kind variables in the kind. newMetaTyVarX = new_meta_tv_x TauTv --- | Like 'newMetaTyVarX', but for concrete type variables. -newConcreteTyVarX :: ConcreteTvOrigin -> Subst -> TyVar -> TcM (Subst, TcTyVar) -newConcreteTyVarX conc subst tv - = do { th_lvl <- getThLevel - ; if - -- See [Wrinkle: Typed Template Haskell] - -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | TypedBrack _ <- th_lvl - -> new_meta_tv_x TauTv subst tv - | otherwise - -> new_meta_tv_x (ConcreteTv conc) subst tv } - newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Just like newMetaTyVarX, but make a TyVarTv newMetaTyVarTyVarX subst tv = new_meta_tv_x TyVarTv subst tv View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ab8c71c340d649fe9038fd98dfae108... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ab8c71c340d649fe9038fd98dfae108... You're receiving this email because of your account on gitlab.haskell.org.