Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: e69b3f51 by Simon Peyton Jones at 2025-07-13T23:52:25+01:00 Proper occurrence analysis for TyCoVars - - - - - 11 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Var.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -42,7 +42,8 @@ module GHC.Core ( foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, collectNBinders, collectNValBinders_maybe, - collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectArgs, collectValArgs, stripNArgs, collectArgsTicks, + flattenBinds, glomValBinds, mapBindBndrs, collectFunSimple, exprToType, @@ -2174,7 +2175,6 @@ foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds where fold_bind = (foldBindersOfBindStrict f) - rhssOfBind :: Bind b -> [Expr b] rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] @@ -2189,6 +2189,21 @@ flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds flattenBinds [] = [] +glomValBinds :: [Bind b] -> [Bind b] +-- Glom all the value bindings into a single Rec; +-- Leave any type bindings as NonRecs, bringing them to the front +glomValBinds bs = go [] bs + where + go prs (b@(NonRec _ (Type {})) : bs) = b : go prs bs + go prs (NonRec b r : bs) = go ((b,r) : prs) bs + go prs (Rec rprs : bs) = go (rprs ++ prs) bs + go [] [] = [] + go prs [] = [Rec prs] + +mapBindBndrs :: (b -> b) -> Bind b -> Bind b +mapBindBndrs f (NonRec b r) = NonRec (f b) r +mapBindBndrs f (Rec prs) = Rec (mapFst f prs) + -- | We often want to strip off leading lambdas before getting down to -- business. Variants are 'collectTyBinders', 'collectValBinders', -- and 'collectTyAndValBinders' ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -39,7 +39,6 @@ import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion import GHC.Core.Predicate ( isDictId ) import GHC.Core.Type -import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) import GHC.Data.Maybe( orElse ) @@ -50,6 +49,7 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Id +import GHC.Types.Name( isExternalName ) import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Tickish @@ -65,6 +65,8 @@ import GHC.Utils.Misc import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) +import qualified Data.Semigroup as S( Semigroup(..) ) +import qualified Data.Monoid as S( Monoid(..) ) import Data.List (mapAccumL) import Data.List.NonEmpty (NonEmpty (..)) @@ -100,18 +102,15 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds init_env = initOccEnv { occ_rule_act = active_rule , occ_unf_act = active_unf } - WUD final_usage occ_anald_binds = go binds init_env - WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel - imp_rule_edges - (flattenBinds binds) - initial_uds + WUD final_usage occ_anald_binds = go binds init_env + WUD _ occ_anald_glommed_binds = go (glomValBinds binds) init_env -- It's crucial to re-analyse the glommed-together bindings -- so that we establish the right loop breakers. Otherwise -- we can easily create an infinite loop (#9583 is an example) -- - -- Also crucial to re-analyse the /original/ bindings - -- in case the first pass accidentally discarded as dead code - -- a binding that was actually needed (albeit before its + -- Also crucial to re-analyse the /original/ bindings, not the + -- occ_anald_binds, in case the first pass accidentally discarded as + -- dead code a binding that was actually needed (albeit before its -- definition site). #17724 threw this up. initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules) @@ -971,16 +970,32 @@ occAnalBind -> WithUsageDetails r -- Of the whole let(rec) occAnalBind env lvl ire (Rec pairs) thing_inside combine - = addInScopeList env (map fst pairs) $ \env -> + = addInScope env (map fst pairs) $ \env -> let WUD body_uds body' = thing_inside env WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds in WUD bind_uds (combine binds' body') -occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine - | isTyVar bndr -- A type let; we don't gather usage info - = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside - in WUD body_uds (combine [NonRec bndr rhs] res) +occAnalBind !env _lvl _ire (NonRec bndr rhs) thing_inside combine + | isTyCoVar bndr -- A type/coercion let + = let !(WUD body_uds (occ,res)) + = addInScopeOne env bndr $ \env_body -> + let !(WUD inner_uds inner_res) = thing_inside env_body + !tyco_occ = lookupTyCoOcc inner_uds bndr + in (WUD inner_uds (tyco_occ, inner_res)) + + rhs_tyco_occs = case rhs of + Type ty -> occAnalTy ty + Coercion co -> occAnalCo co + _ -> pprPanic "occAnalBind" (ppr (NonRec bndr rhs)) + in + case occ of + TyCoDead -> WUD body_uds res + _ -> WUD (body_uds `addTyCoOccs` rhs_tyco_occs) + (combine [NonRec bndr' rhs] res) + where + bndr' = tagTyCoBinder occ bndr +occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine -- /Existing/ non-recursive join points -- See Note [Occurrence analysis for join points] | mb_join@(JoinPoint {}) <- idJoinPointHood bndr @@ -1134,19 +1149,13 @@ occAnalRec :: OccEnv -> TopLevelFlag -> WithUsageDetails [CoreBind] -- The NonRec case is just like a Let (NonRec ...) above +-- except that type variables can't occur occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) (WUD body_uds binds) - -- Currently we don't gather occ-info for tyvars, - -- so we never discard dead bindings -- Need to fix this - | isTyVar bndr - = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr - !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds - !bndr' = tagged_bndr - in WUD (body_uds `andUDs` rhs_uds') - (NonRec bndr' rhs' : binds) - - | isDeadOcc occ -- Check for dead code: see Note [Dead code] + | assertPpr (not (isTyVar bndr)) (ppr bndr) $ + -- Rec blocks have no TyVar bindings in them + isDeadOcc occ -- Check for dead code: see Note [Dead code] = WUD body_uds binds | otherwise @@ -1705,7 +1714,7 @@ rank (r, _, _) = r makeNode :: OccEnv -> ImpRuleEdges -> VarSet -> (Var, CoreExpr) -> LetrecNode -- See Note [Recursive bindings: the grand plan] -makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty)) +makeNode !_env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty)) = -- This is a type binding, e.g. let @x = Maybe Int in ... assert (isTyVar bndr) $ DigraphNode { node_payload = details @@ -1719,8 +1728,7 @@ makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty)) , nd_weak_fvs = emptyVarSet , nd_active_rule_fvs = emptyVarSet } - rhs_env = setNonTailCtxt OccRhs env - rhs_uds = occAnalTy rhs_env rhs_ty + rhs_uds = mkTyCoUDs (occAnalTy rhs_ty) rhs_fvs = udFreeVars bndr_set rhs_uds makeNode !env imp_rule_edges bndr_set (bndr, rhs) @@ -2229,9 +2237,9 @@ occ_anal_lam_tail env (Cast expr co) = let WUD expr_uds expr' = occ_anal_lam_tail env expr -- co_uds: see Note [Gather occurrences of coercion variables] - co_uds = occAnalCo env co + co_uds = occAnalCo co - usage1 = expr_uds `andUDs` co_uds + usage1 = expr_uds `addTyCoOccs` co_uds -- usage2: see Note [Occ-anal and cast worker/wrapper] usage2 = case expr of @@ -2436,14 +2444,54 @@ float ==> This is worse than the slow cascade, so we only want to say "certainly_inline" if it really is certain. Look at the note with preInlineUnconditionally for the various clauses. See #24582 for an example of the two getting out of sync. +-} + +{- ********************************************************************* +* * + Types +* * +********************************************************************* -} +newtype TyCoOccs = TyCoOccs { get_tyco_occs :: TyCoOccEnv } -************************************************************************ +instance S.Semigroup TyCoOccs where + (TyCoOccs o1) <> (TyCoOccs o2) = TyCoOccs (plusTyCoOccEnv o1 o2) + +instance S.Monoid TyCoOccs where + mempty = TyCoOccs emptyVarEnv + +occTyCoFolder :: TyCoFolder TyCoVarSet TyCoOccs +occTyCoFolder + = TyCoFolder { tcf_view = \_ -> Nothing -- No need to expand synonyms + , tcf_tyvar = do_var + , tcf_covar = do_var + , tcf_hole = \_ h -> pprPanic "occTyCoFolder:hole" (ppr h) + , tcf_tycobinder = do_binder } + where + do_var :: TyCoVarSet -> TyCoVar -> TyCoOccs + do_var locals tcv + | tcv `elemVarSet` locals = mempty + | isExternalName (varName tcv) = mempty -- TyVars from other modules + | otherwise = TyCoOccs (unitVarEnv tcv TyCoOne) + + do_binder :: TyCoVarSet -> TyCoVar -> ForAllTyFlag -> TyCoVarSet + do_binder locals tcv _ = extendVarSet locals tcv + +occAnalTy :: Type -> TyCoOccEnv +occAnalCo :: Coercion -> TyCoOccEnv +occAnalTy ty = get_tyco_occs (occ_anal_ty ty) +occAnalCo co = get_tyco_occs (occ_anal_co co) + +occ_anal_ty :: Type -> TyCoOccs +occ_anal_co :: Coercion -> TyCoOccs +(occ_anal_ty, _, occ_anal_co, _) = foldTyCo occTyCoFolder emptyVarSet +-- No need to return a modified type, unlike expressions + +{- ********************************************************************* * * Expressions * * -************************************************************************ --} +********************************************************************* -} occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr] occAnalList !_ [] = WUD emptyDetails [] @@ -2452,50 +2500,6 @@ occAnalList env (e:es) = let (WUD uds2 es') = occAnalList env es in WUD (uds1 `andUDs` uds2) (e' : es') -occAnalTys :: OccEnv -> [Type] -> UsageDetails -occAnalTys env tys = foldr (andUDs . occAnalTy env) emptyDetails tys - -occAnalTy :: OccEnv -> Type -> UsageDetails --- No need to return a modified type, unlike expressions -occAnalTy env (TyVarTy tv) = mkOneTyVarOcc env tv -occAnalTy _ (LitTy {}) = emptyDetails -occAnalTy env (AppTy t1 t2) = occAnalTy env t1 `andUDs` occAnalTy env t2 -occAnalTy env (CastTy ty co) = occAnalTy env ty `andUDs` occAnalCo env co -occAnalTy env (CoercionTy co) = occAnalCo env co -occAnalTy env (TyConApp _ tys) = occAnalTys env tys -occAnalTy env (ForAllTy (Bndr tv _) ty) = delBndrsFromUDs [tv] (occAnalTy env ty) -occAnalTy env (FunTy { ft_mult = w, ft_arg = arg, ft_res = res }) - = occAnalTy env w `andUDs` occAnalTy env arg `andUDs` occAnalTy env res - -occAnalCos :: OccEnv -> [Coercion] -> UsageDetails -occAnalCos env cos = foldr (andUDs . occAnalCo env) emptyDetails cos - -occAnalMCo :: OccEnv -> MCoercion -> UsageDetails -occAnalMCo _ MRefl = emptyDetails -occAnalMCo env (MCo co) = occAnalCo env co - -occAnalCo :: OccEnv -> Coercion -> UsageDetails -occAnalCo !env (Refl ty) = occAnalTy env ty -occAnalCo !env (GRefl _ ty mco) = occAnalTy env ty `andUDs` occAnalMCo env mco -occAnalCo !env (AppCo co1 co2) = occAnalCo env co1 `andUDs` occAnalCo env co2 -occAnalCo env (CoVarCo cv) = mkOneIdOcc env cv NotInteresting 0 -occAnalCo _ (HoleCo hole) = pprPanic "occAnalCo:HoleCo" (ppr hole) -occAnalCo env (SymCo co) = occAnalCo env co -occAnalCo env (TransCo co1 co2) = occAnalCo env co1 `andUDs` occAnalCo env co2 -occAnalCo env (AxiomCo _ cos) = occAnalCos env cos -occAnalCo env (SelCo _ co) = occAnalCo env co -occAnalCo env (LRCo _ co) = occAnalCo env co -occAnalCo env (InstCo co arg) = occAnalCo env co `andUDs` occAnalCo env arg -occAnalCo env (KindCo co) = occAnalCo env co -occAnalCo env (SubCo co) = occAnalCo env co -occAnalCo env (TyConAppCo _ _ cos) = occAnalCos env cos -occAnalCo !env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 }) - = occAnalCo env cw `andUDs` occAnalCo env c1 `andUDs` occAnalCo env c2 -occAnalCo env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos }) - = occAnalTy env t1 `andUDs` occAnalTy env t2 `andUDs` occAnalCos env cos -occAnalCo env (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) - = occAnalCo env kind_co `andUDs` delBndrsFromUDs [tv] (occAnalCo env co) - occAnal :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr -- Gives info only about the "interesting" Ids @@ -2510,8 +2514,8 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], []) -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. -occAnal env (Type ty) = WUD (occAnalTy env ty) (Type ty) -occAnal env (Coercion co) = WUD (occAnalCo env co) (Coercion co) +occAnal _env (Type ty) = WUD (mkTyCoUDs (occAnalTy ty)) (Type ty) +occAnal _env (Coercion co) = WUD (mkTyCoUDs (occAnalCo co)) (Coercion co) {- Note [Gather occurrences of coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2589,10 +2593,10 @@ occAnal env (Tick tickish body) occAnal env (Cast expr co) = let (WUD expr_uds expr') = occAnal env expr - co_uds = occAnalCo env co + co_uds = occAnalCo co -- co_uds: see Note [Gather occurrences of coercion variables] - uds = markAllNonTail (expr_uds `andUDs` co_uds) - -- co_uds': calls inside expr aren't tail calls any more + uds = markAllNonTail (expr_uds `addTyCoOccs` co_uds) + -- markAllNonTail: calls inside expr aren't tail calls any more in WUD uds (Cast expr' co) occAnal env app@(App _ _) @@ -2614,7 +2618,9 @@ occAnal env (Case scrut bndr ty alts) tagged_bndr = tagLamBinder alts_usage bndr in WUD alts_usage (tagged_bndr, alts') - total_usage = markAllNonTail scrut_usage `andUDs` alts_usage + total_usage = markAllNonTail scrut_usage + `andUDs` alts_usage + `addTyCoOccs` occAnalTy ty -- Alts can have tail calls, but the scrutinee can't in WUD total_usage (Case scrut' tagged_bndr ty alts') @@ -2719,7 +2725,7 @@ occAnalApp !env (Var fun, args, ticks) occAnalApp env (Var fun_id, args, ticks) = WUD all_uds (mkTicks ticks app') where - -- Lots of banged bindings: this is a very heavily bit of code, + -- Lots of banged bindings: this is a very heavily used bit of code, -- so it pays not to make lots of thunks here, all of which -- will ultimately be forced. !(fun', fun_id') = lookupBndrSwap env fun_id @@ -3136,24 +3142,23 @@ addInScope :: OccEnv -> [Var] -- We do not assume that the bndrs are in scope order; in fact the -- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order --- Fast path when the is no environment-munging to do --- This is rather common: notably at top level, but nested too addInScope env bndrs thing_inside | null bndrs -- E.g. nullary constructors in a `case` = thing_inside env + -- Fast path when the is no environment-munging to do + -- This is rather common: notably at top level, but nested too | isEmptyVarEnv (occ_bs_env env) , isEmptyVarEnv (occ_join_points env) , WUD uds res <- thing_inside env = WUD (delBndrsFromUDs bndrs uds) res -addInScope env bndrs thing_inside + -- Normal path + | let !(env', bad_joins) = preprocess_env env bndr_set + !(WUD uds res) = thing_inside env' + uds' = postprocess_uds bndrs bad_joins uds + bndr_set = mkVarSet bndrs = WUD uds' res - where - bndr_set = mkVarSet bndrs - !(env', bad_joins) = preprocess_env env bndr_set - !(WUD uds res) = thing_inside env' - uds' = postprocess_uds bndrs bad_joins uds preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo) preprocess_env env@(OccEnv { occ_join_points = join_points @@ -3668,8 +3673,8 @@ For example, in (case x of A -> y; B -> y; C -> True), -} -type IdOccEnv = VarEnv LocalOcc -- A finite map from an expression's - -- free variables to their usage +type IdOccEnv = IdEnv LocalOcc -- A finite map from an expression's + -- free variables to their usage data LocalOcc -- See Note [LocalOcc] = OneOccL { lo_n_br :: {-# UNPACK #-} !BranchCount -- Number of syntactic occurrences @@ -3690,9 +3695,7 @@ localTailCallInfo (ManyOccL tci) = tci -- For TyVars and CoVars we gather only whether it occurs once or -- many times; we aren't interested in case-branches or tail-calls -data TyCoOccEnv = VarEnv TyCoOcc - -data TyCoOcc = OneOccTyCo | ManyOccTyCo +type TyCoOccEnv = TyCoVarEnv TyCoOccInfo type ZappedSet = IdOccEnv type ZappedTyCoSet = TyCoOccEnv @@ -3704,24 +3707,19 @@ data UsageDetails , ud_z_many :: !ZappedSet -- apply 'markMany' to these , ud_z_in_lam :: !ZappedSet -- apply 'markInsideLam' to these , ud_z_tail :: !ZappedSet -- zap tail-call info for these + , ud_tyco_env :: !TyCoOccEnv - , ud_z_tyzo :: !ZappedTyCoSet + , ud_z_tyco :: !ZappedTyCoSet -- These ones occur many times } -- INVARIANT: `ud_z_many`, `ud_z_in_lam` and `ud_z_tail` -o -- are all subsets of ud_id_env - -- `ud_z_tyco` is a subset of ud_tycon_env + -- are all subsets of ud_id_env + -- `ud_z_tyco` is a subset of ud_tyco_env instance Outputable UsageDetails where - ppr ud@(UD { ud_id_env = env, ud_tyco_env = tyco_env }) - = text "UD" <+> (braces $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr (lookupOccByUnique ud uq) - | uq <- nonDetStrictFoldVarEnv_Directly do_one [] id_env ] - ++ - [ ppr uq <+> text ":->" <+> ppr (lookupTyCoOccByUnique ud uq) - | uq <- nonDetStrictFoldVarEnv_Directly do_one [] tyco_env ]) - where - do_one :: Unique -> a -> [Unique] -> [Unique] - do_one uniq _ uniqs = uniq : uniqs + ppr (UD { ud_id_env = id_env, ud_tyco_env = tyco_env }) + = text "UD" <+> (braces $ vcat + [ text "ud_id_env =" <+> ppr id_env + , text "ud_tyco_env =" <+> ppr tyco_env ]) --------------------- -- | TailUsageDetails captures the result of applying 'occAnalLamTail' @@ -3743,18 +3741,13 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +plusTyCoOccEnv :: TyCoOccEnv -> TyCoOccEnv -> TyCoOccEnv +plusTyCoOccEnv env1 env2 = plusVarEnv_C plusTyCoOccInfo env1 env2 + +andUDs, orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc -mkOneTyVarOcc :: OccEnv -> TyVar -> UsageDetails -mkOneTyVarOcc !_env tv - = mkSimpleDetails (unitVarEnv tv occ) - where - occ = OneOccL { lo_n_br = 1, lo_int_cxt = NotInteresting - , lo_tail = NoTailCallInfo } - mkOneIdOcc :: OccEnv -> Var -> InterestingCxt -> JoinArity -> UsageDetails mkOneIdOcc !env id int_cxt arity | assert (not (isTyVar id)) $ @@ -3765,10 +3758,10 @@ mkOneIdOcc !env id int_cxt arity = -- See Note [Occurrence analysis for join points] assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $ -- We only put non-empty join-points into occ_join_points - mkSimpleDetails (extendVarEnv join_uds id occ) + mkIdUDs (extendVarEnv join_uds id occ) | otherwise - = mkSimpleDetails (unitVarEnv id occ) + = mkIdUDs (unitVarEnv id occ) where occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt @@ -3786,11 +3779,15 @@ add_many_occ v env = extendVarEnv env v (ManyOccL NoTailCallInfo) addManyOccs :: UsageDetails -> VarSet -> UsageDetails addManyOccs uds var_set | isEmptyVarSet var_set = uds - | otherwise = uds { ud_env = add_to (ud_env uds) } + | otherwise = uds { ud_id_env = add_to (ud_id_env uds) } where add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes +addTyCoOccs :: UsageDetails -> TyCoOccEnv -> UsageDetails +addTyCoOccs uds@(UD { ud_tyco_env = env}) extras + = uds { ud_tyco_env = env `plusTyCoOccEnv` extras } + addLamTyCoVarOccs :: UsageDetails -> [Var] -> UsageDetails -- occAnalLamBndrs :: OccEnv -> UsageDetails -> [Var] -> WithUsageDetails [Var] -- Add any TyCoVars free in the type of a lambda-binder @@ -3801,39 +3798,52 @@ addLamTyCoVarOccs uds bndrs add bndr uds = uds `addManyOccs` tyCoVarsOfType (varType bndr) emptyDetails :: UsageDetails -emptyDetails = mkSimpleDetails emptyVarEnv +emptyDetails = UD { ud_id_env = emptyVarEnv + , ud_z_many = emptyVarEnv + , ud_z_in_lam = emptyVarEnv + , ud_z_tail = emptyVarEnv + , ud_tyco_env = emptyVarEnv + , ud_z_tyco = emptyVarEnv } isEmptyDetails :: UsageDetails -> Bool -isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env +isEmptyDetails (UD { ud_id_env = id_env, ud_tyco_env = tyco_env }) + = isEmptyVarEnv id_env && isEmptyVarEnv tyco_env + +mkIdUDs :: IdOccEnv -> UsageDetails +mkIdUDs env = emptyDetails { ud_id_env = env } -mkSimpleDetails :: IdOccEnv -> UsageDetails -mkSimpleDetails env = UD { ud_env = env - , ud_z_many = emptyVarEnv - , ud_z_in_lam = emptyVarEnv - , ud_z_tail = emptyVarEnv } +mkTyCoUDs :: TyCoOccEnv -> UsageDetails +mkTyCoUDs env = emptyDetails { ud_tyco_env = env } modifyUDEnv :: (IdOccEnv -> IdOccEnv) -> UsageDetails -> UsageDetails -modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env } +modifyUDEnv f uds@(UD { ud_id_env = env }) = uds { ud_id_env = f env } delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails -- Delete these binders from the UsageDetails --- But /add/ the free vars of the types -delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many - , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail }) - = UD { ud_env = env `delVarEnvList` bndrs +-- But /add/ the free vars of the types. That may seem odd, but this is +-- a very convenient place to do it! +delBndrsFromUDs bndrs (UD { ud_id_env = env, ud_z_many = z_many + , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail + , ud_tyco_env = tyco_env, ud_z_tyco = z_tyco }) + = UD { ud_id_env = env `delVarEnvList` bndrs , ud_z_many = z_many `delVarEnvList` bndrs , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs - , ud_z_tail = z_tail `delVarEnvList` bndrs } + , ud_z_tail = z_tail `delVarEnvList` bndrs + , ud_tyco_env = adjust bndrs tyco_env + , ud_z_tyco = z_tyco `delVarEnvList` bndrs + } where - ty_fvs [] = emptyVarSet - ty_fvs (b:bs) = tyCoVarsOfType b `unionVarSet` - (ty_fvs bs `delVarSet` b) + adjust :: [Var] -> TyCoOccEnv -> TyCoOccEnv + -- Delete binders, but add the free vars of their types + adjust [] env = env + adjust (b:bs) env = occAnalTy (varType b) `plusTyCoOccEnv` + (adjust bs env `delVarEnv` b) markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail :: UsageDetails -> UsageDetails -markAllMany ud@(UD { ud_env = env }) = ud { ud_z_many = env } -markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env } -markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = env } +markAllMany ud@(UD { ud_id_env = env }) = ud { ud_z_many = env } +markAllInsideLam ud@(UD { ud_id_env = env }) = ud { ud_z_in_lam = env } +markAllNonTail ud@(UD { ud_id_env = env }) = ud { ud_z_tail = env } markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails @@ -3846,7 +3856,7 @@ markAllNonTailIf False ud = ud lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo lookupTailCallInfo uds id - | UD { ud_z_tail = z_tail, ud_env = env } <- uds + | UD { ud_z_tail = z_tail, ud_id_env = env } <- uds , not (id `elemVarEnv` z_tail) , Just occ <- lookupVarEnv env id = localTailCallInfo occ @@ -3855,9 +3865,10 @@ lookupTailCallInfo uds id udFreeVars :: VarSet -> UsageDetails -> VarSet -- Find the subset of bndrs that are mentioned in uds -udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env +udFreeVars bndrs (UD { ud_id_env = id_env, ud_tyco_env = tyco_env }) + = restrictFreeVars bndrs id_env `unionVarSet` restrictFreeVars bndrs tyco_env -restrictFreeVars :: VarSet -> IdOccEnv -> VarSet +restrictFreeVars :: VarSet -> VarEnv a -> VarSet restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs ------------------- @@ -3867,15 +3878,19 @@ combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc) -> UsageDetails -> UsageDetails -> UsageDetails {-# INLINE combineUsageDetailsWith #-} combineUsageDetailsWith plus_occ_info - uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 }) - uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 }) - | isEmptyVarEnv env1 = uds2 - | isEmptyVarEnv env2 = uds1 + uds1@(UD { ud_id_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 + , ud_tyco_env = tyco_env1, ud_z_tyco = z_tyco1 }) + uds2@(UD { ud_id_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 + , ud_tyco_env = tyco_env2, ud_z_tyco = z_tyco2 }) + | isEmptyDetails uds1 = uds2 + | isEmptyDetails uds2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 - , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + = UD { ud_id_env = plusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = plusVarEnv z_many1 z_many2 + , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 + , ud_z_tail = plusVarEnv z_tail1 z_tail2 + , ud_tyco_env = plusTyCoOccEnv tyco_env1 tyco_env2 + , ud_z_tyco = plusVarEnv z_tyco1 z_tyco2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) @@ -3884,21 +3899,24 @@ lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- we are about to re-generate it and it shouldn't be "sticky" lookupLetOccInfo ud id | isExportedId id = noOccInfo - | otherwise = lookupOccByUnique ud (idUnique id) + | otherwise = lookupIdOccByUnique ud (idUnique id) + +lookupIdOccInfo :: UsageDetails -> Id -> OccInfo +lookupIdOccInfo ud id = lookupIdOccByUnique ud (idUnique id) -lookupOccInfo :: UsageDetails -> Id -> OccInfo -lookupOccInfo ud id = lookupOccByUnique ud (idUnique id) +lookupTyCoOcc :: UsageDetails -> TyCoVar -> TyCoOccInfo +lookupTyCoOcc uds tcv = lookupTyCoOccByUnique uds (varUnique tcv) -lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOcc -lookupTyCoByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq +lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOccInfo +lookupTyCoOccByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq = case lookupVarEnv_Directly env uniq of - Nothing -> Nothing - Just ManyOccTyCo -> Just ManyOccTyCo - Just OneOccTyCo | uniq `elemVarEnvByKey` z_tyco = Just ManyOccTyCo - | otherwise = Just OneOccTyCo + Nothing -> TyCoDead + Just TyCoOne | uniq `elemVarEnvByKey` z_tyco -> TyCoMany + | otherwise -> TyCoOne + Just occ -> occ -lookupOccByUnique :: UsageDetails -> Unique -> OccInfo -lookupOccByUnique (UD { ud_env = env +lookupIdOccByUnique :: UsageDetails -> Unique -> OccInfo +lookupIdOccByUnique (UD { ud_id_env = env , ud_z_many = z_many , ud_z_in_lam = z_in_lam , ud_z_tail = z_tail }) @@ -3925,6 +3943,12 @@ lookupOccByUnique (UD { ud_env = env | otherwise = ti +tyCoOccToIdOcc :: TyCoOccInfo -> OccInfo +-- Used for CoVars +tyCoOccToIdOcc TyCoDead = IAmDead +tyCoOccToIdOcc TyCoOne = OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 + , occ_int_cxt = NotInteresting, occ_tail = NoTailCallInfo } +tyCoOccToIdOcc TyCoMany = noOccInfo ------------------- -- See Note [Adjusting right-hand sides] @@ -3958,34 +3982,42 @@ adjustTailArity mb_rhs_ja (TUD ja usage) type IdWithOccInfo = Id tagLamBinders :: UsageDetails -- Of scope - -> [Id] -- Binders + -> [CoreBndr] -- Binders -> [IdWithOccInfo] -- Tagged binders tagLamBinders usage binders = map (tagLamBinder usage) binders tagLamBinder :: UsageDetails -- Of scope - -> Id -- Binder + -> CoreBndr -- Binder -> IdWithOccInfo -- Tagged binders -- Used for lambda and case binders --- No-op on TyVars +-- No-op on TyVars; we could tag them but not much point -- A lambda binder never has an unfolding, so no need to look for that tagLamBinder usage bndr - = setBinderOcc (markNonTail occ) bndr + | isTyCoVar bndr + = bndr + | otherwise + = setIdBinderOcc (markNonTail occ) bndr -- markNonTail: don't try to make an argument into a join point where - occ = lookupOccInfo usage bndr + occ = lookupIdOccInfo usage bndr + +tagTyCoBinder :: TyCoOccInfo -> TyCoVar -> TyCoVar +tagTyCoBinder occ bndr + | isId bndr = setIdOccInfo bndr (tyCoOccToIdOcc occ) + | otherwise = setTyVarOccInfo bndr occ tagNonRecBinder :: TopLevelFlag -- At top level? -> OccInfo -- Of scope - -> CoreBndr -- Binder + -> Id -- Binder -> (IdWithOccInfo, JoinPointHood) -- Tagged binder -- Precondition: OccInfo is not IAmDead tagNonRecBinder lvl occ bndr | okForJoinPoint lvl bndr tail_call_info , AlwaysTailCalled ar <- tail_call_info - = (setBinderOcc occ bndr, JoinPoint ar) + = (setIdBinderOcc occ bndr, JoinPoint ar) | otherwise - = (setBinderOcc zapped_occ bndr, NotJoinPoint) + = (setIdBinderOcc zapped_occ bndr, NotJoinPoint) where tail_call_info = tailCallInfo occ zapped_occ = markNonTail occ @@ -4035,18 +4067,17 @@ tagRecBinders lvl body_uds details_s adj_uds = foldr andUDs body_uds rhs_udss' -- 4. Tag each binder with its adjusted details - bndrs' = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr + bndrs' = [ setIdBinderOcc (lookupLetOccInfo adj_uds bndr) bndr | bndr <- bndrs ] in WUD adj_uds bndrs' -setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr -setBinderOcc occ_info bndr - | isTyVar bndr = if (occ_info == tyVarOccInfo bndr) then bndr - else setTyVarOccInfo bndr occ_info - | otherwise = if (occ_info == idOccInfo bndr) then bndr - else setIdOccInfo bndr occ_info +setIdBinderOcc :: OccInfo -> CoreBndr -> CoreBndr +setIdBinderOcc occ_info bndr + = assertPpr (isNonCoVarId bndr) (ppr bndr) $ + if (occ_info == idOccInfo bndr) then bndr + else setIdOccInfo bndr occ_info -- | Decide whether some bindings should be made into join points or not, based -- on its occurrences. This is ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -441,8 +441,8 @@ type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] + | otherwise = glomValBinds binds' -- for this no_need_to_flatten stuff where ind_env = makeIndEnv binds -- These exported Ids are the subjects of the indirection-elimination ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -930,22 +930,19 @@ mkRecFloats :: SimplFloats -> SimplFloats -- If any are type bindings they must be non-recursive, so -- do not need to be joined into a letrec; indeed they must not -- since Rec{} is not allowed to have type binders -mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff +mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats val_bs ff , sfJoinFloats = join_bs , sfInScope = in_scope }) - = assertPpr (isNilOL bs || isNilOL join_bs) (ppr floats) $ - SimplFloats { sfLetFloats = LetFloats (type_bs `appOL` val_b) ff + = assertPpr (isNilOL val_bs || isNilOL join_bs) (ppr floats) $ + SimplFloats { sfLetFloats = LetFloats val_b ff , sfJoinFloats = join_b , sfInScope = in_scope } where - type_bs, val_bs :: OrdList OutBind - (type_bs, val_bs) = partitionOL isTypeBind bs - -- See Note [Bangs in the Simplifier] !val_b | isNilOL val_bs = nilOL - | otherwise = unitOL (Rec (flattenBinds (fromOL val_bs))) + | otherwise = toOL (glomValBinds (fromOL val_bs)) !join_b | isNilOL join_bs = nilOL - | otherwise = unitOL (Rec (flattenBinds (fromOL join_bs))) + | otherwise = toOL (glomValBinds (fromOL join_bs)) wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -204,6 +204,9 @@ simplTopBinds env0 binds0 -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". + -- + -- But the type of that top-level binder might mention a let-bound + -- type variable, so we put all those let-bindings at the front -- See Note [Bangs in the Simplifier] ; (ty_floats, env1) <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplTopTyVarBinds env0 binds0 @@ -291,10 +294,12 @@ simplTyVarBind :: SimplEnv -> InTyVar -> InType -- Returned SimplFloats is empty, or singleton type binding simplTyVarBind env tv ty | Just env' <- preInlineTypeUnconditionally env tv ty - = return (emptyFloats env', env') + = -- pprTrace "Pre-inline-tv" (ppr tv <+> equals <+> ppr ty) $ + return (emptyFloats env', env') | otherwise = do { ty' <- simplType env ty - ; completeTyVarBindX env (zapTyVarUnfolding tv) ty' } + ; -- pprTrace "Don't pre-inline-tv" (ppr tv <+> equals <+> ppr ty') $ + completeTyVarBindX env (zapTyVarUnfolding tv) ty' } -- Zap any unfolding because competeTyVarBindX will add -- the new unfolding and we don't wnat to waste work -- substituting the old one @@ -303,7 +308,8 @@ completeTyVarBindX :: SimplEnv -> InTyVar -> OutType -> SimplM (SimplFloats, SimplEnv) completeTyVarBindX env in_tv out_ty | postInlineTypeUnconditionally out_ty - = return (emptyFloats env, extendTvSubst env in_tv out_ty) + = -- pprTrace "Post-inline-tv" (ppr in_tv <+> equals <+> ppr out_ty) $ + return (emptyFloats env, extendTvSubst env in_tv out_ty) | otherwise = do { (env1, out_tv) <- simplTyVarBndr env in_tv @@ -314,7 +320,9 @@ completeTyVarBindX env in_tv out_ty -- occurrence of in_tv. After all, in a beta-redex, in_tv -- had no unfolding. See (TCL2) in -- Note [Type and coercion lets] in GHC.Core - ; return (mkFloatBind env2 (NonRec out_tv_w_unf (Type out_ty))) } + ; -- pprTrace "Don't post-inline-tv" (ppr in_tv <+> equals <+> ppr out_tv_w_unf + -- <+> equals <+> ppr out_ty) $ + return (mkFloatBind env2 (NonRec out_tv_w_unf (Type out_ty))) } {- ************************************************************************ ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1444,7 +1444,7 @@ preInlineTypeUnconditionally env tv rhs_ty -- Inline unconditionally if it occurs exactly once, inside a lambda or not. -- No work is wasted by substituting inside a lambda, although if the -- lambda is inlined a lot, we migth duplicate the type. - | OneOcc{ occ_n_br = 1 } <- tyVarOccInfo tv + | isOneTyCoOcc (tyVarOccInfo tv) = Just $! extendTvSubst env tv $! substTy env rhs_ty | otherwise ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -780,10 +780,10 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls }) local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals final_binds | null spec_binds = wrapDictBinds dict_binds [] - | otherwise = [Rec $ mapFst (addRulesToId local_rule_base) $ - flattenBinds $ - wrapDictBinds dict_binds $ - spec_binds] + | otherwise = glomValBinds $ + wrapDictBinds dict_binds $ + map (mapBindBndrs (addRulesToId local_rule_base)) $ + spec_binds ; return (rules_for_imps, final_binds) } ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -472,7 +472,12 @@ pprTypedLetBinder binder pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar - = text "@" <> pprTyVarWithKind tyvar + = text "@" <> pp_occ <> pprTyVarWithKind tyvar + where + pp_occ = case tyVarOccInfo tyvar of + TyCoDead -> text "[dead]" + TyCoOne -> text "[one]" + TyCoMany -> empty -- pprId x prints x :: ty pprId :: Id -> SDoc ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -153,8 +153,7 @@ simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr -- created from DynFlags, but not necessarily. simpleOptExpr opts expr - = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) - simpleOptExprWith opts init_subst expr + = simpleOptExprWith opts init_subst expr where init_subst = mkEmptySubst (mkInScopeSet (mapVarSet zapIdUnfolding (exprFreeVars expr))) -- zapIdUnfolding: see Note [The InScopeSet for simpleOptExpr] @@ -176,9 +175,10 @@ simpleOptExprNoInline opts expr simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser] simpleOptExprWith opts subst expr - = simple_opt_expr init_env (occurAnalyseExpr expr) + = simple_opt_expr init_env occ_expr where init_env = (emptyEnv opts) { soe_subst = subst } + occ_expr = occurAnalyseExpr expr ---------------------- simpleOptPgm :: SimpleOpts @@ -493,7 +493,7 @@ simple_type_bind env@(SOE { soe_subst = subst }) | occurs_once || typeIsSmallEnoughToInline out_ty = (env { soe_subst = extendTvSubst subst in_tv out_ty }, Nothing) - | otherwise + | otherwise -- Make a type binding = let (subst1, tv1) = substTyVarBndr subst in_tv out_tv = tv1 `setTyVarUnfolding` out_ty in ( env { soe_subst = extendTvSubst subst1 in_tv (mkTyVarTy out_tv) } @@ -504,7 +504,7 @@ simple_type_bind env@(SOE { soe_subst = subst }) subst_for_rhs = setInScope (soe_subst rhs_env) (substInScopeSet subst) out_ty = substTyUnchecked subst_for_rhs in_ty bndr_occ = tyVarOccInfo in_tv - occurs_once {- syntactically -} = isOneOcc bndr_occ && occ_n_br bndr_occ == 1 + occurs_once {- syntactically -} = isOneTyCoOcc bndr_occ ---------------------- simple_bind_pair :: SimpleOptEnv @@ -1621,7 +1621,7 @@ exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) - , not (isTyVar x) && not (isCoVar x) + , isNonCoVarId x , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co , let res = Just (x',e',ts) ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -73,6 +73,8 @@ module GHC.Types.Basic ( isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, isNoOccInfo, strongLoopBreaker, weakLoopBreaker, + TyCoOccInfo(..), plusTyCoOccInfo, isOneTyCoOcc, + InsideLam(..), BranchCount, oneBranch, InterestingCxt(..), @@ -1380,8 +1382,25 @@ point can also be invoked from other join points, not just from case branches: Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`. +-} -************************************************************************ +data TyCoOccInfo = TyCoDead | TyCoOne | TyCoMany + +instance Outputable TyCoOccInfo where + ppr TyCoDead = text "dead" + ppr TyCoOne = text "one" + ppr TyCoMany = text "many" + +isOneTyCoOcc :: TyCoOccInfo -> Bool +isOneTyCoOcc TyCoOne = True +isOneTyCoOcc _ = False + +plusTyCoOccInfo :: TyCoOccInfo -> TyCoOccInfo -> TyCoOccInfo +plusTyCoOccInfo TyCoDead occ = occ +plusTyCoOccInfo occ TyCoDead = occ +plusTyCoOccInfo _ _ = TyCoMany + +{-********************************************************************** * * Default method specification * * @@ -2461,4 +2480,4 @@ convImportLevel NotLevelled = NormalLevel convImportLevelSpec :: ImportDeclLevel -> ImportLevel convImportLevelSpec ImportDeclQuote = QuoteLevel -convImportLevelSpec ImportDeclSplice = SpliceLevel \ No newline at end of file +convImportLevelSpec ImportDeclSplice = SpliceLevel ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -128,7 +128,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , nonDetCmpUnique ) -import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo ) +import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo, TyCoOccInfo(..) ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable @@ -269,7 +269,7 @@ data Var varType :: Kind, -- ^ The type or kind of the 'Var' in question tv_unfolding :: Maybe Type, -- ^ The type to which the variable is bound to, -- if any, see Note [Type and coercion lets] in GHC.Core - tv_occ_info :: OccInfo + tv_occ_info :: TyCoOccInfo } | TcTyVar { -- Used only during type inference @@ -1032,8 +1032,8 @@ tyVarUnfolding_maybe :: TyVar -> Maybe Type tyVarUnfolding_maybe (TyVar { tv_unfolding = unf }) = unf tyVarUnfolding_maybe _ = Nothing -tyVarOccInfo :: TyVar -> OccInfo -tyVarOccInfo (TcTyVar {}) = noOccInfo +tyVarOccInfo :: TyVar -> TyCoOccInfo +tyVarOccInfo (TcTyVar {}) = TyCoMany tyVarOccInfo tv = assertPpr (isTyVar tv) (ppr tv) $ tv_occ_info tv setTyVarUnique :: TyVar -> Unique -> TyVar @@ -1059,7 +1059,7 @@ zapTyVarUnfolding tv@(TcTyVar {}) = tv -- Why: because zapTyVarUnfolding is called by substTyBndr during typechecking zapTyVarUnfolding v = pprPanic "zapTyVarUnfolding" (ppr v) -setTyVarOccInfo :: HasDebugCallStack => TyVar -> OccInfo -> TyVar +setTyVarOccInfo :: HasDebugCallStack => TyVar -> TyCoOccInfo -> TyVar setTyVarOccInfo tv@(TyVar {}) occ_info = tv {tv_occ_info = occ_info} setTyVarOccInfo tv occ_info @@ -1101,7 +1101,7 @@ mkTyVar name kind = TyVar { varName = name , realUnique = nameUnique name , varType = kind , tv_unfolding = Nothing - , tv_occ_info = noOccInfo + , tv_occ_info = TyCoMany } mkTyVarWithUnfolding :: Name -> Kind -> Type -> TyVar @@ -1109,7 +1109,7 @@ mkTyVarWithUnfolding name kind unf = TyVar { varName = name , realUnique = nameUnique name , varType = kind , tv_unfolding = Just unf - , tv_occ_info = noOccInfo + , tv_occ_info = TyCoMany } mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e69b3f51045360e53260aec1734f23f3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e69b3f51045360e53260aec1734f23f3... You're receiving this email because of your account on gitlab.haskell.org.