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
3 changed files:
Changes:
| ... | ... | @@ -2228,8 +2228,7 @@ occ_anal_lam_tail env expr@(Lam {}) |
| 2228 | 2228 | = addInScope env (reverse rev_bndrs) $ \env ->
|
| 2229 | 2229 | let !(WUD usage body') = occ_anal_lam_tail env body
|
| 2230 | 2230 | wrap_lam body bndr = Lam (tagLamBinder usage bndr) body
|
| 2231 | - in WUD (usage `addLamTyCoVarOccs` rev_bndrs)
|
|
| 2232 | - (foldl' wrap_lam body' rev_bndrs)
|
|
| 2231 | + in WUD usage (foldl' wrap_lam body' rev_bndrs)
|
|
| 2233 | 2232 | |
| 2234 | 2233 | -- For casts, keep going in the same lambda-group
|
| 2235 | 2234 | -- See Note [Occurrence analysis for lambda binders]
|
| ... | ... | @@ -3136,12 +3135,15 @@ addInScopeOne env bndr = addInScope env [bndr] |
| 3136 | 3135 | addInScope :: OccEnv -> [Var]
|
| 3137 | 3136 | -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
|
| 3138 | 3137 | {-# INLINE addInScope #-}
|
| 3138 | +-- Do occ-analysis under a telescope of binders
|
|
| 3139 | +-- `addInScope` accounts for
|
|
| 3140 | +-- -- Accounting for the free vars of the types of the binders
|
|
| 3141 | +-- - Dealing with the interaction between shadowing and
|
|
| 3142 | +-- the `bad_join` and binder-swap mechanisms
|
|
| 3139 | 3143 | -- This function is called a lot, so we want to inline the fast path
|
| 3140 | --- so we don't have to allocate thing_inside and call it
|
|
| 3144 | +-- so we don't have to allocate thing_inside and call it
|
|
| 3141 | 3145 | -- The bndrs must include TyVars as well as Ids, because of
|
| 3142 | 3146 | -- (BS3) in Note [Binder swap]
|
| 3143 | --- We do not assume that the bndrs are in scope order; in fact the
|
|
| 3144 | --- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order
|
|
| 3145 | 3147 | |
| 3146 | 3148 | addInScope env bndrs thing_inside
|
| 3147 | 3149 | | null bndrs -- E.g. nullary constructors in a `case`
|
| ... | ... | @@ -3789,15 +3791,6 @@ addTyCoOccs :: UsageDetails -> TyCoOccEnv -> UsageDetails |
| 3789 | 3791 | addTyCoOccs uds@(UD { ud_tyco_env = env}) extras
|
| 3790 | 3792 | = uds { ud_tyco_env = env `plusTyCoOccEnv` extras }
|
| 3791 | 3793 | |
| 3792 | -addLamTyCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
|
|
| 3793 | --- occAnalLamBndrs :: OccEnv -> UsageDetails -> [Var] -> WithUsageDetails [Var]
|
|
| 3794 | --- Add any TyCoVars free in the type of a lambda-binder
|
|
| 3795 | --- See Note [Gather occurrences of coercion variables]
|
|
| 3796 | -addLamTyCoVarOccs uds bndrs
|
|
| 3797 | - = foldr add uds bndrs
|
|
| 3798 | - where
|
|
| 3799 | - add bndr uds = uds `addManyOccs` tyCoVarsOfType (varType bndr)
|
|
| 3800 | - |
|
| 3801 | 3794 | emptyDetails :: UsageDetails
|
| 3802 | 3795 | emptyDetails = UD { ud_id_env = emptyVarEnv
|
| 3803 | 3796 | , ud_z_many = emptyVarEnv
|
| ... | ... | @@ -2679,8 +2679,8 @@ argToPat1 :: ScEnv |
| 2679 | 2679 | -> ArgOcc
|
| 2680 | 2680 | -> StrictnessMark
|
| 2681 | 2681 | -> UniqSM (Bool, Expr CoreBndr, [Id])
|
| 2682 | -argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str
|
|
| 2683 | - = return (False, arg, [])
|
|
| 2682 | +argToPat1 _env in_scope _val_env (Type ty) _arg_occ _arg_str
|
|
| 2683 | + = return (False, Type (mkTyPat in_scope ty), [])
|
|
| 2684 | 2684 | |
| 2685 | 2685 | argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str
|
| 2686 | 2686 | = argToPat env in_scope val_env arg arg_occ arg_str
|
| ... | ... | @@ -2819,8 +2819,19 @@ argToPat in_scope val_env arg arg_occ |
| 2819 | 2819 | |
| 2820 | 2820 | -- The default case: make a wild-card
|
| 2821 | 2821 | -- We use this for coercions too
|
| 2822 | -argToPat1 _env _in_scope _val_env arg _arg_occ arg_str
|
|
| 2823 | - = wildCardPat (exprType arg) arg_str
|
|
| 2822 | +argToPat1 _env in_scope _val_env arg _arg_occ arg_str
|
|
| 2823 | + = wildCardPat (mkTyPat in_scope (exprType arg)) arg_str
|
|
| 2824 | + |
|
| 2825 | +mkTyPat :: InScopeSet -> Type -> Type
|
|
| 2826 | +-- Expand unfoldings of any tyvars not in the in-scope set
|
|
| 2827 | +-- E.g. call f @a @b{=a} (K @a)
|
|
| 2828 | +-- The tyvars `a` and `b` might have been in scope at the call site,
|
|
| 2829 | +-- but not at the definition site. We want a call pattern
|
|
| 2830 | +-- f @a @a (K @a) a
|
|
| 2831 | +mkTyPat in_scope ty
|
|
| 2832 | + = expandSomeTyVarUnfoldings not_in_scope ty
|
|
| 2833 | + where
|
|
| 2834 | + not_in_scope tv = not (tv `elemInScopeSet` in_scope)
|
|
| 2824 | 2835 | |
| 2825 | 2836 | -- | wildCardPats are always boring
|
| 2826 | 2837 | wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])
|
| ... | ... | @@ -171,7 +171,8 @@ module GHC.Core.Type ( |
| 171 | 171 | anyFreeVarsOfType, anyFreeVarsOfTypes,
|
| 172 | 172 | noFreeVarsOfType,
|
| 173 | 173 | expandTypeSynonyms, expandSynTyConApp_maybe,
|
| 174 | - typeSize, occCheckExpand, expandTyVarUnfoldings,
|
|
| 174 | + typeSize, occCheckExpand,
|
|
| 175 | + expandTyVarUnfoldings, expandSomeTyVarUnfoldings,
|
|
| 175 | 176 | |
| 176 | 177 | -- ** Closing over kinds
|
| 177 | 178 | closeOverKindsDSet, closeOverKindsList,
|
| ... | ... | @@ -491,7 +492,7 @@ on its fast path must also be inlined, linked back to this Note. |
| 491 | 492 | * *
|
| 492 | 493 | ********************************************************************* -}
|
| 493 | 494 | |
| 494 | -expandTyVarUnfoldings :: TyVarSet -> Type -> Type
|
|
| 495 | +expandTyVarUnfoldings :: TyVarSet -> Type -> Type
|
|
| 495 | 496 | -- (expandTyVarUnfoldings tvs ty) replace any occurrences of `tvs` in `ty`
|
| 496 | 497 | -- with their unfoldings. The returned type does not mention any of `tvs`.
|
| 497 | 498 | --
|
| ... | ... | @@ -500,7 +501,11 @@ expandTyVarUnfoldings :: TyVarSet -> Type -> Type |
| 500 | 501 | -- also in scope, without having been shadowed.
|
| 501 | 502 | expandTyVarUnfoldings tvs ty
|
| 502 | 503 | | isEmptyVarSet tvs = ty
|
| 503 | - | otherwise = runIdentity (expand ty)
|
|
| 504 | + | otherwise = expandSomeTyVarUnfoldings (`elemVarSet` tvs) ty
|
|
| 505 | + |
|
| 506 | +expandSomeTyVarUnfoldings :: (TyVar -> Bool) -> Type -> Type
|
|
| 507 | +expandSomeTyVarUnfoldings expand_me ty
|
|
| 508 | + = runIdentity (expand ty)
|
|
| 504 | 509 | where
|
| 505 | 510 | expand :: Type -> Identity Type
|
| 506 | 511 | (expand, _, _, _)
|
| ... | ... | @@ -508,8 +513,8 @@ expandTyVarUnfoldings tvs ty |
| 508 | 513 | , tcm_hole = exp_hole, tcm_tycobinder = exp_tcb
|
| 509 | 514 | , tcm_tycon = pure })
|
| 510 | 515 | exp_tv _ tv = case tyVarUnfolding_maybe tv of
|
| 511 | - Just ty | tv `elemVarSet` tvs -> expand ty
|
|
| 512 | - _ -> pure (TyVarTy tv)
|
|
| 516 | + Just ty | expand_me tv -> expand ty
|
|
| 517 | + _ -> pure (TyVarTy tv)
|
|
| 513 | 518 | exp_cv _ cv = pure (CoVarCo cv)
|
| 514 | 519 | exp_hole _ cv = pprPanic "expand_tv_unf" (ppr cv)
|
| 515 | 520 | exp_tcb :: () -> TyCoVar -> ForAllTyFlag -> (() -> TyCoVar -> Identity r) -> Identity r
|