Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: 7fe3be18 by Simon Peyton Jones at 2025-07-14T17:21:38+01:00 More small fixes - - - - - 3 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2228,8 +2228,7 @@ occ_anal_lam_tail env expr@(Lam {}) = addInScope env (reverse rev_bndrs) $ \env -> let !(WUD usage body') = occ_anal_lam_tail env body wrap_lam body bndr = Lam (tagLamBinder usage bndr) body - in WUD (usage `addLamTyCoVarOccs` rev_bndrs) - (foldl' wrap_lam body' rev_bndrs) + in WUD usage (foldl' wrap_lam body' rev_bndrs) -- For casts, keep going in the same lambda-group -- See Note [Occurrence analysis for lambda binders] @@ -3136,12 +3135,15 @@ addInScopeOne env bndr = addInScope env [bndr] addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a {-# INLINE addInScope #-} +-- Do occ-analysis under a telescope of binders +-- `addInScope` accounts for +-- -- Accounting for the free vars of the types of the binders +-- - Dealing with the interaction between shadowing and +-- the `bad_join` and binder-swap mechanisms -- This function is called a lot, so we want to inline the fast path --- so we don't have to allocate thing_inside and call it +-- so we don't have to allocate thing_inside and call it -- The bndrs must include TyVars as well as Ids, because of -- (BS3) in Note [Binder swap] --- 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 addInScope env bndrs thing_inside | null bndrs -- E.g. nullary constructors in a `case` @@ -3789,15 +3791,6 @@ 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 --- See Note [Gather occurrences of coercion variables] -addLamTyCoVarOccs uds bndrs - = foldr add uds bndrs - where - add bndr uds = uds `addManyOccs` tyCoVarsOfType (varType bndr) - emptyDetails :: UsageDetails emptyDetails = UD { ud_id_env = emptyVarEnv , ud_z_many = emptyVarEnv ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -2679,8 +2679,8 @@ argToPat1 :: ScEnv -> ArgOcc -> StrictnessMark -> UniqSM (Bool, Expr CoreBndr, [Id]) -argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str - = return (False, arg, []) +argToPat1 _env in_scope _val_env (Type ty) _arg_occ _arg_str + = return (False, Type (mkTyPat in_scope ty), []) argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str = argToPat env in_scope val_env arg arg_occ arg_str @@ -2819,8 +2819,19 @@ argToPat in_scope val_env arg arg_occ -- The default case: make a wild-card -- We use this for coercions too -argToPat1 _env _in_scope _val_env arg _arg_occ arg_str - = wildCardPat (exprType arg) arg_str +argToPat1 _env in_scope _val_env arg _arg_occ arg_str + = wildCardPat (mkTyPat in_scope (exprType arg)) arg_str + +mkTyPat :: InScopeSet -> Type -> Type +-- Expand unfoldings of any tyvars not in the in-scope set +-- E.g. call f @a @b{=a} (K @a) +-- The tyvars `a` and `b` might have been in scope at the call site, +-- but not at the definition site. We want a call pattern +-- f @a @a (K @a) a +mkTyPat in_scope ty + = expandSomeTyVarUnfoldings not_in_scope ty + where + not_in_scope tv = not (tv `elemInScopeSet` in_scope) -- | wildCardPats are always boring wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -171,7 +171,8 @@ module GHC.Core.Type ( anyFreeVarsOfType, anyFreeVarsOfTypes, noFreeVarsOfType, expandTypeSynonyms, expandSynTyConApp_maybe, - typeSize, occCheckExpand, expandTyVarUnfoldings, + typeSize, occCheckExpand, + expandTyVarUnfoldings, expandSomeTyVarUnfoldings, -- ** Closing over kinds closeOverKindsDSet, closeOverKindsList, @@ -491,7 +492,7 @@ on its fast path must also be inlined, linked back to this Note. * * ********************************************************************* -} -expandTyVarUnfoldings :: TyVarSet -> Type -> Type +expandTyVarUnfoldings :: TyVarSet -> Type -> Type -- (expandTyVarUnfoldings tvs ty) replace any occurrences of `tvs` in `ty` -- with their unfoldings. The returned type does not mention any of `tvs`. -- @@ -500,7 +501,11 @@ expandTyVarUnfoldings :: TyVarSet -> Type -> Type -- also in scope, without having been shadowed. expandTyVarUnfoldings tvs ty | isEmptyVarSet tvs = ty - | otherwise = runIdentity (expand ty) + | otherwise = expandSomeTyVarUnfoldings (`elemVarSet` tvs) ty + +expandSomeTyVarUnfoldings :: (TyVar -> Bool) -> Type -> Type +expandSomeTyVarUnfoldings expand_me ty + = runIdentity (expand ty) where expand :: Type -> Identity Type (expand, _, _, _) @@ -508,8 +513,8 @@ expandTyVarUnfoldings tvs ty , tcm_hole = exp_hole, tcm_tycobinder = exp_tcb , tcm_tycon = pure }) exp_tv _ tv = case tyVarUnfolding_maybe tv of - Just ty | tv `elemVarSet` tvs -> expand ty - _ -> pure (TyVarTy tv) + Just ty | expand_me tv -> expand ty + _ -> pure (TyVarTy tv) exp_cv _ cv = pure (CoVarCo cv) exp_hole _ cv = pprPanic "expand_tv_unf" (ppr cv) exp_tcb :: () -> TyCoVar -> ForAllTyFlag -> (() -> TyCoVar -> Identity r) -> Identity r View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe3be18a1bdab4b78b5264baea3dcde... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe3be18a1bdab4b78b5264baea3dcde... You're receiving this email because of your account on gitlab.haskell.org.