Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 033ba59c by sheaf at 2026-10-15T04:55:44-04:00 Make exprFreeVars deep exprFreeVars used to be a shallow free-variable finder (it didn't look into kinds), but most callers wanted it to be deep. In particular, 'exprFreeVars' is often used to seed an 'InScopeSet', and that must contain the /deep/ free variables. This commit makes it deep, which allows us to get rid of calls to 'closeOverKinds' or other workarounds for shallowness in: - 'GHC.Core.Opt.Simplify.Utils.abstractFloats' - 'GHC.HsToCore.Binds.dsSpec_help' - 'GHC.Core.Opt.Arity.etaBodyForJoinPoint' - 'GHC.Core.FVs.freeVars' - 'GHC.Core.Lint.lintCoreRule' We also remove 'deepExprsFreeVarsDSet' and 'closeOverKindsDSet'. Other places needed a little bit more care, in particular to properly handle coercion variables free in kinds: - 'GHC.Core.Opt.Specialise.specHeader' quantifies over the binder of an unspecialised argument directly, instead of computing the free Ids of the argument. - 'GHC.HsToCore.dsWarnRuleShadowing' filters out 'CoVar's. - 'GHC.Core.Opt.SpecConstr.callToPat' had some ad-hoc logic to compute argument pattern types and a workaround with 'expandTypeSynonyms'. That logic is removed in favour of a new 'argsToPats' function which directly computes the argument pattern types by instantiating the type of the head of the call pattern. Fixes #27936 - - - - - 16 changed files: - + changelog.d/27936 - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/Type.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Var/FV.hs - + testsuite/tests/simplCore/should_compile/T27936.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/27936 ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: + Ensure in-scope set computations always look into kinds, avoiding + "needInScope" assertion failures in various places in the compiler. +mrs: !16799 +issues: #27936 ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -11,18 +11,17 @@ Taken quite directly from the Peyton Jones/Lester paper. module GHC.Core.FVs ( -- * Free variables of expressions and binding groups exprFreeVars, exprsFreeVars, - exprFreeVarsDSet, + exprFreeVarsDSet, exprsFreeVarsDSet, exprFreeVarsList, exprsFreeVarsList, exprFreeIds, exprsFreeIds, exprFreeIdsDSet, exprsFreeIdsDSet, exprFreeIdsList, exprsFreeIdsList, bindFreeVars, - -- * Selective shallow free variables of expressions + -- * Selective free variables of expressions InterestingVarFun, exprSomeFreeVars, exprsSomeFreeVars, exprSomeFreeVarsList, exprsSomeFreeVarsList, exprsSomeFreeVarsDSet, - deepExprsFreeVarsDSet, -- * Free variables of Rules, Vars and Ids bndrTypeTyCoFVs, bndrFVs, dBndrFreeVars, @@ -73,95 +72,118 @@ import GHC.Builtin.WiredIn.Types( unrestrictedFunTyConName ) import GHC.Builtin.WiredIn.Prim( fUNTyCon ) import GHC.Data.Maybe( orElse ) -import GHC.Utils.EndoOS import GHC.Utils.Misc import GHC.Utils.Panic.Plain {- ************************************************************************ * * - Find the shallow free variables of term + Free variables of terms * * ************************************************************************ Note [Free variables of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This function simply finds the shallow free variables of an expression. -So far as type variables are concerned, it only finds tyvars that are - * free in type arguments, - * free in the type of a binder, -but not those that are free in the type of variable occurrences. - -(FVE1) For /types/ we have a shallow free-var finder and a deep free-var finder, - both implemented via TyCoFolder. For /terms/ we have just one free-var - finder (shallow). - - If we want the deep free vars (as in `deepExprsFreeVarsDSet`) we use - `closeOverKinds`. There is no deep reason for this. Maybe we should - make a folder for terms as well. --} +'exprFreeVars' computes the /deep/ free variables of an expression, in the +sense of Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs: + +(FVE1) An occurrence of a variable `v` contributes `v` together with the deep + free variables of v's type (and, for an Id, of its multiplicity). +The selective variants, e.g. 'exprSomeFreeVars', are also deep. +They only collect interesting free variables, and entirely skip looking into +the kind of non-interesting free variables. + +The type of a variable is traversed only when the variable is first collected, +so each free variable's type is visited at most once per call; see +Note [Computing deep free variables] in GHC.Core.TyCo.FVs. +-} -- | Find all locally-defined free Ids or type variables in an expression -- returning a non-deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprFreeVars :: CoreExpr -> VarSet exprFreeVars = dVarSetToVarSet . exprFreeVarsDSet -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprFreeVarsDSet :: CoreExpr -> DVarSet exprFreeVarsDSet = runFVSelective isLocalVar . exprFVs --- | Find all locally-defined free Ids or type variables in several expressions +-- | Find all locally-defined free Ids or type variables in several expressions, -- returning a non-deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = dVarSetToVarSet . exprsFreeVarsDSet --- | Find all locally-defined free Ids or type variables in several expressions +-- | Find all locally-defined free Ids or type variables in several expressions, -- returning a deterministically ordered list. +-- +-- The result is deep; see Note [Free variables of an expression]. exprsFreeVarsList :: [CoreExpr] -> [Var] exprsFreeVarsList = runFVSelectiveList isLocalVar . exprsFVs +-- | Find all locally-defined free Ids or type variables in several expressions, +-- returning a deterministic set. +-- +-- The result is deep; see Note [Free variables of an expression]. exprsFreeVarsDSet :: [CoreExpr] -> DVarSet exprsFreeVarsDSet = runFVSelective isLocalVar . exprsFVs -deepExprsFreeVarsDSet :: [CoreExpr] -> DVarSet --- See (FVE1) in Note [Free variables of an expression] -deepExprsFreeVarsDSet = closeOverKindsDSet . exprsFreeVarsDSet - -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministically ordered list. +-- +-- The result is deep; see Note [Free variables of an expression]. exprFreeVarsList :: CoreExpr -> [Var] exprFreeVarsList = dVarSetElems . exprFreeVarsDSet --- | Find all locally-defined free Ids in an expression -exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +-- | Find all locally-defined free Ids in an expression. +-- +-- The result is deep; see Note [Free variables of an expression]. +exprFreeIds :: CoreExpr -> IdSet exprFreeIds = dVarSetToVarSet . exprFreeIdsDSet -exprsFreeIds :: [CoreExpr] -> IdSet -- Find all locally-defined free Ids +-- | Find all locally-defined free Ids in several expressions. +-- +-- The result is deep; see Note [Free variables of an expression]. +exprsFreeIds :: [CoreExpr] -> IdSet exprsFreeIds = dVarSetToVarSet . exprsFreeIdsDSet -- | Find all locally-defined free Ids in an expression -- returning a deterministic set. -exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprFreeIdsDSet :: CoreExpr -> DIdSet exprFreeIdsDSet = runFVSelective isLocalId . exprFVs -- | Find all locally-defined free Ids in several expressions -- returning a deterministic set. -exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprsFreeIdsDSet :: [CoreExpr] -> DIdSet exprsFreeIdsDSet = runFVSelective isLocalId . exprsFVs -- | Find all locally-defined free Ids in an expression -- returning a deterministically ordered list. -exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprFreeIdsList :: CoreExpr -> [Id] exprFreeIdsList = dVarSetElems . exprFreeIdsDSet -- | Find all locally-defined free Ids in several expressions -- returning a deterministically ordered list. -exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids +-- +-- The result is deep; see Note [Free variables of an expression]. +exprsFreeIdsList :: [CoreExpr] -> [Id] exprsFreeIdsList = dVarSetElems . exprsFreeIdsDSet --- | Find all locally defined free Ids in a binding group +-- | Find all locally-defined free Ids or type variables in a binding group. +-- +-- The result is deep; see Note [Free variables of an expression]. bindFreeVars :: CoreBind -> VarSet bindFreeVars = runFVSelectiveSet isLocalVar . bind_fvs @@ -171,6 +193,8 @@ bind_fvs (Rec prs) = addBndrsSelectiveFV (map fst prs) $ mapUnionFV rhs_fvs prs -- | Finds free variables in an expression selected by a predicate +-- +-- See Note [Free variables of an expression]. exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> VarSet @@ -221,30 +245,25 @@ addCoreBndrsFV :: [CoreBndr] -> SelectiveDFV -> SelectiveDFV addCoreBndrsFV bndrs fv = foldr addCoreBndrFV fv bndrs unitFV :: Var -> SelectiveDFV --- Deals with an occurrence --- Shallow: does not look at the kind -unitFV v = MkFV (\env -> EndoOS (do_it env)) - where - do_it (bvs, is_interesting) acc - | v `elemVarSet` bvs = acc -- First exclude the bound vars - | not (is_interesting v) = acc -- The "selective" bit - | v `elemDVarSet` acc = acc - | otherwise = acc `extendDVarSet` v +-- Deals with an occurrence: the variable and, if it is newly collected, +-- the free variables of its type and multiplicity. +-- See (FVE1) in Note [Free variables of an expression] +unitFV = deepSelUnitFV bndrTypeTyCoFVs exprsFVs :: [CoreExpr] -> SelectiveDFV exprsFVs = mapUnionFV exprFVs exprFVs :: CoreExpr -> SelectiveDFV -exprFVs (Type ty) = shallowSelTypeFV ty -exprFVs (Coercion co) = shallowSelCoFV co +exprFVs (Type ty) = deepSelTypeFV ty +exprFVs (Coercion co) = deepSelCoFV co exprFVs (Var var) = unitFV var exprFVs (Lit _) = mempty exprFVs (Tick t expr) = tickish_fvs t `mappend` exprFVs expr exprFVs (App fun arg) = exprFVs fun `mappend` exprFVs arg exprFVs (Lam bndr body) = addCoreBndrFV bndr (exprFVs body) -exprFVs (Cast expr co) = exprFVs expr `mappend` shallowSelCoFV co +exprFVs (Cast expr co) = exprFVs expr `mappend` deepSelCoFV co exprFVs (Case scrut bndr ty alts) - = exprFVs scrut `mappend` shallowSelTypeFV ty `mappend` + = exprFVs scrut `mappend` deepSelTypeFV ty `mappend` addCoreBndrFV bndr (mapUnionFV alt_fvs alts) where alt_fvs (Alt _ bndrs rhs) = addCoreBndrsFV bndrs (exprFVs rhs) @@ -267,13 +286,13 @@ tickish_fvs _ = mempty --------- bndrTypeTyCoFVs :: Var -> SelectiveDFV --- Find the free variables of a binder. +-- Find the (deep) free variables of the type of a variable. -- In the case of ids, don't forget the multiplicity field! bndrTypeTyCoFVs var - = shallowSelTypeFV (varType var) `mappend` mult_fvs + = deepSelTypeFV (varType var) `mappend` mult_fvs where mult_fvs = case varMultMaybe var of - Just mult -> shallowSelTypeFV mult + Just mult -> deepSelTypeFV mult Nothing -> mempty dBndrTypeTyCoVars :: Var -> DTyCoVarSet @@ -286,11 +305,10 @@ bndrFreeVars id = assert (isId id) $ dBndrFreeVars id dBndrFreeVars :: Id -> DVarSet --- Shallow free vars dBndrFreeVars id = runFVSelective isLocalVar $ bndrFVs id bndrFVs :: Id -> SelectiveDFV --- Shallow free vars of types, rules, and inlining +-- Free vars of types, rules, and inlining bndrFVs id = assert (isId id) $ bndrTypeTyCoFVs id `mappend` bndrRuleAndUnfoldingFVs id @@ -593,7 +611,8 @@ Note [The FVAnn invariant] Invariant: a FVAnn, say S, is closed: That is: if v is in S, then freevars( v's type/kind ) is also in S -So FVAnn computes /deep/ free variables +So FVAnn computes /deep/ free variables, just like `exprFreeVars` does; +see Note [Free variables of an expression]. -} type FVAnn = DVarSet -- See Note [The FVAnn invariant] @@ -690,22 +709,15 @@ freeVars = go where go :: CoreExpr -> CoreExprWithFVs go (Var v) - | isLocalVar v = (aFreeVar v `unionDVarSet` ty_fvs `unionDVarSet` mult_vars, AnnVar v) - | otherwise = (emptyDVarSet, AnnVar v) - where - mult_vars = tyCoVarsOfTypeDSet (idMult v) - ty_fvs = dBndrTypeTyCoVars v - -- See Note [The FVAnn invariant] + | isLocalVar v = (aFreeVar v `unionDVarSet` dBndrTypeTyCoVars v, AnnVar v) + -- See Note [The FVAnn invariant] + | otherwise = (emptyDVarSet, AnnVar v) go (Lit lit) = (emptyDVarSet, AnnLit lit) go (Lam b body) - = ( b_fvs `unionDVarSet` (b `delBinderFV` body_fvs) - , AnnLam b body' ) + = ( b `delBinderFV` body_fvs, AnnLam b body' ) where body'@(body_fvs, _) = go body - b_ty = idType b - b_fvs = tyCoVarsOfTypeDSet b_ty - -- See Note [The FVAnn invariant] go (App fun arg) = ( freeVarsOf fun' `unionDVarSet` freeVarsOf arg' @@ -750,8 +762,7 @@ freeVars = go , AnnTick tickish expr2 ) where expr2 = go expr - tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + tickishFVs = runFVSelective isLocalVar . tickish_fvs go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -2216,7 +2216,8 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs where rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon - lhs_fvs = deepExprsFreeVarsDSet args -- Matching binds deeply + lhs_fvs = exprsFreeVarsDSet args -- Rule matching binds deeply, so compare + -- against the deep free vars rhs_fvs = exprFreeVarsDSet rhs is_bad_bndr :: Var -> Bool ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -3230,15 +3230,12 @@ etaBodyForJoinPoint need_args body ppr body $$ ppr (exprType body) body_ty = exprType body - in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty) - -- in_scope is a bit tricky. - -- - We are wrapping `body` in some value lambdas, so must not shadow - -- any free vars of `body` - -- - We are wrapping `body` in some type lambdas, so must not shadow any - -- tyvars in body_ty. Example: body is just a variable - -- (g :: forall (a::k). T k a -> Int) - -- We must not shadown that `k` when adding the /\a. So treat the free vars - -- of body_ty as in-scope. Showed up in #23026. + in_scope = mkInScopeSet (exprFreeVars body) + -- We are wrapping `body` in lambdas, so the in-scope set must contain the + -- /deep/ free vars of `body` (exprFreeVars returns deep free vars). + -- Why? See Note [No type-shadowing in Core]: if body is just a variable + -- (g :: forall (a::k). T k a -> Int) + -- we must not shadow that `k` when adding the /\a (#23026). -------------- freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -2360,13 +2360,14 @@ new binding is abstracted. Several points worth noting poly_t = /\ a b -> (e1, e2) poly_x = /\ a -> fst (poly_t a *b*) -(AB2) We must do closeOverKinds. Example (#10934): +(AB2) We must abstract over kind variables too. Example (#10934): f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... Here we want to float 't', but we must remember to abstract over 'k' as well, even though it is not explicitly mentioned in the RHS, otherwise we get t = /\ (f:k->*) (a:k). AccFailure @ (f a) - which is obviously bogus. + which is obviously bogus. `exprSomeFreeVars isTyVar` is deep, + so the kind variables are picked up with the rest. (AB3) We get the variables to abstract over by filtering down the the main_tvs for the original function, picking only ones @@ -2449,7 +2450,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body rhs' = GHC.Core.Subst.substExpr subst rhs -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') + tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') -- (AB2) abstract subst (CyclicSCC trpls) = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids @@ -2478,14 +2479,12 @@ abstractFloats uf_opts top_lvl main_tvs floats body -- because it has a non-CoVar precondition | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var = -- 'var' is like 'x' in (AB4) - exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs + exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs -- (AB2) | otherwise = free_tvs choose_tvs free_tvs - = filter (`elemVarSet` all_free_tvs) main_tvs -- (AB3) - where - all_free_tvs = closeOverKinds free_tvs -- (AB2) + = filter (`elemVarSet` free_tvs) main_tvs -- (AB3) mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) mk_poly1 tvs_here var ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -60,6 +60,7 @@ import GHC.Types.Unique( hasKey ) import GHC.Data.Maybe ( fromMaybe, orElse, catMaybes, isJust, isNothing ) import GHC.Data.FastString +import GHC.Data.Pair import GHC.Utils.Misc import GHC.Utils.Outputable @@ -2317,17 +2318,18 @@ they are constructor applications. Note [Free type variables of the qvar types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a call (f @a x True), that we want to specialise, what variables should -we quantify over. Clearly over 'a' and 'x', but what about any type variables -free in x's type? In fact we don't need to worry about them because (f @a) -can only be a well-typed application if its type is compatible with x, so any -variables free in x's type must be free in (f @a), and hence either be gathered -via 'a' itself, or be in scope at f's defn. Hence we just take - (exprsFreeVars pats). - -BUT phantom type synonyms can mess this reasoning up, - eg x::T b with type T b = Int -So we apply expandTypeSynonyms to the bound Ids. -See # 5458. Yuk. +we quantify over? Clearly over 'a' and 'x', but what about any type variables +free in x's type? In fact we don't need to worry about them, because +argsToPats gives 'x' the type of the corresponding argument of f, instantiated +at the type arguments of the call pattern (and similarly for the fields of a +data constructor in the pattern). So any variables free in x's type are free +in (f @a), and hence either gathered via 'a' itself, or in scope at f's defn. +Hence we just take (exprsFreeVars pats). + +We do not use the type of the actual argument: it is not necessarily +syntactically equal to the type of f's argument, and so may mention other +variables, e.g. with a phantom type synonym (#5458) + x::T b with type T b = Int Note [SpecConstr call patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2337,7 +2339,7 @@ Wrinkles: * The list of argument patterns, cp_args, is no longer than the visible lambdas of the binding, ri_arg_occs. This is done via - the zipWithM in callToPat. + argsToPats in callToPat. * The list of argument patterns can certainly be shorter than the lambdas in the function definition (under-saturated). For example @@ -2602,8 +2604,9 @@ callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) callToPat env bndr_occs call@(Call fn args con_env) = do { let in_scope = substInScopeSet (sc_subst env) - ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) - -- This zip trims the args to be no longer than + ; arg_triples <- argsToPats env in_scope con_env (idType fn) args bndr_occs + (repeat NotMarkedStrict) + -- This trims the args to be no longer than -- the lambdas in the function definition (bndr_occs) -- Drop boring patterns from the end @@ -2631,14 +2634,11 @@ callToPat env bndr_occs call@(Call fn args con_env) -- See Note [Shadowing in SpecConstr] at the top (qktvs, qids) = partition isTyVar qvars - qvars' = scopedSort qktvs ++ map sanitise qids + qvars' = scopedSort qktvs ++ qids -- Order into kind variables, type variables, term variables -- The kind of a type variable may mention a kind variable -- and the type of a term variable may mention a type variable - sanitise id = updateIdTypeAndMult expandTypeSynonyms id - -- See Note [Free type variables of the qvar types] - -- Check for bad coercion variables: see Note [SpecConstr and casts] ; let bad_covars = filter isCoVar qids ; warnPprTrace (not (null bad_covars)) @@ -2657,18 +2657,49 @@ callToPat env bndr_occs call@(Call fn args con_env) ; return (Just cp_res) } else return Nothing } - -- argToPat takes an actual argument, and returns an abstracted - -- version, consisting of just the "constructor skeleton" of the - -- argument, with non-constructor sub-expression replaced by new - -- placeholder variables. For example: - -- C a (D (f x) (g y)) ==> C p1 (D p2 p3) +-- | Turn the arguments of an application into patterns using 'argToPat'. +-- +-- See Note [Free type variables of the qvar types]. +argsToPats :: ScEnv + -> InScopeSet -- ^ what's in scope at the function definition site + -> ValueEnv -- ^ 'ValueEnv' at the call site + -> Type -- ^ type of the head (function or data constructor) + -> [CoreArg] -- ^ arguments of the head + -> [ArgOcc] -- ^ occurrence info, one per argument; the result is trimmed to this length + -> [StrictnessMark] -- ^ strictness info, one per value argument + -> UniqSM [(Bool, CoreArg, [Id])] +argsToPats env in_scope val_env = go + where + go _ [] _ _ = return [] + go _ _ [] _ = return [] + go fun_ty (arg : args) (occ : occs) strs + = do { (pat, strs') <- case arg of + Type {} -> do { pat <- argToPat env in_scope val_env arg_ty arg occ NotMarkedStrict + ; return (pat, strs) } + _ | str : strs' <- strs + -> do { pat <- argToPat env in_scope val_env arg_ty arg occ str + ; return (pat, strs') } + | otherwise + -> pprPanic "argsToPats: more value arguments than strictness marks" + (ppr fun_ty $$ ppr (arg : args)) + ; pats <- go (applyTypeToArgs fun_ty [sndOf3 pat]) args occs strs' + ; return (pat : pats) } + where + arg_ty = piTyBinderType (fst (splitPiTy fun_ty)) +-- | 'argToPat' takes an actual argument, and returns an abstracted +-- version, consisting of just the "constructor skeleton" of the +-- argument, with non-constructor sub-expression replaced by new +-- placeholder variables. For example: +-- +-- > C a (D (f x) (g y)) ==> C p1 (D p2 p3) argToPat :: ScEnv - -> InScopeSet -- What's in scope at the fn defn site - -> ValueEnv -- ValueEnv at the call site - -> CoreArg -- A call arg (or component thereof) - -> ArgOcc - -> StrictnessMark -- Tells us if this argument is a strict field of a data constructor + -> InScopeSet -- ^ what's in scope at the function definition site + -> ValueEnv -- ^ 'ValueEnv' at the call site + -> Type -- ^ type for this argument + -> CoreArg -- ^ A call arg (or component thereof) + -> ArgOcc -- ^ occurrence info for the argument + -> StrictnessMark -- ^ Tells us if this argument is a strict field of a data constructor -- See Note [SpecConstr and strict fields] -> UniqSM (Bool, CoreArg, [Id]) @@ -2682,25 +2713,26 @@ argToPat :: ScEnv -- lvl7 --> (True, lvl7) if lvl7 is bound -- somewhere further out -argToPat env in_scope val_env arg arg_occ arg_str +argToPat env in_scope val_env pat_ty arg arg_occ arg_str = do -- pprTraceM "argToPatIn" (ppr arg) - !res <- argToPat1 env in_scope val_env arg arg_occ arg_str + !res <- argToPat1 env in_scope val_env pat_ty arg arg_occ arg_str -- pprTraceM "argToPatOut" (ppr res) return res argToPat1 :: ScEnv -> InScopeSet -> ValueEnv + -> Type -> Expr CoreBndr -> ArgOcc -> StrictnessMark -> UniqSM (Bool, Expr CoreBndr, [Id]) -argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str +argToPat1 _env _in_scope _val_env _pat_ty arg@(Type {}) _arg_occ _arg_str = return (False, arg, []) -argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str - = argToPat env in_scope val_env arg arg_occ arg_str +argToPat1 env in_scope val_env pat_ty (Tick _ arg) arg_occ arg_str + = argToPat env in_scope val_env pat_ty arg arg_occ arg_str -- Note [Tick annotations in call patterns] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Ignore Notes. In particular, we want to ignore any InlineMe notes @@ -2708,8 +2740,8 @@ argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str -- ride roughshod over them all for now. --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules -argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str - = argToPat env in_scope val_env arg arg_occ arg_str +argToPat1 env in_scope val_env pat_ty (Let _ arg) arg_occ arg_str + = argToPat env in_scope val_env pat_ty arg arg_occ arg_str -- See Note [Matching lets] in "GHC.Core.Rules" -- Look through let expressions -- e.g. f (let v = rhs in (v,w)) @@ -2717,35 +2749,34 @@ argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str -- because the rule-matcher will look through the let. -- Casts: see Note [SpecConstr and casts] -argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str +argToPat1 env in_scope val_env pat_ty (Cast arg co) arg_occ arg_str | not (ignoreType env ty2) - = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str + = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env ty1 arg arg_occ arg_str ; if not interesting then - wildCardPat ty2 arg_str + wildCardPat pat_ty arg_str else return (interesting, Cast arg' co, strict_args) } where - ty2 = coercionRKind co + Pair ty1 ty2 = coercionKind co -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs -argToPat1 env in_scope val_env arg arg_occ _arg_str +argToPat1 env in_scope val_env _pat_ty arg arg_occ _arg_str | Just (ConVal _wf (DataAlt dc) args) <- isValue val_env arg -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2) , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args - con_str, matched_str :: [StrictnessMark] + con_str :: [StrictnessMark] -- con_str corresponds 1-1 with the /value/ arguments - -- matched_str corresponds 1-1 with /all/ arguments con_str = dataConRepStrictness dc - matched_str = match_vals con_str rest_args + con_ty = applyTypeToArgs (dataConRepType dc) ty_args -- ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$ -- ppr dc $$ -- ppr con_str $$ -- ppr rest_args $$ -- ppr (map isTypeArg rest_args)) - ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str + ; prs <- argsToPats env in_scope val_env con_ty rest_args arg_occs con_str ; let args' = map sndOf3 prs :: [CoreArg] ; assertPpr (length con_str == length (filter isRuntimeArg rest_args)) ( ppr con_str $$ ppr rest_args $$ @@ -2760,17 +2791,6 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -> Just (repeat UnkOcc) | otherwise -> Nothing - match_vals bangs (arg:args) - | isTypeArg arg - = NotMarkedStrict : match_vals bangs args - | (b:bs) <- bangs - = b : match_vals bs args - match_vals [] [] = [] - match_vals as bs = - pprPanic "spec-constr:argToPat - Bangs don't match value arguments" - (text "arg:" <> ppr arg $$ - text "remaining args:" <> ppr as $$ - text "remaining bangs:" <> ppr bs) -- Check if the argument is a variable that -- (a) is used in an interesting way in the function body @@ -2779,7 +2799,7 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -- business of absence analysis, not SpecConstr.) -- (b) we know what its value is -- In that case it counts as "interesting" -argToPat1 env in_scope val_env (Var v) arg_occ arg_str +argToPat1 env in_scope val_env _pat_ty (Var v) arg_occ arg_str | sc_force env || specialisableArgOcc arg_occ -- (a) -- See Note [Forcing specialisation], point (FS3) , is_value -- (b) @@ -2836,8 +2856,8 @@ 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 pat_ty _arg _arg_occ arg_str + = wildCardPat pat_ty arg_str -- | wildCardPats are always boring wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -2111,7 +2111,7 @@ to push the cast back inside. It would be terrible if the cast defeated specialisation! Hence the use of collectBindersPushingCo. Note [Evidence foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#12212) that we are specialising f :: forall a b. (Num a, F a ~# F b) => blah with a=b=Int. Then the RULE will be something like @@ -2120,18 +2120,13 @@ with a=b=Int. Then the RULE will be something like where that `g` is really (Coercion (CoVar g)), since `g` is a coercion variable and can't appear as (Var g). -But both varToCoreExpr (when constructing the LHS args), and the -simplifier (when simplifying the LHS args), will transform to +When simplifying the LHS args, the simplifier may replace g with Refl: RULE forall (d:Num Int) (g :: F Int ~ F Int). f Int Int d <F Int> = f_spec -by replacing g with Refl. So now 'g' is unbound, which results in a later -crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a (Coercion Refl) - * exprsFreeIdsList returns the Ids bound by the args, - which won't include g - -You might wonder if this will match as often, but the simplifier replaces -complicated Refl coercions with Refl pretty aggressively. +So now 'g' is unbound on the LHS. That is OK: since g's type is +reflexive, the rule matcher instantiates it to Refl when the rule fires; +see Note [Unbound RULE binders] in GHC.Core.Rules. So specHeader simply +forall-quantifies 'g' like any other unspecialised binder. Note [Orphans and auto-generated rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2483,13 +2478,13 @@ instance Outputable SpecArg where ppr UnspecArg = text "UnspecArg" specArgsFVs :: InterestingVarFun -> [SpecArg] -> VarSet --- Find the shallow deep free vars of the SpecArgs that are not already in scope +-- Find the (deep) free vars of the SpecArgs specArgsFVs interesting args = runFVSelectiveSet interesting $ mapUnionFV get args where get :: SpecArg -> SelectiveDFV - get (SpecType ty) = shallowSelTypeFV ty + get (SpecType ty) = deepSelTypeFV ty get (SpecDict dx) = exprFVs dx get UnspecType = mempty get UnspecArg = mempty @@ -2652,15 +2647,12 @@ specHeader subst (bndr:bndrs) (UnspecArg : args) <- specHeader subst1 bndrs args ; let dummy_arg = varToCoreExpr bndr' - -- dummy_arg is usually just (Var bndr), - -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr)) - -- or even Coercion Refl (if t1=t2) - -- See Note [Evidence foralls] - bndrs = exprFreeIdsList dummy_arg + -- dummy_arg is (Var bndr'), or (Coercion (CoVarCo bndr')) + -- if bndr' is a coercion variable; see Note [Evidence foralls] ; pure ( useful, subst2 - , bndrs ++ rule_bs, dummy_arg : rule_es - , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) } + , bndr' : rule_bs, dummy_arg : rule_es + , bndr' : spec_bs, dx, dummy_arg : spec_args ) } -- | Binds a dictionary argument to a fresh name, to preserve sharing ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -590,15 +590,15 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args ------------------ substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet -- Apply the substitution to the vars in the set, --- and take the shallow free vars of the result +-- and take the (deep) free vars of the result substDVarSet subst@(Subst _ _ tv_env cv_env) fvs = runFVSelective isLocalVar $ strictFoldDVarSet (mappend . do_one) mempty fvs where do_one :: Var -> SelectiveDFV do_one fv - | isTyVar fv = shallowSelTypeFV (lookupVarEnv tv_env fv `orElse` mkTyVarTy fv) - | isCoVar fv = shallowSelCoFV (lookupVarEnv cv_env fv `orElse` mkCoVarCo fv) + | isTyVar fv = deepSelTypeFV (lookupVarEnv tv_env fv `orElse` mkTyVarTy fv) + | isCoVar fv = deepSelCoFV (lookupVarEnv cv_env fv `orElse` mkCoVarCo fv) | otherwise = exprFVs (lookupIdSubst subst fv) ------------------ ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -26,8 +26,9 @@ module GHC.Core.TyCo.FVs coVarsOfCo, coVarsOfCos, coVarsOfCoDSet, coVarsOfCosDSet, - -- Shallow, deterministic, composable - shallowSelTypeFV, shallowSelCoFV, + -- Selective, deterministic, composable + shallowSelTypeFV, + deepSelTypeFV, deepSelCoFV, deepSelUnitFV, -- Almost devoid almostDevoidCoVarOfCo, @@ -50,7 +51,6 @@ module GHC.Core.TyCo.FVs occCheckExpand, -- * Closing over kinds - closeOverKindsDSet, closeOverKinds, ) where @@ -111,6 +111,9 @@ Examples: forall (a:(k:Type)). a {k} {k} (a:k->Type) (b:k) {a,b} {a,b,k} +Free variables of /terms/ (GHC.Core.FVs) are always deep; see +Note [Free variables of an expression] in GHC.Core.FVs. + Note [Computing deep free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -150,9 +153,10 @@ GHC.Types.Var.FV. At an occurrence of a variable (a::k) AND add on the free vars of its kind `k`. BUT in this latter step, start with an empty BoundVars set. -The "start with an empty BoundVars set" is implemented in `deepUnitFV`. It's -not /necessary/ to zap the BoundVars set, because of Invariant (NoTypeShadowing). -But it's a tiny bit more efficient because the BoundVars set is smaller. +The "start with an empty BoundVars set" is implemented in the `*UnitFV` +functions. It's not /necessary/ to zap the BoundVars set, because of +Invariant (NoTypeShadowing). But it's a tiny bit more efficient because the +BoundVars set is smaller. Side note: the free-variable binder would still work even without (NoTypeShadowing). Consider: @@ -256,39 +260,47 @@ deepCosFV :: [Coercion] -> TyCoFV (deepTypeFV, deepTypesFV, deepCoFV, deepCosFV) = foldTyCo deepTcvFolder deepTcvFolder :: TyCoFolder TyCoFV +deepTcvFolder = deepFolder (deepUnitFV fvs) fvs addBndrFV + where fvs = deepTypeFV . varType + +deepFolder :: Monoid fv + => (TyCoVar -> fv) -- ^ an occurrence of a variable + -> (TyCoVar -> fv) -- ^ the free variables of a variable's type + -> (TyCoVar -> fv -> fv) -- ^ go under a binder + -> TyCoFolder fv +-- A folder computing deep free variables; the occurrence function is one of +-- the `*UnitFV` functions. See Note [Computing deep free variables]. +-- -- It's important that we use a one-shot EndoOS, to ensure that all -- the free-variable finders are eta-expanded. Lacking the one-shot-ness -- led to some big slow downs. See Note [The one-shot state monad trick] -- in GHC.Utils.Monad -deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_lit = const mempty - , tcf_tycobinder = addBndrFV } - where - do_tcv :: TyVar -> TyCoFV - do_tcv = deepUnitFV deepTypeFV - - do_hole :: CoercionHole -> TyCoFV - do_hole hole = deepTypeFV (varType (coHoleCoVar hole)) +{-# INLINE deepFolder #-} +deepFolder occ fvs_of_type add_bndr + = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] + , tcf_tyvar = occ, tcf_covar = occ + , tcf_hole = fvs_of_type . coHoleCoVar -- We don't collect the CoercionHole itself, but we /do/ -- need to collect the free variables of its /kind/ -- See Note [CoercionHoles and coercion free variables] + , tcf_lit = const mempty + , tcf_tycobinder = add_bndr } -deepUnitFV :: (Type -> TyCoFV) -> TyCoVar -> TyCoFV --- Deal with a single TyCoVar --- Takes a function to find free vars of the kind +deepUnitFV :: (TyCoVar -> TyCoFV) -- ^ the free variables of a variable's type + -> TyCoVar -> TyCoFV +-- Deal with an occurrence of a single 'TyCoVar' -- See Note [Computing deep free variables] -{-# INLINE deepUnitFV #-} -- INLINE to specialise on fvs_of_kind -deepUnitFV fvs_of_kind +{-# INLINE deepUnitFV #-} -- INLINE to specialise on fvs_of_type +deepUnitFV fvs_of_type = \v -> MkFV (\bvs -> EndoOS (do_it bvs v)) where do_it :: BoundVars -> TyCoVar -> TyCoVarSet -> TyCoVarSet do_it bvs v acc | v `elemVarSet` bvs = acc | v `elemVarSet` acc = acc - | otherwise = runFVAcc (fvs_of_kind (varType v)) acc + | otherwise = runFVAcc (fvs_of_type v) acc `extendVarSet` v - -- Left-to-right: add the kind variables to the - -- accumulator before v itself + -- Left-to-right: add the kind variables to the + -- accumulator before v itself {- ********************************************************************* * * @@ -389,31 +401,22 @@ deepDetCoFV :: Coercion -> DTyCoFV (deepDetTypeFV, deepDetTypesFV, deepDetCoFV, _) = foldTyCo deepDetTcvFolder deepDetTcvFolder :: TyCoFolder DTyCoFV --- This one returns a /deterministic/ list --- See `deepTcvFolder` for the general pattern -deepDetTcvFolder - = TyCoFolder { tcf_view = noView - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole, tcf_lit = const mempty - , tcf_tycobinder = addBndrFV } - where - do_tcv = deepDetUnitFV deepDetTypeFV - do_hole hole = deepDetTypeFV (varType (coHoleCoVar hole)) - -deepDetUnitFV :: (Type -> DTyCoFV) -> TyCoVar -> DTyCoFV --- Deal with a single TyCoVar --- Takes a function to find free vars of the kind --- See Note [Computing deep free variables] -deepDetUnitFV fvs_of_kind v - = MkFV (\bvs -> EndoOS (do_it bvs)) +-- This one returns a /deterministic/ set +deepDetTcvFolder = deepFolder (deepDetUnitFV fvs) fvs addBndrFV + where fvs = deepDetTypeFV . varType + +deepDetUnitFV :: (TyCoVar -> DTyCoFV) -- ^ the free variables of a variable's type + -> TyCoVar -> DTyCoFV +-- Deterministic version of 'deepUnitFV' +{-# INLINE deepDetUnitFV #-} -- INLINE to specialise on fvs_of_type +deepDetUnitFV fvs_of_type + = \v -> MkFV (\bvs -> EndoOS (do_it bvs v)) where - do_it :: BoundVars -> DTyCoVarSet -> DTyCoVarSet - do_it bvs acc | v `elemVarSet` bvs = acc - | v `elemDVarSet` acc = acc - | otherwise = runFVAcc (fvs_of_kind (varType v)) acc - `extendDVarSet` v - -- Left-to-right: add the kind variables to the - -- accumulator before v itself + do_it :: BoundVars -> TyCoVar -> DTyCoVarSet -> DTyCoVarSet + do_it bvs v acc | v `elemVarSet` bvs = acc + | v `elemDVarSet` acc = acc + | otherwise = runFVAcc (fvs_of_type v) acc + `extendDVarSet` v {- ********************************************************************* * * @@ -430,30 +433,61 @@ someTyCoVarsOfTypes interesting = runFVSelectiveList interesting . mapUnionFV shallowSelTypeFV shallowSelTypeFV :: Type -> SelectiveDFV -shallowSelCoFV :: Coercion -> SelectiveDFV -- Returns shallow free vars -- See Note [Shallow and deep free variables] -(shallowSelTypeFV, _, shallowSelCoFV, _) = foldTyCo selectiveTcvFolder +(shallowSelTypeFV, _, _, _) = foldTyCo selectiveTcvFolder selectiveTcvFolder :: TyCoFolder SelectiveDFV -- This one takes an `InterestingVarFun`, and returns shallow free vars -- See `shallowTcvFolder` for the general pattern selectiveTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] - , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_tyvar = shallowSelUnitFV, tcf_covar = shallowSelUnitFV , tcf_hole = do_hole, tcf_lit = const mempty , tcf_tycobinder = addBndrSelectiveFV } where - do_tcv v = MkFV (\env -> EndoOS (do_it env)) - where - do_it (bvs,is_interesting) acc - | v `elemVarSet` bvs = acc -- First exclude bound variables - | not (is_interesting v) = acc -- The "selective" bit - | v `elemDVarSet` acc = acc - | otherwise = acc `extendDVarSet` v - do_hole hole = shallowSelTypeFV (varType (coHoleCoVar hole)) +shallowSelUnitFV :: TyCoVar -> SelectiveDFV +shallowSelUnitFV v = MkFV (\env -> EndoOS (do_it env)) + where + do_it (bvs,is_interesting) acc + | v `elemVarSet` bvs = acc -- First exclude bound variables + | not (is_interesting v) = acc -- The "selective" bit + | v `elemDVarSet` acc = acc + | otherwise = acc `extendDVarSet` v + + +{- ********************************************************************* +* * + Selective, deep, deterministic free vars +* * +********************************************************************* -} + +deepSelTypeFV :: Type -> SelectiveDFV +deepSelCoFV :: Coercion -> SelectiveDFV +-- Returns deep free vars, selectively +-- See Note [Shallow and deep free variables] +(deepSelTypeFV, _, deepSelCoFV, _) = foldTyCo deepSelectiveTcvFolder + +deepSelectiveTcvFolder :: TyCoFolder SelectiveDFV +deepSelectiveTcvFolder = deepFolder (deepSelUnitFV fvs) fvs addBndrSelectiveFV + where fvs = deepSelTypeFV . varType + +deepSelUnitFV :: (TyCoVar -> SelectiveDFV) -- ^ the free variables of a variable's type + -> TyCoVar -> SelectiveDFV +-- ^ Selective version of 'deepUnitFV'. +{-# INLINE deepSelUnitFV #-} -- INLINE to specialise on fvs_of_type +deepSelUnitFV fvs_of_type + = \v -> MkFV (\env -> EndoOS (do_it env v)) + where + do_it (bvs,is_interesting) v acc + | v `elemVarSet` bvs = acc + | not (is_interesting v) = acc + | v `elemDVarSet` acc = acc + | otherwise = runFVSelectiveAcc is_interesting (fvs_of_type v) acc + `extendDVarSet` v + {- ********************************************************************* * * @@ -508,7 +542,7 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView -- the tyvar won't end up in the accumulator, so -- we'd look repeatedly. Blargh. - do_covar = deepUnitFV deepCoVarTypeFV + do_covar = deepUnitFV (deepCoVarTypeFV . varType) do_hole hole = do_covar (coHoleCoVar hole) -- We /do/ treat a CoercionHole as a free variable @@ -540,7 +574,7 @@ deepDetCoVarFolder = TyCoFolder { tcf_view = noView do_tyvar _ = mempty do_covar :: CoVar -> DCoVarFV - do_covar = deepDetUnitFV det_ty + do_covar = deepDetUnitFV (det_ty . varType) do_hole hole = do_covar (coHoleCoVar hole) @@ -558,13 +592,6 @@ closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs where do_one v = runFVAcc (deepTypeFV (varType v)) --- | Add the kind variables free in the kinds of the tyvars in the given set. --- Returns a deterministic set. -closeOverKindsDSet :: DTyVarSet -> DTyVarSet -closeOverKindsDSet vs = nonDetStrictFoldDVarSet do_one vs vs - where - do_one v = runFVAcc (deepDetTypeFV (varType v)) - {- %************************************************************************ @@ -779,7 +806,7 @@ inj_vars_of_type :: Bool -> Type -> TyCoFV inj_vars_of_type look_under_tfs = go where go ty | Just ty' <- rewriterView ty = go ty' - go (TyVarTy v) = deepUnitFV go v + go (TyVarTy v) = deepUnitFV (go . varType) v go (AppTy f a) = go f `mappend` go a go (FunTy _ w ty1 ty2) = go w `mappend` go ty1 `mappend` go ty2 go (TyConApp tc tys) = go_tc tc tys ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -168,7 +168,6 @@ module GHC.Core.Type ( typeSize, occCheckExpand, -- ** Closing over kinds - closeOverKindsDSet, closeOverKinds, -- * Forcing evaluation of types ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -92,6 +92,7 @@ import GHC.Types.Id.Info import GHC.Types.InlinePragma ( alwaysInlinePragma, competesWith ) import GHC.Types.ForeignStubs import GHC.Types.Avail +import GHC.Types.Var ( isNonCoVarId ) import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -479,7 +480,7 @@ dsWarnRuleShadowing fn_id where bndrs_set = mkVarSet bndrs arg_ids = filterOut (`elemVarSet` bndrs_set) $ - exprsSomeFreeVarsList isId args + exprsSomeFreeVarsList isNonCoVarId args check check_rules_too lhs_id | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1014,8 +1014,7 @@ dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call is_local v = v `elemVarSet` locals -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas] - -- We have to do closeOverKinds beccause exprsSomeFreeVars is shallow - rule_bndrs = scopedSort $ dVarSetElems $ closeOverKindsDSet $ + rule_bndrs = scopedSort $ dVarSetElems $ exprsSomeFreeVarsDSet is_local rule_lhs_args -- getRenamings: (S3) of Note [Desugaring new-form SPECIALISE pragmas] ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -183,7 +183,7 @@ module GHC.Tc.Utils.TcType ( coreView, tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, - tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, tyCoVarsOfTypeList, tyCoVarsOfTypesList, noFreeVarsOfType, ===================================== compiler/GHC/Types/Var/FV.hs ===================================== @@ -6,7 +6,7 @@ module GHC.Types.Var.FV ( BoundVars, VarSetFV, DVarSetFV, SelectiveDFV, TyCoFV, DTyCoFV, runFVTop, runFVAcc, runTyCoVars, runTyCoVarsDSet, - runFVSelective, runFVSelectiveList, runFVSelectiveSet, + runFVSelective, runFVSelectiveAcc, runFVSelectiveList, runFVSelectiveSet, InterestingVarFun, updEnvFV, addBndrFV, addBndrsFV, addBndrSelectiveFV, addBndrsSelectiveFV, @@ -225,8 +225,11 @@ runTyCoVarsDSet :: DTyCoFV -> DTyCoVarSet runTyCoVarsDSet f = runFVAcc f emptyDVarSet runFVSelective :: InterestingVarFun -> SelectiveDFV -> DVarSet -runFVSelective interesting f - = runEndoOS (runFV f (emptyVarSet, interesting)) emptyDVarSet +runFVSelective interesting f = runFVSelectiveAcc interesting f emptyDVarSet + +runFVSelectiveAcc :: InterestingVarFun -> SelectiveDFV -> DVarSet -> DVarSet +-- Add the interesting free variables to the accumulator +runFVSelectiveAcc interesting f = runEndoOS (runFV f (emptyVarSet, interesting)) runFVSelectiveList :: InterestingVarFun -> SelectiveDFV -> [Var] runFVSelectiveList interesting f = dVarSetElems (runFVSelective interesting f) ===================================== testsuite/tests/simplCore/should_compile/T27936.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, ViewPatterns, RankNTypes #-} +{-# OPTIONS_GHC -fno-opt-coercion #-} +module T27936 where + +data G a where + MkG :: G Int + +f :: G a -> a -> Int -> Int +f MkG v (((\x -> (v + 1, x)) :: forall b. b -> (Int, b)) -> (y, _)) = y ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -627,3 +627,5 @@ test('T27749', compile, ['-O -g3 -ddump-simpl -dsuppress-uniques']) test('T27629', only_ways(['optasm']), makefile_test, ['T27629']) + +test('T27936', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/033ba59cbe5e70dea06fb50517d4c788... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/033ba59cbe5e70dea06fb50517d4c788... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help