Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cf01f842 by Alan Zimmerman at 2026-10-14T20:54:03-04:00 EPA: Start using vocurly as basis for AnnListLayout For the existing cases that populate AnnList. This uses AnnListBraces when braces are explicitly supplied, and AnnListLayout when vocurly is used The change also shows up AnnList usages that can never capture layout, these are cleared up later. - - - - - a6187dc3 by sheaf at 2026-10-14T20:54:07-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 - - - - - 6786471c by Luite Stegeman at 2026-10-14T20:54:12-04:00 testsuite: Use mkWeakMVar in memo001/memo002 mkWeakPtr in the memo001/memo001 tests created weak pointers with the MVar box as the key, which is fragile in the presence of optimization. The fix is using mkWeakMVar, keying on the primitive MVar# instead. Fixes #27924 and #27396 - - - - - 21 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/Parser.y - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Var/FV.hs - libraries/base/tests/Memo1.lhs - libraries/base/tests/Memo2.lhs - libraries/base/tests/all.T - testsuite/tests/parser/should_compile/DumpSemis.stderr - + 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/Parser.y ===================================== @@ -1797,10 +1797,10 @@ cvars1 :: { [RecordPatSynField GhcPs] } where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, epTok $1, - AnnList (AnnListLayout (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } + AnnList AnnListBraces (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, epTok $1, - AnnList (AnnListLayout (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3))) } + AnnList (AnnListLayout (glR $3)) ListNone (sndOf3 $ unLoc $3))) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -1936,7 +1936,7 @@ decls :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) } | {- empty -} { noLoc (noAnn, [],nilOL) } decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) + : '{' decls '}' { sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } | vocurly decls close { sL1 $2 (AnnList (AnnListLayout (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } @@ -1952,7 +1952,7 @@ binds :: { Located (HsLocalBinds GhcPs) } ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList la p s) cs, noEpTok) val_binds)} } | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (AnnListLayout$ glR $2) (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } | vocurly dbinds close {% acs (gl $2) (\loc cs -> (L loc $ HsIPBinds (EpAnn (glR $1) (AnnList (AnnListLayout $ glR $2) ListNone []) cs, noEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } @@ -3543,12 +3543,12 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList)) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), - (AnnList (AnnListLayout $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } + (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } | vocurly alts(PATS) close { $2 >>= \ $2 -> amsA' (L (getLoc $2) (reverse (snd $ unLoc $2), (AnnList (AnnListLayout $ glR $2) ListNone (fst $ unLoc $2)))) } - | '{' '}' { amsA' (sLL $1 $> ([], (AnnList AnnListNoLayout (ListBraces (epTok $1) (epTok $2)) []))) } - | vocurly close { return $ noLocA ([], noAnn) } + | '{' '}' { amsA' (sLL $1 $> ([], (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $2)) []))) } + | vocurly close { return $ noLocA ([], AnnList (AnnListLayout $ glR $1) ListNone []) } alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) } : alts1(PATS) { $1 >>= \ $1 -> return $ @@ -3657,7 +3657,7 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) } : '{' stmts '}' { $2 >>= \ $2 -> - amsA' (sLL $1 $> (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) + amsA' (sLL $1 $> (AnnList AnnListBraces (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) , sL1 $2 $ reverse $ snd $ unLoc $2))} | vocurly stmts close { $2 >>= \ $2 -> amsA' (L (stmtsLoc $2) (AnnList (AnnListLayout (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2) ===================================== 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) ===================================== libraries/base/tests/Memo1.lhs ===================================== @@ -13,10 +13,10 @@ module Memo1 where import System.Mem.StableName ( StableName, makeStableName, hashStableName ) -import System.Mem.Weak ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize ) +import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize ) import Data.Array.IO ( IOArray, newArray, readArray, writeArray ) import System.IO.Unsafe ( unsafePerformIO ) -import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar ) +import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar, mkWeakMVar ) \end{code} ----------------------------------------------------------------------------- @@ -78,7 +78,7 @@ lazyMemoSized size f = let (table,weak) = unsafePerformIO ( do { tbl <- newArray (0,size) [] ; mvar <- newMVar (size,tbl) - ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size)) + ; weak <- mkWeakMVar mvar (table_finalizer tbl size) ; return (mvar,weak) }) in memo' f table weak ===================================== libraries/base/tests/Memo2.lhs ===================================== @@ -13,10 +13,10 @@ module Memo2 where import System.Mem.StableName ( StableName, makeStableName, hashStableName ) -import System.Mem.Weak ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize ) +import System.Mem.Weak ( Weak, mkWeak, deRefWeak, finalize ) import Data.Array.IO ( IOArray, newArray, readArray, writeArray ) import System.IO.Unsafe ( unsafePerformIO ) -import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar ) +import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar, mkWeakMVar ) \end{code} ----------------------------------------------------------------------------- @@ -78,7 +78,7 @@ lazyMemoSized size f = let (table,weak) = unsafePerformIO ( do { tbl <- newArray (0,size) [] ; mvar <- newMVar (size,tbl) - ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size)) + ; weak <- mkWeakMVar mvar (table_finalizer tbl size) ; return (mvar,weak) }) in memo' f table weak ===================================== libraries/base/tests/all.T ===================================== @@ -135,8 +135,7 @@ test('list003', when(fast(), skip), compile_and_run, ['']) test('isSuffixOf', normal, compile_and_run, ['']) test('memo001', [extra_files(['Memo1.lhs']), - extra_run_opts('+RTS -A10k -RTS'), - expect_broken_for(27396, opt_ways)], multimod_compile_and_run, + extra_run_opts('+RTS -A10k -RTS')], multimod_compile_and_run, ['memo001', '']) test('memo002', [extra_files(['Memo2.lhs']), ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -364,8 +364,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:11:8-13 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:11:6 })) (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) @@ -627,8 +626,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:16:3 })) (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) @@ -880,8 +878,7 @@ ((,) (Right (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:22:12-28 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:22:10 })) (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) @@ -1936,8 +1933,7 @@ (EpAnn (EpaSpan { DumpSemis.hs:34:13-31 }) (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:34:18-30 })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:34:13 })) (EpTok (EpaSpan { DumpSemis.hs:34:31 }))) @@ -2333,8 +2329,7 @@ ((,) (FromSource) (AnnList - (AnnListLayout - (EpaSpan { DumpSemis.hs:(38,6)-(43,13) })) + (AnnListBraces) (ListBraces (EpTok (EpaSpan { DumpSemis.hs:38:4 })) (EpTok (EpaSpan { DumpSemis.hs:44:4 }))) ===================================== 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/-/compare/b877a9b0eacc082eccf51b70b8b4a96... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b877a9b0eacc082eccf51b70b8b4a96... 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