Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: e62e731a by Simon Peyton Jones at 2025-09-26T00:05:16+01:00 Now it compiles - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -47,7 +48,7 @@ import GHC.Core.TyCo.Subst ( substTyWithInScope ) import GHC.Core.Type import GHC.Core.Coercion -import GHC.Builtin.Types ( multiplicityTy ) +import GHC.Builtin.Types ( multiplicityTy, runtimeRepTy ) import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names @@ -59,6 +60,7 @@ import GHC.Types.SrcLoc import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) import GHC.Data.Maybe +import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable @@ -395,9 +397,7 @@ tcApp rn_expr exp_res_ty -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun ; (inst_args, app_res_rho) - <- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in - -- Note [tcApp: typechecking applications] - tcInstFun do_ql inst_final tc_head fun_sigma rn_args + <- tcInstFun do_ql inst_final tc_head fun_sigma rn_args ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) @@ -431,10 +431,6 @@ tcApp rn_expr exp_res_ty -- Step 5.5: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } } -setQLInstLevel :: QLFlag -> TcM a -> TcM a -setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside -setQLInstLevel NoQL thing_inside = thing_inside - quickLookResultType :: TcRhoType -> ExpRhoType -> TcM () -- This function implements the shaded bit of rule APP-Downarrow in -- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20). @@ -723,7 +719,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma addHeadCtxt fun_ctxt $ - instantiateSigma fun_orig fun_conc_tvs tvs theta body2 + instantiateSigma do_ql fun_orig fun_conc_tvs tvs theta body2 -- See Note [Representation-polymorphism checking built-ins] -- in GHC.Tc.Utils.Concrete. -- NB: we are doing this even when "acc" is not empty, @@ -786,8 +782,7 @@ 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..] - ; rr_ty <- newFlexiTyVarTyQL do_ql runtimeRepTy - ; res_ty <- newFlexiTyVarTyQL do_ql (mkTYPEapp rr_ty) + ; res_ty <- newOpenFlexiTyVarTyQL do_ql TauTv ; let fun_ty' = mkScaledFunTys arg_tys res_ty -- Fill in kappa := nu_1 -> .. -> nu_n -> res_nu @@ -827,12 +822,12 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType) -- Make a fresh nus for each argument in rule IVAR new_arg_ty (L _ arg) i - = do { arg_nu <- newOpenFlexiFRRTyVarTy $ + = do { arg_nu <- newArgTyVarTyQL do_ql $ FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], -- thereby ensuring that the arguments have concrete runtime representations - ; mult_ty <- newFlexiTyVarTyQL do_ql multiplicityTy + ; mult_ty <- newFlexiTyVarTyQL do_ql (mkTyVarOccFS (fsLit "m")) TauTv multiplicityTy -- mult_ty: e need variables for argument multiplicities (#18731) -- Otherwise, 'undefined x' wouldn't be linear in x @@ -916,30 +911,55 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside {- ********************************************************************* * * Instantiating fresh type variables + + Functions in here use getTcLevelQL to decide what level + to put on fresh unification variables. If do_ql = DoQL, we + ignore the level in the monad, and use QLInstVar instead, + thereby giving birth to a Quick Look instantiation varaible * * ********************************************************************* -} -getTcLevelQL :: DoQL -> TcM TcLevel +getTcLevelQL :: QLFlag -> TcM TcLevel +-- If Quick Look is on, instantiate all fresh unification variables +-- at level QLInstVar; they are instantiation variables 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 +newFlexiTyVarQL :: QLFlag -> OccName -> MetaInfo -> TcKind -> TcM TcTyVar +newFlexiTyVarQL do_ql occ info kind + = do { lvl <- getTcLevelQL do_ql + ; ref <- newMutVar Flexi + ; name <- newSysName occ -- See Note [Name of an unification variable] + -- in GHC.Tc.Utils.TcMType + ; let details = MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = lvl } + ; return (mkTcTyVar name kind details) } + +newFlexiTyVarTyQL :: QLFlag -> OccName -> MetaInfo -> TcKind -> TcM TcType +newFlexiTyVarTyQL do_ql occ info kind + = mkTyVarTy <$> newFlexiTyVarQL do_ql occ info kind + +newOpenFlexiTyVarTyQL :: QLFlag -> MetaInfo -> TcM TcType +newOpenFlexiTyVarTyQL do_ql rr_info + = do { let rr_occ = mkTyVarOccFS (fsLit "cx") + tv_occ = mkTyVarOccFS (fsLit "q") + ; rr_ty <- newFlexiTyVarTyQL do_ql rr_occ rr_info runtimeRepTy + ; arg_nu <- newFlexiTyVarTyQL do_ql tv_occ TauTv (mkTYPEapp rr_ty) + ; return arg_nu } + +newArgTyVarTyQL :: QLFlag -> FixedRuntimeRepContext -> TcM TcType +newArgTyVarTyQL do_ql frr_ctxt + = mdo { let conc_orig = ConcreteFRR $ + FixedRuntimeRepOrigin + { frr_context = frr_ctxt + , frr_type = arg_nu } + ; rr_info <- mkConcreteInfo conc_orig + ; arg_nu <- newOpenFlexiTyVarTyQL do_ql rr_info + ; return arg_nu } + +instantiateSigma :: QLFlag + -> CtOrigin -> ConcreteTyVars -- ^ concreteness information -> [TyVar] -> TcThetaType -> TcSigmaType @@ -947,9 +967,8 @@ instantiateSigma :: CtOrigin -- (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 +instantiateSigma do_ql 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 @@ -959,7 +978,7 @@ instantiateSigma orig do_ql concs tvs theta body_ty , text "tvs" <+> ppr tvs , text "theta" <+> ppr theta , text "type" <+> debugPprType body_ty - , text "with" <+> vcat (map debugPprType inst_tv_tys) + , text "with" <+> ppr inst_tvs , text "theta:" <+> ppr inst_theta ]) ; return (wrap, inst_body) } @@ -969,35 +988,26 @@ instantiateSigma orig do_ql concs tvs theta body_ty -- 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 + new_meta :: Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar) + new_meta final_subst subst tv + = do { let occ = getOccName tv + substd_kind = substTy subst (tyVarKind tv) + ; info <- get_info final_subst tv + ; new_tv <- newFlexiTyVarQL do_ql occ info substd_kind + ; let new_subst = extendTvSubstWithClone subst tv new_tv ; return (new_subst, new_tv) } get_info :: Subst -> TyVar -> TcM MetaInfo - get_info concs final_subst tv + get_info 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) } + = mkConcreteInfo conc_orig -- The vastly common case | otherwise ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -80,7 +80,6 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Name -import GHC.Types.Name.Env import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.Var import qualified GHC.LanguageExtensions as LangExt @@ -304,7 +303,7 @@ topInstantiate orig sigma , text "tvs" <+> ppr tvs , text "theta" <+> ppr theta , text "type" <+> debugPprType body_ty - , text "with" <+> vcat (map debugPprType inst_tv_tys) + , text "with" <+> ppr inst_tvs , text "theta:" <+> ppr inst_theta ]) ; return (wrap2 <.> wrap1, inner_body) } ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Tc.Utils.TcMType ( newOpenBoxedTypeKind, newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, substConcreteTvOrigin, - newAnonMetaTyVar, newConcreteTyVar, + newAnonMetaTyVar, newConcreteTyVar, mkConcreteInfo, cloneMetaTyVar, cloneMetaTyVarWithInfo, newCycleBreakerTyVar, @@ -58,7 +58,6 @@ module GHC.Tc.Utils.TcMType ( newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarBndrsX, newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, - newConcreteTyVarX, newPatTyVar, newSkolemTyVar, newWildCardX, -------------------------------- @@ -714,25 +713,28 @@ used for ScopedTypeVariables in patterns, to make sure these type variables only refer to other type variables, but this restriction was dropped, and ScopedTypeVariables can now refer to full types (GHC Proposal 29). + +Note [Name of a unification variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We give unification variables a /System/ Name, which is eagerly elmininated +the the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and +GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) + +Note [Name of an instantiated type variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we give a unification variable a System Name, which +influences the way it is tidied; see TypeRep.tidyTyVarBndr. -} newMetaTyVarName :: FastString -> TcM Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and --- GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) +-- Makes a /System/ Name; see Note [Name of a unification variable] newMetaTyVarName str = newSysName (mkTyVarOccFS str) cloneMetaTyVarName :: Name -> TcM Name +-- See Note [Name of an instantiated type variable] cloneMetaTyVarName name = newSysName (nameOccName name) - -- See Note [Name of an instantiated type variable] - -{- Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. --} metaInfoToTyVarName :: MetaInfo -> FastString metaInfoToTyVarName meta_info = @@ -795,18 +797,21 @@ newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin -> FastString -> TcKind -> TcM TcTyVar newConcreteTyVar reason fs kind = assertPpr (isConcreteType kind) assert_msg $ - do { th_lvl <- getThLevel - ; if - -- See [Wrinkle: Typed Template Haskell] - -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | TypedBrack _ <- th_lvl - -> newNamedAnonMetaTyVar fs TauTv kind - - | otherwise - -> newNamedAnonMetaTyVar fs (ConcreteTv reason) kind } + do { info <- mkConcreteInfo reason + ; newNamedAnonMetaTyVar fs info kind } where assert_msg = text "newConcreteTyVar: non-concrete kind" <+> ppr kind +mkConcreteInfo :: ConcreteTvOrigin -> TcM MetaInfo +-- Usually returns (ConcreteTv origin); but if we are in a typed +-- Template Haskell bracket, return TauTv +-- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete +mkConcreteInfo conc_origin + = do { th_lvl <- getThLevel + ; case th_lvl of + TypedBrack {} -> return TauTv + _ -> return (ConcreteTv conc_origin) } + newPatTyVar :: Name -> Kind -> TcM TcTyVar newPatTyVar name kind = do { details <- newMetaDetails TauTv @@ -981,18 +986,13 @@ newOpenFlexiTyVar -- in GHC.Tc.Utils.Concrete. newOpenFlexiFRRTyVar :: FixedRuntimeRepContext -> TcM TcTyVar newOpenFlexiFRRTyVar frr_ctxt - = do { th_lvl <- getThLevel - ; case th_lvl of - { TypedBrack _ -- See [Wrinkle: Typed Template Haskell] - -> newOpenFlexiTyVar -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - ; _ -> - mdo { let conc_orig = ConcreteFRR $ + = mdo { let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin { frr_context = frr_ctxt , frr_type = mkTyVarTy tv } - ; rr <- mkTyVarTy <$> newConcreteTyVar conc_orig (fsLit "cx") runtimeRepTy - ; tv <- newFlexiTyVar (mkTYPEapp rr) - ; return tv } } } + ; rr_tv <- newConcreteTyVar conc_orig (fsLit "cx") runtimeRepTy + ; tv <- newFlexiTyVar (mkTYPEapp (mkTyVarTy rr_tv)) + ; return tv } -- | See 'newOpenFlexiFRRTyVar'. newOpenFlexiFRRTyVarTy :: FixedRuntimeRepContext -> TcM TcType View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e62e731ae896667b0b6099b497251477... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e62e731ae896667b0b6099b497251477... You're receiving this email because of your account on gitlab.haskell.org.