Simon Peyton Jones pushed to branch wip/T26868 at Glasgow Haskell Compiler / GHC Commits: d3f56f61 by Simon Peyton Jones at 2026-02-21T22:55:58+00:00 Major refactor of free-variable functions For some time we have had two free-variable mechanims for types: * The "FV" mechanism, embodied in GHC.Utils.FV, which worked OK, but was fragile where eta-expansion was concerned. * The TyCoFolder mechanism, using a one-shot EndoOS accumulator I finally got tired of this and refactored the whole thing. Now we have * GHC.Types.Var.FV, which has a composable free-variable result type, very much in the spirit of the old `FV`, but much more robust. (It uses the "one shot trick".) * GHC.Core.TyCo.FVs now has just one technology for free variables. All this led to a lot of renaming. - - - - - 18 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Opt/SetLevels.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/Iface/Ext/Ast.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Utils/EndoOS.hs - − compiler/GHC/Utils/FV.hs - compiler/ghc.cabal.in - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -78,7 +78,6 @@ module GHC.Core.Coercion ( -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, - tyCoFVsOfCo, tyCoVarsOfCoDSet, coercionSize, anyFreeVarsOfCo, -- ** Substitution ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -35,7 +35,7 @@ module GHC.Core.FVs ( ruleLhsFreeIds, ruleLhsFreeIdsList, ruleRhsFreeVars, rulesRhsFreeIds, - exprFVs, addBndrFV, addBndrsFV, unitFV, + exprFVs, addCoreBndrFV, addCoreBndrsFV, unitFV, -- * Orphan names orphNamesOfType, orphNamesOfTypes, orphNamesOfAxiomLHS, @@ -61,8 +61,9 @@ import GHC.Types.Id.Info import GHC.Types.Name.Set import GHC.Types.Name import GHC.Types.Tickish -import GHC.Types.Var.Set import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.FV import GHC.Core.Type import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs @@ -154,10 +155,10 @@ exprsFreeIdsList = dVarSetElems . exprsFreeIdsDSet bindFreeVars :: CoreBind -> VarSet bindFreeVars = runFVSelectiveSet isLocalVar . bind_fvs -bind_fvs :: CoreBind -> SelectiveFVRes +bind_fvs :: CoreBind -> SelectiveFV bind_fvs (NonRec b r) = rhs_fvs (b,r) -bind_fvs (Rec prs) = addBndrsSelectiveFVRes (map fst prs) $ - mapUnionFVRes rhs_fvs prs +bind_fvs (Rec prs) = addBndrsSelectiveFV (map fst prs) $ + mapUnionFV rhs_fvs prs -- | Finds free variables in an expression selected by a predicate exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting @@ -199,20 +200,20 @@ exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interestin -> DVarSet exprsSomeFreeVarsDSet fv_cand = runFVSelective fv_cand . exprsFVs -addBndrFV :: CoreBndr -> SelectiveFVRes -> SelectiveFVRes -addBndrFV bndr fvr +addCoreBndrFV :: CoreBndr -> SelectiveFV -> SelectiveFV +addCoreBndrFV bndr fvr = bndrTypeTyCoFVs bndr `mappend` -- Include type variables in the binder's type -- (not just Ids; coercion variables too!) - addBndrSelectiveFVRes bndr fvr + addBndrSelectiveFV bndr fvr -addBndrsFV :: [CoreBndr] -> SelectiveFVRes -> SelectiveFVRes -addBndrsFV bndrs fv = foldr addBndrFV fv bndrs +addCoreBndrsFV :: [CoreBndr] -> SelectiveFV -> SelectiveFV +addCoreBndrsFV bndrs fv = foldr addCoreBndrFV fv bndrs -unitFV :: Var -> SelectiveFVRes +unitFV :: Var -> SelectiveFV -- Deals with an occurrence -- Shallow: does not look at the kind -unitFV v = FVRes (\bvs -> EndoOS (do_it bvs)) +unitFV v = MkFV (\bvs -> EndoOS (do_it bvs)) where do_it (is_interesting,bvs) acc | not (is_interesting v) = acc -- The "selective" bit @@ -220,49 +221,49 @@ unitFV v = FVRes (\bvs -> EndoOS (do_it bvs)) | v `elemDVarSet` acc = acc | otherwise = acc `extendDVarSet` v -exprsFVs :: [CoreExpr] -> SelectiveFVRes -exprsFVs = mapUnionFVRes exprFVs +exprsFVs :: [CoreExpr] -> SelectiveFV +exprsFVs = mapUnionFV exprFVs -exprFVs :: CoreExpr -> SelectiveFVRes -exprFVs (Type ty) = tyCoFVsOfType ty -exprFVs (Coercion co) = tyCoFVsOfCo co +exprFVs :: CoreExpr -> SelectiveFV +exprFVs (Type ty) = shallowSelTypeFV ty +exprFVs (Coercion co) = shallowSelCoFV 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) = addBndrFV bndr (exprFVs body) -exprFVs (Cast expr co) = exprFVs expr `mappend` tyCoFVsOfCo co +exprFVs (Lam bndr body) = addCoreBndrFV bndr (exprFVs body) +exprFVs (Cast expr co) = exprFVs expr `mappend` shallowSelCoFV co exprFVs (Case scrut bndr ty alts) - = exprFVs scrut `mappend` tyCoFVsOfType ty `mappend` - addBndrFV bndr (mapUnionFVRes alt_fvs alts) + = exprFVs scrut `mappend` shallowSelTypeFV ty `mappend` + addCoreBndrFV bndr (mapUnionFV alt_fvs alts) where - alt_fvs (Alt _ bndrs rhs) = addBndrsFV bndrs (exprFVs rhs) + alt_fvs (Alt _ bndrs rhs) = addCoreBndrsFV bndrs (exprFVs rhs) exprFVs (Let (NonRec bndr rhs) body) - = rhs_fvs (bndr, rhs) `mappend` addBndrFV bndr (exprFVs body) + = rhs_fvs (bndr, rhs) `mappend` addCoreBndrFV bndr (exprFVs body) exprFVs (Let (Rec pairs) body) - = addBndrsFV (map fst pairs) $ - mapUnionFVRes rhs_fvs pairs `mappend` exprFVs body + = addCoreBndrsFV (map fst pairs) $ + mapUnionFV rhs_fvs pairs `mappend` exprFVs body --------- -rhs_fvs :: (Id, CoreExpr) -> SelectiveFVRes +rhs_fvs :: (Id, CoreExpr) -> SelectiveFV rhs_fvs (bndr, rhs) = exprFVs rhs `mappend` bndrRuleAndUnfoldingFVs bndr -- Treat any RULES as extra RHSs of the binding --------- -tickish_fvs :: CoreTickish -> SelectiveFVRes -tickish_fvs (Breakpoint _ _ ids) = mapUnionFVRes unitFV ids +tickish_fvs :: CoreTickish -> SelectiveFV +tickish_fvs (Breakpoint _ _ ids) = mapUnionFV unitFV ids tickish_fvs _ = mempty --------- -bndrTypeTyCoFVs :: Var -> SelectiveFVRes +bndrTypeTyCoFVs :: Var -> SelectiveFV -- Find the free variables of a binder. -- In the case of ids, don't forget the multiplicity field! bndrTypeTyCoFVs var - = tyCoFVsOfType (varType var) `mappend` mult_fvs + = shallowSelTypeFV (varType var) `mappend` mult_fvs where mult_fvs = case varMultMaybe var of - Just mult -> tyCoFVsOfType mult + Just mult -> shallowSelTypeFV mult Nothing -> mempty dBndrTypeTyCoVars :: Var -> DTyCoVarSet @@ -278,7 +279,7 @@ dBndrFreeVars :: Id -> DVarSet -- Shallow free vars dBndrFreeVars id = runFVSelective isLocalVar $ bndrFVs id -bndrFVs :: Id -> SelectiveFVRes +bndrFVs :: Id -> SelectiveFV -- Shallow free vars of types, rules, and inlining bndrFVs id = assert (isId id) $ bndrTypeTyCoFVs id `mappend` @@ -290,7 +291,7 @@ bndrRuleAndUnfoldingVarsDSet = runFVSelective isLocalVar . bndrRuleAndUnfoldingF bndrRuleAndUnfoldingVars :: Id -> VarSet bndrRuleAndUnfoldingVars = dVarSetToVarSet . bndrRuleAndUnfoldingVarsDSet -bndrRuleAndUnfoldingFVs :: Id -> SelectiveFVRes +bndrRuleAndUnfoldingFVs :: Id -> SelectiveFV bndrRuleAndUnfoldingFVs id | isId id = idRuleFVs id `mappend` idUnfoldingFVs id | otherwise = mempty @@ -298,7 +299,7 @@ bndrRuleAndUnfoldingFVs id idRuleVars :: Id -> VarSet -- Does *not* include CoreUnfolding vars idRuleVars = dVarSetToVarSet . ruleInfoFreeVars . idSpecialisation -idRuleFVs :: Id -> SelectiveFVRes +idRuleFVs :: Id -> SelectiveFV idRuleFVs id = assert (isId id) $ strictFoldDVarSet (mappend . unitFV) mempty $ ruleInfoFreeVars (idSpecialisation id) @@ -311,21 +312,21 @@ idUnfoldingVars :: Id -> VarSet -- we might get out-of-scope variables idUnfoldingVars = runFVSelectiveSet isLocalVar . idUnfoldingFVs -idUnfoldingFVs :: Id -> SelectiveFVRes +idUnfoldingFVs :: Id -> SelectiveFV idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` mempty stableUnfoldingVars :: Unfolding -> Maybe VarSet stableUnfoldingVars unf = fmap (runFVSelectiveSet isLocalVar) $ stableUnfoldingFVs unf -stableUnfoldingFVs :: Unfolding -> Maybe SelectiveFVRes +stableUnfoldingFVs :: Unfolding -> Maybe SelectiveFV stableUnfoldingFVs unf = case unf of CoreUnfolding { uf_tmpl = rhs, uf_src = src } | isStableSource src -> Just (exprFVs rhs) DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just (addBndrsFV bndrs (exprsFVs args)) + -> Just (addCoreBndrsFV bndrs (exprsFVs args)) -- DFuns are top level, so no fvs from types of bndrs _other -> Nothing @@ -497,13 +498,13 @@ data RuleFVsFrom -- | Those locally-defined variables free in the left and/or right hand sides -- of the rule, depending on the first argument. -ruleFVs :: RuleFVsFrom -> CoreRule -> SelectiveFVRes +ruleFVs :: RuleFVsFrom -> CoreRule -> SelectiveFV ruleFVs !_ (BuiltinRule {}) = mempty ruleFVs from (Rule { ru_fn = _do_not_include -- See Note [Rule free var hack] , ru_bndrs = bndrs , ru_rhs = rhs, ru_args = args }) - = addBndrsFV bndrs (exprsFVs exprs) + = addCoreBndrsFV bndrs (exprsFVs exprs) where exprs = case from of LhsOnly -> args @@ -512,8 +513,8 @@ ruleFVs from (Rule { ru_fn = _do_not_include -- | Those locally-defined variables free in the left and/or right hand sides -- from several rules, depending on the first argument. -rulesFVs :: RuleFVsFrom -> [CoreRule] -> SelectiveFVRes -rulesFVs from = mapUnionFVRes (ruleFVs from) +rulesFVs :: RuleFVsFrom -> [CoreRule] -> SelectiveFV +rulesFVs from = mapUnionFV (ruleFVs from) -- | Those variables free in the right hand side of a rule returned as a -- non-deterministic set @@ -666,7 +667,7 @@ freeVarsBind (Rec binds) body_fvs (binders, rhss) = unzip binds rhss2 = map freeVars rhss rhs_body_fvs = foldr (unionDVarSet . freeVarsOf) body_fvs rhss2 - binders_fvs = runFVSelective isLocalVar $ mapUnionFVRes bndrRuleAndUnfoldingFVs binders + binders_fvs = runFVSelective isLocalVar $ mapUnionFV bndrRuleAndUnfoldingFVs binders -- See Note [The FVAnn invariant] all_fvs = rhs_body_fvs `unionDVarSet` binders_fvs -- The "delBinderFV" happens after adding the idSpecVars, ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -101,6 +101,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Var import GHC.Types.Var.Set +import GHC.Types.Var.FV import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env @@ -1380,7 +1381,7 @@ lvlBind env (AnnRec pairs) bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs]) `unionDVarSet` (runFVSelective isLocalVar $ - mapUnionFVRes (\(bndr,_) -> bndrFVs bndr) pairs)) + mapUnionFV (\(bndr,_) -> bndrFVs bndr) pairs)) `delDVarSetList` bndrs ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env +import GHC.Types.Var.FV import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.InlinePragma @@ -2512,10 +2513,10 @@ specArgsFVs :: InterestingVarFun -> [SpecArg] -> VarSet -- Find the shallow deep free vars of the SpecArgs that are not already in scope specArgsFVs interesting args = runFVSelectiveSet interesting $ - mapUnionFVRes get args + mapUnionFV get args where - get :: SpecArg -> SelectiveFVRes - get (SpecType ty) = tyCoFVsOfType ty + get :: SpecArg -> SelectiveFV + get (SpecType ty) = shallowSelTypeFV ty get (SpecDict dx) = exprFVs dx get UnspecType = mempty get UnspecArg = mempty ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -48,6 +48,7 @@ import GHC.Core.Coercion( mkCoVarCo, substCoVarBndr ) import GHC.Core.TyCo.FVs import GHC.Types.Var.Set +import GHC.Types.Var.FV import GHC.Types.Var.Env as InScopeSet import GHC.Types.Id import GHC.Types.Name ( Name ) @@ -594,10 +595,10 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs = runFVSelective isLocalVar $ strictFoldDVarSet (mappend . do_one) mempty fvs where - do_one :: Var -> SelectiveFVRes + do_one :: Var -> SelectiveFV do_one fv - | isTyVar fv = tyCoFVsOfType (lookupVarEnv tv_env fv `orElse` mkTyVarTy fv) - | isCoVar fv = tyCoFVsOfCo (lookupVarEnv cv_env fv `orElse` mkCoVarCo fv) + | isTyVar fv = shallowSelTypeFV (lookupVarEnv tv_env fv `orElse` mkTyVarTy fv) + | isCoVar fv = shallowSelCoFV (lookupVarEnv cv_env fv `orElse` mkCoVarCo fv) | otherwise = exprFVs (lookupIdSubst subst fv) ------------------ ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -1,17 +1,7 @@ -{-# LANGUAGE MultiWayIf, PatternSynonyms #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Core.TyCo.FVs - ( -- FVRes and friends - FVRes( runFV, FVRes ), - addBndrFVRes, addBndrsFVRes, addBndrSelectiveFVRes, addBndrsSelectiveFVRes, - mapUnionFVRes, shallowUnitFVRes, deepUnitFVRes, - BoundVars, VarSetFVRes, DVarSetFVRes, SelectiveFVRes, - TyCoFVRes, DTyCoFVRes, - runFVTop, runFVAcc, runTyCoVars, runTyCoVarsDSet, - runFVSelective, runFVSelectiveList, runFVSelectiveSet, - InterestingVarFun, - - -- Shallow + ( -- Shallow shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, shallowTyCoVarsOfCo, shallowTyCoVarsOfCos, shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv, @@ -20,13 +10,13 @@ module GHC.Core.TyCo.FVs tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypesList, tyCoVarsOfThings, tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfMCo, - deepTcvFolder, deepTypeFV, deepCoFV, + deepTcvFolder, deepTypeFV, deepTypesFV, deepCoFV, -- Deep, deterministic tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, tyCoVarsOfTypeList, tyCoVarsOfCoDSet, tyCoVarsOfCoList, tyCoVarsOfThingsDSet, - detTyCoVarsOfType, detTyCoVarsOfTypes, detTyCoVarsOfCo, + deepDetTypeFV, deepDetTypesFV, deepDetCoFV, -- Selective someTyCoVarsOfType, someTyCoVarsOfTypes, @@ -37,7 +27,7 @@ module GHC.Core.TyCo.FVs coVarsOfCoDSet, coVarsOfCosDSet, -- Shallow, deterministic, composable - tyCoFVsOfType, tyCoFVsOfCo, + shallowSelTypeFV, shallowSelCoFV, -- Almost devoid almostDevoidCoVarOfCo, @@ -76,6 +66,7 @@ import GHC.Core.TyCon import GHC.Core.Coercion.Axiom( CoAxiomRule(..), BuiltInFamRewrite(..), coAxiomTyCon ) import GHC.Types.Var +import GHC.Types.Var.FV import GHC.Types.Unique.FM import GHC.Types.Unique.Set @@ -86,7 +77,6 @@ import GHC.Utils.Misc import GHC.Utils.EndoOS import GHC.Data.Pair -import GHC.Exts (oneShot) import Data.Semigroup @@ -120,97 +110,42 @@ Examples: (a : (k:Type)) {a} {a,k} forall (a:(k:Type)). a {k} {k} (a:k->Type) (b:k) {a,b} {a,b,k} --} - - -{- Note [Free variables of types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns -a VarSet that is closed over the types of its variables. More precisely, - if S = tyCoVarsOfType( t ) - and (a:k) is in S - then tyCoVarsOftype( k ) is a subset of S - -Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. - -We could /not/ close over the kinds of the variable occurrences, and -instead do so at call sites, but it seems that we always want to do -so, so it's easiest to do it here. - -It turns out that getting the free variables of types is performance critical, -so we profiled several versions, exploring different implementation strategies. - -1. Baseline version: uses FV naively. Essentially: - - tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty - - This is not nice, because FV introduces some overhead to implement - determinism, and through its "interesting var" function, neither of which - we need here, so they are a complete waste. -2. UnionVarSet version: instead of reusing the FV-based code, we simply used - VarSets directly, trying to avoid the overhead of FV. E.g.: - -- FV version: - tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c +Note [Computing deep free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tyCoVarsOfType computes the /deep/ free variables of a type; that is, if +`a::k` is in the result, then so are the free vars of `k`. We say that the +resulting set is "closed over kinds". - -- UnionVarSet version: - tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) +But we must take care (see #14880): - This looks deceptively similar, but while FV internally builds a list- and - set-generating function, the VarSet functions manipulate sets directly, and - the latter performs a lot worse than the naive FV version. +1. Efficiency. If we have Proxy (a::ki) -> Proxy (a::ki) -> Proxy (a::ki), then + we don't want to have to traverse ki more than once. -3. Accumulator-style VarSet version: this is what we use now. We do use VarSet - as our data structure, but delegate the actual work to a new - ty_co_vars_of_... family of functions, which use accumulator style and the - "in-scope set" filter found in the internals of FV, but without the - determinism overhead. - -See #14880. - -Note [Closing over free variable kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over -free variable kinds. In previous GHC versions, this happened naively: whenever -we would encounter an occurrence of a free type variable, we would close over -its kind. This, however is wrong for two reasons (see #14880): - -1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then - we don't want to have to traverse k more than once. - -2. Correctness. Imagine we have forall k. b -> k, where b has - kind k, for some k bound in an outer scope. If we look at b's kind inside +2. Correctness. Imagine we have forall k. (b::k) -> k, where b has + kind k, for some k bound in an /outer/ scope. If we look at b's kind inside the forall, we'll collect that k is free and then remove k from the set of free variables. This is plain wrong. We must instead compute that b is free and then conclude that b's kind is free. -An obvious first approach is to move the closing-over-kinds from the -occurrences of a type variable to after finding the free vars - however, this -turns out to introduce performance regressions, and isn't even entirely -correct. - -In fact, it isn't even important *when* we close over kinds; what matters is -that we handle each type var exactly once, and that we do it in the right -context. +An obvious first approach is to compute the /shallow/ free variables of the type, +and /then/ close over kinds. But that turns out not to be very efficient. +Fortunately, there is a simpler way, which works with the accumulating +free-var story described in (FV1) of Note [Finding free variables] in +GHC.Types.Var.FV. At an occurrence of a variable (a::k) -So the next approach we tried was to use the "in-scope set" part of FV or the -equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to -say "don't bother with variables we have already closed over". This should work -fine in theory, but the code is complicated and doesn't perform well. +* Check if `a` is a locally-bound var; if so, ignore it. -But there is a simpler way, which is implemented here. Consider the two points -above: +* Check if `a` is already in the accumulator; if so, ignore it because we have + deal with its kind already. Also pre-checking set membership before inserting + ends up not only being faster, -1. Efficiency: we now have an accumulator, so the second time we encounter 'a', - we'll ignore it, certainly not looking at its kind - this is why - pre-checking set membership before inserting ends up not only being faster, - but also being correct. +* Otherwise add `a` to the accumulator, + AND add on the free vars of its kind `k`. + BUT in this latter step, start with an empty BoundVars set. -2. Correctness: we have an "in-scope set" (I think we should call it it a - "bound-var set"), specifying variables that are bound by a forall in the type - we are traversing; we simply ignore these variables, certainly not looking at - their kind. +This twist is implemented in `deepUnitFV` So now consider: @@ -222,22 +157,6 @@ this is our first encounter with b; we want the free vars of its kind. But we want to behave as if we took the free vars of its kind at the end; that is, with no bound vars in scope. -So the solution is easy. The old code was this: - - ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) - -Now all we need to do is take the free vars of tyVarKind v *with an empty -bound-var set*, thus: - -ty_co_vars_of_type (TyVarTy v) is acc - | v `elemVarSet` is = acc - | v `elemVarSet` acc = acc - | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) - ^^^^^^^^^^^ - And that's it. This works because a variable is either bound or free. If it is bound, then we won't look at it at all. If it is free, then all the variables free in its kind are free -- regardless of whether some local variable has the same Unique. @@ -266,147 +185,6 @@ The sole reason is in Note [Emitting the residual implication in simplifyInfer] in GHC.Tc.Solver. Yuk. This is not pretty. -} -{- ********************************************************************* -* * - Endo for free variables -* * -********************************************************************* -} - -{- Note [Accumulating parameter free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can use foldType to build an accumulating-parameter version of a -free-var finder, thus: - - fvs :: Type -> TyCoVarSet - fvs ty = appEndo (foldType folder ty) emptyVarSet - -Recall that - foldType :: TyCoFolder env a -> env -> Type -> a - - newtype Endo a = Endo (a -> a) -- In Data.Monoid - instance Monoid a => Monoid (Endo a) where - (Endo f) `mappend` (Endo g) = Endo (f.g) - - appEndo :: Endo a -> a -> a - appEndo (Endo f) x = f x - -So `mappend` for Endos is just function composition. - -It's very important that, after optimisation, we end up with -* an arity-three function -* that is strict in the accumulator - - fvs env (TyVarTy v) acc - | v `elemVarSet` env = acc - | v `elemVarSet` acc = acc - | otherwise = acc `extendVarSet` v - fvs env (AppTy t1 t2) = fvs env t1 (fvs env t2 acc) - ... - -The "strict in the accumulator" part is to ensure that in the -AppTy equation we don't build a thunk for (fvs env t2 acc). - -The optimiser does do all this, but not very robustly. It depends -critically on the basic arity-2 function not being exported, so that -all its calls are visibly to three arguments. This analysis is -done by the Call Arity pass. - -TL;DR: check this regularly! --} - - -{- ********************************************************************* -* * - Free-var result type -* * -********************************************************************* -} - -type InterestingVarFun = Var -> Bool - -newtype FVRes env acc = FVRes' { runFV :: env -> acc } - -- Caries an environment (typically empty, or a set of in-scope variables) - -- and a composable accumulator - -pattern FVRes :: (env -> acc) -> FVRes env acc -pattern FVRes f <- FVRes' f - where - FVRes f = FVRes' (oneShot f) - -- oneShot: this is the core of the one-shot trick! - -- Note [The one-shot state monad trick] in GHC.Utils.Monad. - -instance Semigroup a => Semigroup (FVRes env a) where - f1 <> f2 = FVRes (\env -> runFV f1 env <> runFV f2 env) - -instance Monoid a => Monoid (FVRes env a) where - mempty = FVRes (\_ -> mempty) - -addBndrFV :: (env -> env) -> FVRes env a -> FVRes env a -{-# INLINE addBndrFV #-} -addBndrFV upd f = FVRes (\bvs -> runFV f $! upd bvs) - -- Strict application to avoid making a thunk - -addBndrFVRes :: TyCoVar -> FVRes BoundVars a -> FVRes BoundVars a -addBndrFVRes tcv = addBndrFV (\bvs -> extendVarSet bvs tcv) - -addBndrsFVRes :: [Var] -> FVRes BoundVars a -> FVRes BoundVars a -addBndrsFVRes tcvs = addBndrFV (\bvs -> extendVarSetList bvs tcvs) - -addBndrSelectiveFVRes :: TyCoVar -> FVRes (f, BoundVars) a -> FVRes (f, BoundVars) a -addBndrSelectiveFVRes tcv - = addBndrFV (\(f,bvs) -> let !bvs' = extendVarSet bvs tcv - -- Strict let to avoid thunks - in (f,bvs')) -addBndrsSelectiveFVRes :: [Var] -> FVRes (f, BoundVars) a -> FVRes (f, BoundVars) a -addBndrsSelectiveFVRes bs - = addBndrFV (\(f,bvs) -> let !bvs' = extendVarSetList bvs bs - -- Strict let to avoid thunks - in (f,bvs')) - -mapUnionFVRes :: (Foldable t, Monoid acc) - => (a -> FVRes env acc) -> t a -> FVRes env acc -{-# INLINE mapUnionFVRes #-} -mapUnionFVRes f xs = foldr (mappend . f) mempty xs - - -type BoundVars = TyCoVarSet - - -type VarSetFVRes = FVRes BoundVars (EndoOS TyCoVarSet) -type DVarSetFVRes = FVRes BoundVars (EndoOS DTyCoVarSet) -type SelectiveFVRes = FVRes (InterestingVarFun, BoundVars) (EndoOS DVarSet) --- VarSetFVRes: collects a VarSet --- DVarSetFVRes: collects a DVarSet (deterministic) --- SelectiveFVRes: selectively collects a DVarSet - -type TyCoFVRes = VarSetFVRes -type DTyCoFVRes = DVarSetFVRes - -runFVTop :: FVRes BoundVars a -> a -{-# INLINE runFVTop #-} -runFVTop f = runFV f emptyVarSet - -runFVAcc :: FVRes BoundVars (EndoOS a) -> a -> a -{-# INLINE runFVAcc #-} -runFVAcc f = runEndoOS (runFVTop f) - -runTyCoVars :: TyCoFVRes -> TyCoVarSet -{-# INLINE runTyCoVars #-} -runTyCoVars f = runFVAcc f emptyVarSet - -runTyCoVarsDSet :: DTyCoFVRes -> DTyCoVarSet -{-# INLINE runTyCoVarsDSet #-} -runTyCoVarsDSet f = runFVAcc f emptyDVarSet - -runFVSelective :: InterestingVarFun -> SelectiveFVRes -> DVarSet -runFVSelective interesting f - = runEndoOS (runFV f (interesting, emptyVarSet)) emptyDVarSet - -runFVSelectiveList :: InterestingVarFun -> SelectiveFVRes -> [Var] -runFVSelectiveList interesting f = dVarSetElems (runFVSelective interesting f) - -runFVSelectiveSet :: InterestingVarFun -> SelectiveFVRes -> VarSet -runFVSelectiveSet interesting f = dVarSetToVarSet (runFVSelective interesting f) - {- ********************************************************************* * * @@ -429,7 +207,7 @@ tyCoVarsOfTypes tys = runTyCoVars (deepTypesFV tys) tyCoVarsOfCo :: Coercion -> TyCoVarSet -- The "deep" TyCoVars of the the coercion --- See Note [Free variables of types] +-- See Note [Computing deep free variables] tyCoVarsOfCo co = runTyCoVars (deepCoFV co) tyCoVarsOfMCo :: MCoercion -> TyCoVarSet @@ -441,17 +219,17 @@ tyCoVarsOfCos cos = runTyCoVars (deepCosFV cos) tyCoVarsOfThings :: Foldable t => (a -> Type) -> t a -> TyCoVarSet -- Works over a collection of things from which we can extract a type --- See Note [Free variables of types] +-- See Note [Computing deep free variables] tyCoVarsOfThings get_ty things - = runTyCoVars $ mapUnionFVRes (deepTypeFV . get_ty) things + = runTyCoVars $ mapUnionFV (deepTypeFV . get_ty) things -deepTypeFV :: Type -> TyCoFVRes -deepTypesFV :: [Type] -> TyCoFVRes -deepCoFV :: Coercion -> TyCoFVRes -deepCosFV :: [Coercion] -> TyCoFVRes +deepTypeFV :: Type -> TyCoFV +deepTypesFV :: [Type] -> TyCoFV +deepCoFV :: Coercion -> TyCoFV +deepCosFV :: [Coercion] -> TyCoFV (deepTypeFV, deepTypesFV, deepCoFV, deepCosFV) = foldTyCo deepTcvFolder -deepTcvFolder :: TyCoFolder TyCoFVRes +deepTcvFolder :: TyCoFolder TyCoFV -- 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] @@ -459,22 +237,23 @@ deepTcvFolder :: TyCoFolder TyCoFVRes deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole - , tcf_tycobinder = addBndrFVRes } + , tcf_tycobinder = addBndrFV } where - do_tcv :: TyVar -> TyCoFVRes - do_tcv = deepUnitFVRes deepTypeFV + do_tcv :: TyVar -> TyCoFV + do_tcv = deepUnitFV deepTypeFV - do_hole :: CoercionHole -> TyCoFVRes + do_hole :: CoercionHole -> TyCoFV do_hole hole = deepTypeFV (varType (coHoleCoVar hole)) -- 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] -deepUnitFVRes :: (Type -> TyCoFVRes) -> TyCoVar -> TyCoFVRes +deepUnitFV :: (Type -> TyCoFV) -> TyCoVar -> TyCoFV -- Deal with a single TyCoVar -- Takes a function to find free vars of the kind -deepUnitFVRes fvs_of_kind v - = FVRes (\bvs -> EndoOS (do_it bvs)) +-- See Note [Computing deep free variables] +deepUnitFV fvs_of_kind v + = MkFV (\bvs -> EndoOS (do_it bvs)) where do_it :: BoundVars -> TyCoVarSet -> TyCoVarSet do_it bvs acc | v `elemVarSet` bvs = acc @@ -490,23 +269,23 @@ deepUnitFVRes fvs_of_kind v ********************************************************************* -} shallowTyCoVarsOfType :: Type -> TyCoVarSet --- See Note [Free variables of types] -shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty) +-- See Note [Shallow and deep free variables] +shallowTyCoVarsOfType ty = runTyCoVars (shallowTypeFV ty) shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet -shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys) +shallowTyCoVarsOfTypes tys = runTyCoVars (shallowTypesFV tys) shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet -shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co) +shallowTyCoVarsOfCo co = runTyCoVars (shallowCoFV co) shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet -shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos) +shallowTyCoVarsOfCos cos = runTyCoVars (shallowCosFV cos) -- | Returns free variables of types, including kind variables as -- a non-deterministic set. For type synonyms it does /not/ expand the -- synonym. shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet --- See Note [Free variables of types] +-- See Note [Shallow and deep free variables]of types] shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys) -- It's OK to use nonDetEltsUFM here because we immediately -- forget the ordering by returning a set @@ -516,25 +295,25 @@ shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos) -- It's OK to use nonDetEltsUFM here because we immediately -- forget the ordering by returning a set -shallow_ty :: Type -> TyCoFVRes -shallow_tys :: [Type] -> TyCoFVRes -shallow_co :: Coercion -> TyCoFVRes -shallow_cos :: [Coercion] -> TyCoFVRes -(shallow_ty, shallow_tys, shallow_co, shallow_cos) +shallowTypeFV :: Type -> TyCoFV +shallowTypesFV :: [Type] -> TyCoFV +shallowCoFV :: Coercion -> TyCoFV +shallowCosFV :: [Coercion] -> TyCoFV +(shallowTypeFV, shallowTypesFV, shallowCoFV, shallowCosFV) = foldTyCo shallowTcvFolder -shallowTcvFolder :: TyCoFolder TyCoFVRes +shallowTcvFolder :: TyCoFolder TyCoFV shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole - , tcf_tycobinder = addBndrFVRes } + , tcf_tycobinder = addBndrFV } where - do_tcv = shallowUnitFVRes + do_tcv = shallowUnitFV do_hole _ = mempty -- Ignore coercion holes -shallowUnitFVRes :: TyCoVar -> TyCoFVRes -shallowUnitFVRes v - = FVRes (\bvs -> EndoOS (do_it bvs)) +shallowUnitFV :: TyCoVar -> TyCoFV +shallowUnitFV v + = MkFV (\bvs -> EndoOS (do_it bvs)) where do_it bvs acc | v `elemVarSet` bvs = acc | v `elemVarSet` acc = acc @@ -547,71 +326,71 @@ shallowUnitFVRes v * * ********************************************************************* -} --- | `tyCoVarsOfTypeDSet` that returns free variables of a type in a deterministic --- set. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in "GHC.Utils.FV". +-- | `tyCoVarsOfTypeDSet` that returns deep free variables of a type in a +-- deterministic-- set. For explanation of why using `VarSet` is not deterministic +-- see Note [Deterministic FV] in "GHC.TYpes.Var.FV". tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypeDSet ty = runTyCoVarsDSet (detTyCoVarsOfType ty) +-- See Note [Computing deep free variables] +tyCoVarsOfTypeDSet ty = runTyCoVarsDSet (deepDetTypeFV ty) -- | Returns free variables of types, including kind variables as -- a deterministic set. For type synonyms it does /not/ expand the -- synonym. tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfTypesDSet tys = runTyCoVarsDSet (detTyCoVarsOfTypes tys) +-- See Note [Computing deep free variables] +tyCoVarsOfTypesDSet tys = runTyCoVarsDSet (deepDetTypesFV tys) tyCoVarsOfThingsDSet :: Foldable t => (a -> Type) -> t a -> DTyCoVarSet -- Works over a collection of things from which we can extract a type --- See Note [Free variables of types] +-- See Note [Computing deep free variables] tyCoVarsOfThingsDSet get_ty things - = runTyCoVarsDSet (mapUnionFVRes (detTyCoVarsOfType . get_ty) things) + = runTyCoVarsDSet (mapUnionFV (deepDetTypeFV . get_ty) things) -- | `tyCoVarsOfTypeList` returns free variables of a type in deterministic -- order. For explanation of why using `VarSet` is not deterministic see --- Note [Deterministic FV] in "GHC.Utils.FV". +-- Note [Deterministic FV] in "GHC.Types.Var.FV". tyCoVarsOfTypeList :: Type -> [TyCoVar] --- See Note [Free variables of types] +-- See Note [Computing deep free variables] tyCoVarsOfTypeList ty = dVarSetElems $ tyCoVarsOfTypeDSet ty tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet --- See Note [Free variables of types] -tyCoVarsOfCoDSet ty = runTyCoVarsDSet (detTyCoVarsOfCo ty) +-- See Note [Computing deep free variables] +tyCoVarsOfCoDSet ty = runTyCoVarsDSet (deepDetCoFV ty) tyCoVarsOfCoList :: Coercion -> [TyCoVar] --- See Note [Free variables of types] +-- See Note [Computing deep free variables] tyCoVarsOfCoList ty = dVarSetElems $ tyCoVarsOfCoDSet ty -- | Returns free variables of types, including kind variables as -- a deterministically ordered list. For type synonyms it does /not/ expand the -- synonym. tyCoVarsOfTypesList :: [Type] -> [TyCoVar] --- See Note [Free variables of types] +-- See Note [Computing deep free variables] tyCoVarsOfTypesList tys = dVarSetElems $ tyCoVarsOfTypesDSet tys -detTyCoVarsOfType :: Type -> DTyCoFVRes -detTyCoVarsOfTypes :: [Type] -> DTyCoFVRes -detTyCoVarsOfCo :: Coercion -> DTyCoFVRes -(detTyCoVarsOfType, detTyCoVarsOfTypes, detTyCoVarsOfCo, _) - = foldTyCo deepDetTcvFolder +deepDetTypeFV :: Type -> DTyCoFV +deepDetTypesFV :: [Type] -> DTyCoFV +deepDetCoFV :: Coercion -> DTyCoFV +(deepDetTypeFV, deepDetTypesFV, deepDetCoFV, _) = foldTyCo deepDetTcvFolder -deepDetTcvFolder :: TyCoFolder DTyCoFVRes +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_tycobinder = addBndrFVRes } + , tcf_tycobinder = addBndrFV } where - do_tcv = deepDetUnitFVRes detTyCoVarsOfType - do_hole hole = detTyCoVarsOfType (varType (coHoleCoVar hole)) + do_tcv = deepDetUnitFV deepDetTypeFV + do_hole hole = deepDetTypeFV (varType (coHoleCoVar hole)) -deepDetUnitFVRes :: (Type -> DTyCoFVRes) -> TyCoVar -> DTyCoFVRes +deepDetUnitFV :: (Type -> DTyCoFV) -> TyCoVar -> DTyCoFV -- Deal with a single TyCoVar -- Takes a function to find free vars of the kind -deepDetUnitFVRes fvs_of_kind v - = FVRes (\bvs -> EndoOS (do_it bvs)) +-- See Note [Computing deep free variables] +deepDetUnitFV fvs_of_kind v + = MkFV (\bvs -> EndoOS (do_it bvs)) where do_it :: BoundVars -> DTyCoVarSet -> DTyCoVarSet do_it bvs acc | v `elemVarSet` bvs = acc @@ -627,28 +406,28 @@ deepDetUnitFVRes fvs_of_kind v someTyCoVarsOfType :: (TyCoVar -> Bool) -> Type -> [TyCoVar] someTyCoVarsOfType interesting - = runFVSelectiveList interesting . tyCoFVsOfType + = runFVSelectiveList interesting . shallowSelTypeFV someTyCoVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> [TyCoVar] someTyCoVarsOfTypes interesting - = runFVSelectiveList interesting . mapUnionFVRes tyCoFVsOfType + = runFVSelectiveList interesting . mapUnionFV shallowSelTypeFV -tyCoFVsOfType :: Type -> SelectiveFVRes -tyCoFVsOfCo :: Coercion -> SelectiveFVRes +shallowSelTypeFV :: Type -> SelectiveFV +shallowSelCoFV :: Coercion -> SelectiveFV -- Returns shallow free vars --- See Note [Free variables of types] -(tyCoFVsOfType, _, tyCoFVsOfCo, _) = foldTyCo selectiveTcvFolder +-- See Note [Shallow and deep free variables] +(shallowSelTypeFV, _, shallowSelCoFV, _) = foldTyCo selectiveTcvFolder -selectiveTcvFolder :: TyCoFolder SelectiveFVRes +selectiveTcvFolder :: TyCoFolder SelectiveFV -- 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_hole = do_hole - , tcf_tycobinder = addBndrSelectiveFVRes } + , tcf_tycobinder = addBndrSelectiveFV } where - do_tcv v = FVRes (\bvs -> EndoOS (do_it bvs)) + do_tcv v = MkFV (\bvs -> EndoOS (do_it bvs)) where do_it (is_interesting,bvs) acc | not (is_interesting v) = acc -- The "selective" bit @@ -656,7 +435,7 @@ selectiveTcvFolder | v `elemDVarSet` acc = acc | otherwise = acc `extendDVarSet` v - do_hole hole = tyCoFVsOfType (varType (coHoleCoVar hole)) + do_hole hole = shallowSelTypeFV (varType (coHoleCoVar hole)) {- ********************************************************************* @@ -686,24 +465,24 @@ coVarsOfTypes :: [Type] -> CoVarSet coVarsOfCo :: Coercion -> CoVarSet coVarsOfCos :: [Coercion] -> CoVarSet -coVarsOfType ty = runTyCoVars (deep_cv_ty ty) -coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys) -coVarsOfCo co = runTyCoVars (deep_cv_co co) -coVarsOfCos cos = runTyCoVars (deep_cv_cos cos) +coVarsOfType ty = runTyCoVars (deepCoVarTypeFV ty) +coVarsOfTypes tys = runTyCoVars (deepCoVarTypesFV tys) +coVarsOfCo co = runTyCoVars (deepCoVarCoFV co) +coVarsOfCos cos = runTyCoVars (deepCoVarCosFV cos) -type CoVarFVRes = FVRes BoundVars (EndoOS CoVarSet) +type CoVarFV = FV BoundVars (EndoOS CoVarSet) -deep_cv_ty :: Type -> CoVarFVRes -deep_cv_tys :: [Type] -> CoVarFVRes -deep_cv_co :: Coercion -> CoVarFVRes -deep_cv_cos :: [Coercion] -> CoVarFVRes -(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder +deepCoVarTypeFV :: Type -> CoVarFV +deepCoVarTypesFV :: [Type] -> CoVarFV +deepCoVarCoFV :: Coercion -> CoVarFV +deepCoVarCosFV :: [Coercion] -> CoVarFV +(deepCoVarTypeFV, deepCoVarTypesFV, deepCoVarCoFV, deepCoVarCosFV) = foldTyCo deepCoVarFolder -deepCoVarFolder :: TyCoFolder CoVarFVRes +deepCoVarFolder :: TyCoFolder CoVarFV deepCoVarFolder = TyCoFolder { tcf_view = noView , tcf_tyvar = do_tyvar, tcf_covar = do_covar , tcf_hole = do_hole - , tcf_tycobinder = addBndrFVRes } + , tcf_tycobinder = addBndrFV } where do_tyvar _ = mempty -- This do_tyvar means we won't see any CoVars in this @@ -712,14 +491,14 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView -- the tyvar won't end up in the accumulator, so -- we'd look repeatedly. Blargh. - do_covar = deepUnitFVRes deep_cv_ty + do_covar = deepUnitFV deepCoVarTypeFV do_hole hole = do_covar (coHoleCoVar hole) -- We /do/ treat a CoercionHole as a free variable -- See Note [CoercionHoles and coercion free variables] -------------- Deterministic versions ------------------ -type DCoVarFVRes = FVRes BoundVars (EndoOS DCoVarSet) +type DCoVarFV = FV BoundVars (EndoOS DCoVarSet) coVarsOfCoDSet :: Coercion -> DCoVarSet coVarsOfCoDSet co = runTyCoVarsDSet (det_co co) @@ -727,23 +506,23 @@ coVarsOfCoDSet co = runTyCoVarsDSet (det_co co) coVarsOfCosDSet :: [Coercion] -> DCoVarSet coVarsOfCosDSet cos = runTyCoVarsDSet (det_cos cos) -det_ty :: Type -> DCoVarFVRes -det_co :: Coercion -> DCoVarFVRes -det_cos :: [Coercion] -> DCoVarFVRes +det_ty :: Type -> DCoVarFV +det_co :: Coercion -> DCoVarFV +det_cos :: [Coercion] -> DCoVarFV (det_ty, _, det_co, det_cos) = foldTyCo deepDetCoVarFolder -deepDetCoVarFolder :: TyCoFolder DCoVarFVRes +deepDetCoVarFolder :: TyCoFolder DCoVarFV -- Follows deepCoVarFolders, but returns a /deterministic/ set deepDetCoVarFolder = TyCoFolder { tcf_view = noView , tcf_tyvar = do_tyvar , tcf_covar = do_covar , tcf_hole = do_hole - , tcf_tycobinder = addBndrFVRes } + , tcf_tycobinder = addBndrFV } where do_tyvar _ = mempty - do_covar :: CoVar -> DCoVarFVRes - do_covar = deepDetUnitFVRes det_ty + do_covar :: CoVar -> DCoVarFV + do_covar = deepDetUnitFV det_ty do_hole hole = do_covar (coHoleCoVar hole) @@ -768,7 +547,7 @@ closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs closeOverKindsDSet :: DTyVarSet -> DTyVarSet closeOverKindsDSet vs = nonDetStrictFoldDVarSet do_one vs vs where - do_one v = runFVAcc (detTyCoVarsOfType (varType v)) + do_one v = runFVAcc (deepDetTypeFV (varType v)) {- --------------- Alternative version 1 (using FV) ------------ closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet @@ -1033,18 +812,18 @@ injectiveVarsOfTypes :: Bool -- ^ look under injective type families? -- in "GHC.Tc.Instance.Family". -> [Type] -> VarSet injectiveVarsOfTypes look_under_tfs tys - = runTyCoVars $ mapUnionFVRes (inj_vars_of_type look_under_tfs) tys + = runTyCoVars $ mapUnionFV (inj_vars_of_type look_under_tfs) tys -inj_vars_of_type :: Bool -> Type -> TyCoFVRes +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) = deepUnitFVRes go v + go (TyVarTy v) = deepUnitFV go 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 go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `mappend` - addBndrFVRes tv (go ty) + addBndrFV tv (go ty) go LitTy{} = mempty go (CastTy ty _) = go ty go CoercionTy{} = mempty @@ -1053,7 +832,7 @@ inj_vars_of_type look_under_tfs = go | isTypeFamilyTyCon tc = if | look_under_tfs , Injective flags <- tyConInjectivityInfo tc - -> mapUnionFVRes go $ + -> mapUnionFV go $ filterByList (flags ++ repeat True) tys -- Oversaturated arguments to a tycon are -- always injective, hence the repeat True @@ -1061,7 +840,7 @@ inj_vars_of_type look_under_tfs = go -> mempty | otherwise -- Data type, injective in all positions - = mapUnionFVRes go tys + = mapUnionFV go tys @@ -1110,15 +889,15 @@ invisibleVarsOfTypes = foldr (unionVarSet . invisibleVarsOfType) emptyVarSet ********************************************************************* -} {-# INLINE afvFolder #-} -- so that specialization to (const True) works -afvFolder :: (TyCoVar -> Bool) -> TyCoFolder (FVRes TyCoVarSet DM.Any) +afvFolder :: (TyCoVar -> Bool) -> TyCoFolder (FV TyCoVarSet DM.Any) -- 'afvFolder' is short for "any-free-var folder", good for checking -- if any free var of a type satisfies a predicate `check_fv` afvFolder check_fv = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole - , tcf_tycobinder = addBndrFVRes } + , tcf_tycobinder = addBndrFV } where - do_tcv tv = FVRes $ \ bvs -> + do_tcv tv = MkFV $ \ bvs -> Any (not (tv `elemVarSet` bvs) && check_fv tv) do_hole _ = mempty -- I'm unsure; probably never happens ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -159,11 +159,8 @@ module GHC.Core.Type ( liftedTypeKind, unliftedTypeKind, -- * Type free variables - tyCoFVsOfType, - tyCoVarsOfType, tyCoVarsOfTypes, - tyCoVarsOfTypeDSet, - coVarsOfType, - coVarsOfTypes, + tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeDSet, + coVarsOfType, coVarsOfTypes, anyFreeVarsOfType, anyFreeVarsOfTypes, noFreeVarsOfType, ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -23,7 +23,6 @@ import GHC.Core.DataCon ( dataConWrapperType ) import GHC.Core.Type ( Type, ForAllTyFlag(..) ) import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) import GHC.Core.InstEnv -import GHC.Core.TyCo.FVs import GHC.Core.Predicate ( isEvId ) import GHC.Hs @@ -40,6 +39,7 @@ import GHC.Types.Name.Reader ( RecFieldInfo(..), WithUserRdr(..) ) import GHC.Types.SrcLoc import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) import GHC.Types.Var.Env +import GHC.Types.Var.FV import GHC.Tc.Types import GHC.Tc.Types.Evidence ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -37,7 +37,6 @@ import GHC.Core.DataCon ( dataConConcreteTyVars, isNewDataCon, dataConOrigArgTys import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr -import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Subst ( substTyWithInScope ) import GHC.Core.Type import GHC.Core.Coercion @@ -47,6 +46,7 @@ import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names import GHC.Types.Var +import GHC.Types.Var.FV import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Reader @@ -2082,7 +2082,7 @@ foldQLInstVars check_tv ty where (do_ty, _, _, _) = foldTyCo folder - folder :: TyCoFolder (FVRes () a) + folder :: TyCoFolder (FV () a) folder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] -- in GHC.Core.TyCo.FVs , tcf_tyvar = do_tv, tcf_covar = mempty @@ -2093,8 +2093,8 @@ foldQLInstVars check_tv ty do_hole hole = do_ty (coVarKind (coHoleCoVar hole)) -- See (MIV2) in Note [Monomorphise instantiation variables] - do_tv :: TcTyVar -> FVRes () a - do_tv tv | isQLInstTyVar tv = FVRes $ \_ -> check_tv tv + do_tv :: TcTyVar -> FV () a + do_tv tv | isQLInstTyVar tv = MkFV $ \_ -> check_tv tv | otherwise = mempty {- ********************************************************************* ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -117,6 +117,7 @@ import GHC.Core.TyCo.FVs import GHC.Types.Name import GHC.Types.Var +import GHC.Types.Var.FV import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence @@ -809,7 +810,7 @@ tyCoVarsOfCtList :: Ct -> [TcTyCoVar] tyCoVarsOfCtList = tyCoVarsOfTypeList . ctPred -- | Returns free variables of constraints as a deterministically ordered --- list. See Note [Deterministic FV] in GHC.Utils.FV. +-- list. See Note [Deterministic FV] in GHC.Types.Var.FV. tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar] tyCoVarsOfCtEvList = tyCoVarsOfTypeList . ctEvPred @@ -819,49 +820,49 @@ tyCoVarsOfCts :: Cts -> TcTyCoVarSet tyCoVarsOfCts = dVarSetToVarSet . runTyCoVarsDSet . tcvs_of_cts -- | Returns free variables of a bag of constraints as a deterministically --- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +-- ordered list. See Note [Deterministic FV] in "GHC.Types.Var.FV". tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] tyCoVarsOfCtsList = dVarSetElems . tyCoVarsOfThingsDSet ctPred -- | Returns free variables of a bag of constraints as a deterministically --- ordered list. See Note [Deterministic FV] in GHC.Utils.FV. +-- ordered list. See Note [Deterministic FV] in GHC.Types.Var.FV. tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar] tyCoVarsOfCtEvsList = dVarSetElems . runTyCoVarsDSet - . mapUnionFVRes (detTyCoVarsOfType . ctEvPred) + . mapUnionFV (deepDetTypeFV . ctEvPred) -- | Returns free variables of WantedConstraints as a non-deterministic --- set. See Note [Deterministic FV] in "GHC.Utils.FV". +-- set. See Note [Deterministic FV] in "GHC.Types.Var.FV". tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet -- Only called on *zonked* things tyCoVarsOfWC = dVarSetToVarSet . tyCoVarsOfWcDSet -- | Returns free variables of WantedConstraints as a deterministically --- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +-- ordered list. See Note [Deterministic FV] in "GHC.Types.Var.FV". tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] -- Only called on *zonked* things tyCoVarsOfWCList = dVarSetElems . tyCoVarsOfWcDSet -- | Returns free variables of WantedConstraints as a composable FV --- computation. See Note [Deterministic FV] in "GHC.Utils.FV". +-- computation. See Note [Deterministic FV] in "GHC.Types.Var.FV". tyCoVarsOfWcDSet :: WantedConstraints -> DTyCoVarSet -- Only called on *zonked* things tyCoVarsOfWcDSet = runTyCoVarsDSet . tcvs_of_wc -tcvs_of_wc :: WantedConstraints -> DTyCoFVRes +tcvs_of_wc :: WantedConstraints -> DTyCoFV tcvs_of_wc (WC { wc_simple = simple, wc_impl = implics, wc_errors = errors }) = tcvs_of_cts simple `mappend` - mapUnionFVRes tcvs_of_implic implics `mappend` - mapUnionFVRes tcvs_of_errs errors + mapUnionFV tcvs_of_implic implics `mappend` + mapUnionFV tcvs_of_errs errors -tcvs_of_cts :: Cts -> DTyCoFVRes -tcvs_of_cts = mapUnionFVRes tcvs_of_ct +tcvs_of_cts :: Cts -> DTyCoFV +tcvs_of_cts = mapUnionFV tcvs_of_ct -tcvs_of_ct :: Ct -> DTyCoFVRes -tcvs_of_ct ct = detTyCoVarsOfType (ctPred ct) +tcvs_of_ct :: Ct -> DTyCoFV +tcvs_of_ct ct = deepDetTypeFV (ctPred ct) -- | Returns free variables of Implication as a composable FV computation. --- See Note [Deterministic FV] in "GHC.Utils.FV". -tcvs_of_implic :: Implication -> DTyCoFVRes +-- See Note [Deterministic FV] in "GHC.Types.Var.FV". +tcvs_of_implic :: Implication -> DTyCoFV -- Only called on *zonked* things tcvs_of_implic (Implic { ic_skols = skols , ic_given = givens @@ -869,17 +870,17 @@ tcvs_of_implic (Implic { ic_skols = skols | isEmptyWC wanted = mempty | otherwise - = addBndrsFVRes skols $ - addBndrsFVRes givens $ + = addBndrsFV skols $ + addBndrsFV givens $ tcvs_of_wc wanted -tcvs_of_errs :: DelayedError -> DTyCoFVRes +tcvs_of_errs :: DelayedError -> DTyCoFV tcvs_of_errs (DE_Hole hole) = tcvs_of_hole hole tcvs_of_errs (DE_NotConcrete {}) = mempty -tcvs_of_errs (DE_Multiplicity co _) = detTyCoVarsOfCo co +tcvs_of_errs (DE_Multiplicity co _) = deepDetCoFV co -tcvs_of_hole :: Hole -> DTyCoFVRes -tcvs_of_hole (Hole { hole_ty = ty }) = detTyCoVarsOfType ty +tcvs_of_hole :: Hole -> DTyCoFV +tcvs_of_hole (Hole { hole_ty = ty }) = deepDetTypeFV ty {- ************************************************************************ ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -64,7 +64,6 @@ import GHC.Core.Ppr () -- Instance OutputableBndr TyVar import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.TyCo.Rep (UnivCoProvenance(..)) -import GHC.Core.TyCo.FVs import GHC.Core.TyCon import GHC.Core.Make ( mkWildCase, mkRuntimeErrorApp, tYPE_ERROR_ID ) import GHC.Core.Class ( classTyCon ) @@ -80,6 +79,7 @@ import GHC.Types.Var import GHC.Types.Id( idType ) import GHC.Types.Var.Env import GHC.Types.Var.Set +import GHC.Types.Var.FV import GHC.Types.Basic import GHC.Builtin.Names @@ -1318,25 +1318,25 @@ nestedEvIdsOfTerm :: EvTerm -> VarSet -- Returns only EvIds satisfying relevantEvId nestedEvIdsOfTerm = runFVSelectiveSet isNestedEvId . evTermFVs -evTermFVs :: EvTerm -> SelectiveFVRes +evTermFVs :: EvTerm -> SelectiveFV evTermFVs (EvExpr e) = exprFVs e evTermFVs (EvTypeable _ ev) = evFVsOfTypeable ev evTermFVs (EvFun { et_tvs = tvs, et_given = given , et_binds = tc_ev_binds, et_body = v }) = case tc_ev_binds of TcEvBinds {} -> mempty -- See Note [Free vars of EvFun] - EvBinds binds -> addBndrsFV bndrs fvs + EvBinds binds -> addBndrsSelectiveFV bndrs fvs where fvs = foldr (mappend . evTermFVs . eb_rhs) (unitFV v) binds bndrs = foldr ((:) . eb_lhs) (tvs ++ given) binds -evTermFVss :: [EvTerm] -> SelectiveFVRes -evTermFVss = mapUnionFVRes evTermFVs +evTermFVss :: [EvTerm] -> SelectiveFV +evTermFVss = mapUnionFV evTermFVs -evFVsOfTypeable :: EvTypeable -> SelectiveFVRes +evFVsOfTypeable :: EvTypeable -> SelectiveFV evFVsOfTypeable ev = case ev of - EvTypeableTyCon _ e -> mapUnionFVRes evTermFVs e + EvTypeableTyCon _ e -> mapUnionFV evTermFVs e EvTypeableTyApp e1 e2 -> evTermFVss [e1,e2] EvTypeableTrFun em e1 e2 -> evTermFVss [em,e1,e2] EvTypeableTyLit e -> evTermFVs e ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -1565,7 +1565,7 @@ against any specification -- just suboptimal and confounding to users. Note [Recurring into kinds for candidateQTyVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying +First, read Note [Computing deep free variables] in GHC.Core.TyCo.FVs, paying attention to the end of the Note about using an empty bound set when traversing a variable's kind. @@ -1582,7 +1582,7 @@ type inference, which is seeded by the renamer and its insistence to use different Uniques for different variables. (In contrast, the Core functions work on the output of optimizations, which may introduce shadowing.) Without shadowing, the problem studied by -Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. +Note [Computing deep free variables] in GHC.Core.TyCo.FVs cannot happen. Why it is necessary: Wiping the bound set would be just plain wrong here. Consider @@ -1593,7 +1593,7 @@ We really don't want to think k1 and k2 are free here. (It's true that we'll never be able to fill in `hole`, but we don't want to go off the rails just because we have an insoluble coercion hole.) So: why is it wrong to wipe the bound variables here but right in Core? Because the final statement -in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not +in Note [Computing deep free variables] in GHC.Core.TyCo.FVs is wrong: not every variable is either free or bound. A variable can be a hole, too! The reasoning in that Note then breaks down. ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -219,16 +219,17 @@ import {-# SOURCE #-} GHC.Tc.Types.Origin ( SkolemInfo, unkSkol , FixedRuntimeRepOrigin, FixedRuntimeRepContext ) --- others: +import GHC.Types.Var.FV import GHC.Types.Name as Name -- We use this to make dictionaries for type literals. -- Perhaps there's a better way to do this? import GHC.Types.Name.Env import GHC.Types.Name.Set +import GHC.Types.Basic + import GHC.Builtin.Names import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyConKey , listTyCon, constraintKind ) -import GHC.Types.Basic import GHC.Data.Maybe import GHC.Data.List.SetOps ( getNth, findDupsEq ) @@ -1178,11 +1179,11 @@ exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet exactTyCoVarsOfType ty = runTyCoVars (exact_ty ty) exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys) -exact_ty :: Type -> TyCoFVRes -exact_tys :: [Type] -> TyCoFVRes +exact_ty :: Type -> TyCoFV +exact_tys :: [Type] -> TyCoFV (exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder -exactTcvFolder :: TyCoFolder TyCoFVRes +exactTcvFolder :: TyCoFolder TyCoFV exactTcvFolder = deepTcvFolder { tcf_view = coreView } -- This is the key line ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -101,6 +101,7 @@ import GHC.Types.Id( idType ) import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env +import GHC.Types.Var.FV import GHC.Types.Basic import GHC.Types.Unique.Set (nonDetEltsUniqSet) @@ -3572,20 +3573,20 @@ mkOccFolders :: Name -> (TcType -> Bool, TcCoercion -> Bool) mkOccFolders lhs_tv = ( getAny . runFVTop . check_ty , getAny . runFVTop . check_co) where - check_ty :: Type -> FVRes BoundVars Any + check_ty :: Type -> FV BoundVars Any !(check_ty, _, check_co, _) = foldTyCo occ_folder - occ_folder :: TyCoFolder (FVRes BoundVars Any) + occ_folder :: TyCoFolder (FV BoundVars Any) occ_folder = TyCoFolder { tcf_view = noView -- Don't expand synonyms , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole - , tcf_tycobinder = addBndrFVRes } + , tcf_tycobinder = addBndrFV } - do_tcv v = (FVRes $ \ bvs -> + do_tcv v = (MkFV $ \ bvs -> Any (not (v `elemVarSet` bvs) && tyVarName v == lhs_tv)) `mappend` check_ty (varType v) - do_hole _hole = FVRes $ \ _bvs -> DM.Any True -- Reject coercion holes + do_hole _hole = MkFV $ \ _bvs -> DM.Any True -- Reject coercion holes {- ********************************************************************* * * ===================================== compiler/GHC/Utils/EndoOS.hs ===================================== @@ -1,12 +1,13 @@ {-# LANGUAGE PatternSynonyms #-} -- | One-shot endomorphisms --- Mostly for backwards compatibility. -- One-shot endomorphisms -- Like GHC.Internal.Data.Semigroup.Internal.Endo, but using -- the one-shot trick from -- Note [The one-shot state monad trick] in GHC.Utils.Monad. +-- +-- It is also strict: see the (<>) method in he Semigroup instance module GHC.Utils.EndoOS( EndoOS(EndoOS, runEndoOS ), foldEndoOS ) where @@ -19,13 +20,21 @@ newtype EndoOS a = EndoOS' { runEndoOS :: a -> a } instance Semigroup (EndoOS a) where - f <> g = EndoOS (\x -> runEndoOS f $! (runEndoOS g x)) - -- Strict application, to avoid thunk creation + EndoOS' f <> EndoOS' g = EndoOS (\x -> g $! f x) + -- NB1: Strict application, to avoid thunk creation + -- See (FV3) in Note [Finding free variables] + -- in GHC.Types.Var.FV + -- NB2: We apply `f` to the acccumulator first, then `g` + -- So if we traverse a type left-to-right, the insertion + -- order for (say) free type variables is left-to-right + -- See (FV4) in Note [Finding free variables] + -- in GHC.Types.Var.FV instance Monoid (EndoOS a) where mempty = EndoOS id pattern EndoOS :: (a->a) -> EndoOS a +{-# COMPLETE EndoOS #-} pattern EndoOS f <- EndoOS' f where EndoOS f = EndoOS' (oneShot f) ===================================== compiler/GHC/Utils/FV.hs deleted ===================================== @@ -1,202 +0,0 @@ -{- -(c) Bartosz Nitka, Facebook 2015 - --} - --- | Utilities for efficiently and deterministically computing free variables. -module GHC.Utils.FV ( - -- * Deterministic free vars computations - FV, InterestingVarFun, - - -- * Running the computations - fvVarList, fvVarSet, fvDVarSet, - - -- ** Manipulating those computations - unitFV, - emptyFV, - mkFVs, - unionFV, - unionsFV, - delFV, - delFVs, - filterFV, - mapUnionFV, - fvDVarSetSome, - ) where - -import GHC.Prelude - -import GHC.Types.Var -import GHC.Types.Var.Set - --- | Predicate on possible free variables: returns @True@ iff the variable is --- interesting -type InterestingVarFun = Var -> Bool - --- Note [Deterministic FV] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- When computing free variables, the order in which you get them affects --- the results of floating and specialization. If you use UniqFM to collect --- them and then turn that into a list, you get them in nondeterministic --- order as described in Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. - --- A naive algorithm for free variables relies on merging sets of variables. --- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log --- factor. It's cheaper to incrementally add to a list and use a set to check --- for duplicates. -type FV = InterestingVarFun -- Used for filtering sets as we build them - -> VarSet -- Locally bound variables - -> VarAcc -- Accumulator - -> VarAcc - -type VarAcc = ([Var], VarSet) -- List to preserve ordering and set to check for membership, - -- so that the list doesn't have duplicates - -- For explanation of why using `VarSet` is not deterministic see - -- Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. - --- Note [FV naming conventions] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- To get the performance and determinism that FV provides, FV computations --- need to built up from smaller FV computations and then evaluated with --- one of `fvVarList`, `fvDVarSet` That means the functions --- returning FV need to be exported. --- --- The conventions are: --- --- a) non-deterministic functions: --- * a function that returns VarSet --- e.g. `tyVarsOfType` --- b) deterministic functions: --- * a worker that returns FV --- e.g. `tyFVsOfType` --- * a function that returns [Var] --- e.g. `tyVarsOfTypeList` --- * a function that returns DVarSet --- e.g. `tyVarsOfTypeDSet` --- --- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented --- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet --- respectively. - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order and a non-deterministic set containing --- those variables. -fvVarAcc :: FV -> ([Var], VarSet) -fvVarAcc fv = fv (const True) emptyVarSet ([], emptyVarSet) - --- | Run a free variable computation, returning a list of distinct free --- variables in deterministic order. -fvVarList :: FV -> [Var] -fvVarList = fst . fvVarAcc - --- | Run a free variable computation, returning a deterministic set of free --- variables. Note that this is just a wrapper around the version that --- returns a deterministic list. If you need a list you should use --- `fvVarList`. -fvDVarSet :: FV -> DVarSet -fvDVarSet = mkDVarSet . fvVarList - --- | Run a free variable computation, returning a non-deterministic set of --- free variables. Don't use if the set will be later converted to a list --- and the order of that list will impact the generated code. -fvVarSet :: FV -> VarSet -fvVarSet = snd . fvVarAcc - --- Note [FV eta expansion] --- ~~~~~~~~~~~~~~~~~~~~~~~ --- Let's consider an eta-reduced implementation of freeVarsOf using FV: --- --- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b --- --- If GHC doesn't eta-expand it, after inlining unionFV we end up with --- --- freeVarsOf = \x -> --- case x of --- App a b -> \fv_cand in_scope acc -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which has to create a thunk, resulting in more allocations. --- --- On the other hand if it is eta-expanded: --- --- freeVarsOf (App a b) fv_cand in_scope acc = --- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc --- --- after inlining unionFV we have: --- --- freeVarsOf = \x fv_cand in_scope acc -> --- case x of --- App a b -> --- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc --- --- which saves allocations. --- --- GHC when presented with knowledge about all the call sites, correctly --- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets --- exported to be composed with other functions, GHC doesn't have that --- information and has to be more conservative here. --- --- Hence functions that get exported and return FV need to be manually --- eta-expanded. See also #11146. - --- | Add a variable - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -unitFV :: Id -> FV -unitFV var fv_cand in_scope acc@(have, haveSet) - | var `elemVarSet` in_scope = acc - | var `elemVarSet` haveSet = acc - | fv_cand var = (var:have, extendVarSet haveSet var) - | otherwise = acc -{-# INLINE unitFV #-} - --- | Return no free variables. -emptyFV :: FV -emptyFV _ _ acc = acc -{-# INLINE emptyFV #-} - --- | Union two free variable computations. -unionFV :: FV -> FV -> FV -unionFV fv1 fv2 fv_cand in_scope acc = - fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc -{-# INLINE unionFV #-} - --- | Mark the variable as not free by putting it in scope. -delFV :: Var -> FV -> FV -delFV var fv fv_cand !in_scope acc = - fv fv_cand (extendVarSet in_scope var) acc -{-# INLINE delFV #-} - --- | Mark many free variables as not free. -delFVs :: VarSet -> FV -> FV -delFVs vars fv fv_cand !in_scope acc = - fv fv_cand (in_scope `unionVarSet` vars) acc -{-# INLINE delFVs #-} - --- | Filter a free variable computation. -filterFV :: InterestingVarFun -> FV -> FV -filterFV fv_cand2 fv fv_cand1 in_scope acc = - fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc -{-# INLINE filterFV #-} - --- | Map a free variable computation over a list and union the results. -mapUnionFV :: (a -> FV) -> [a] -> FV -mapUnionFV _f [] _fv_cand _in_scope acc = acc -mapUnionFV f (a:as) fv_cand in_scope acc = - mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc -{-# INLINABLE mapUnionFV #-} - --- | Union many free variable computations. -unionsFV :: [FV] -> FV -unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc -{-# INLINE unionsFV #-} - --- | Add multiple variables - when free, to the returned free variables. --- Ignores duplicates and respects the filtering function. -mkFVs :: [Var] -> FV -mkFVs vars fv_cand in_scope acc = - mapUnionFV unitFV vars fv_cand in_scope acc -{-# INLINE mkFVs #-} - -fvDVarSetSome :: InterestingVarFun -> FV -> DVarSet -fvDVarSetSome interesting_var fv = - mkDVarSet $ fst $ fv interesting_var emptyVarSet ([], emptyVarSet) ===================================== compiler/ghc.cabal.in ===================================== @@ -951,6 +951,7 @@ Library GHC.Types.Var GHC.Types.Var.Env GHC.Types.Var.Set + GHC.Types.Var.FV GHC.Unit GHC.Unit.Env GHC.Unit.External @@ -992,7 +993,6 @@ Library GHC.Utils.EndoOS GHC.Utils.Exception GHC.Utils.Fingerprint - GHC.Utils.FV GHC.Utils.GlobalVars GHC.Utils.IO.Unsafe GHC.Utils.Json ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -43,7 +43,8 @@ import qualified Data.Set as Set import GHC hiding (HsTypeGhcPsExt (..)) import GHC.Builtin.Types (liftedRepTy) import GHC.Core.TyCo.Rep (Type (..)) -import GHC.Core.Type (binderVar, isRuntimeRepVar) +import GHC.Core.TyCo.FVs ( deepDetTypesFV ) +import GHC.Core.Type (isRuntimeRepVar) import GHC.Data.StringBuffer (StringBuffer) import qualified GHC.Data.StringBuffer as S import GHC.Driver.Session @@ -52,17 +53,11 @@ import GHC.Types.Name import GHC.Types.SrcLoc (advanceSrcLoc) import GHC.Types.SourceText (SourceText(..)) import GHC.Types.Var - ( Specificity - , TyVarBinder - , VarBndr (..) - , isInvisibleForAllTyFlag - , tyVarKind - , updateTyVarKind - ) -import GHC.Types.Var.Env (TyVarEnv, elemVarEnv, emptyVarEnv, extendVarEnv) -import GHC.Types.Var.Set (VarSet, emptyVarSet) -import GHC.Utils.FV as FV +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Var.FV import GHC.Utils.Outputable (Outputable, SDocContext, ppr) +import GHC.Utils.EndoOS import qualified GHC.Utils.Outputable as Outputable import GHC.Utils.Panic (panic) @@ -86,6 +81,7 @@ filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig filterSigNames p (FixSig _ (FixitySig ns_spec ns ty)) = case filter (p . unLoc) ns of + [] -> Nothing filtered -> Just (FixSig noAnn (FixitySig ns_spec filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig @@ -817,66 +813,14 @@ isTypeHidden expInfo = typeHidden -- | Get free type variables in a 'Type' in their order of appearance. -- See [Ordering of implicit variables]. orderedFVs - :: VarSet - -- ^ free variables to ignore - -> [Type] - -- ^ types to traverse (in order) looking for free variables - -> [TyVar] - -- ^ free type variables, in the order they appear in -orderedFVs vs tys = - reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet) - --- See the "Free variables of types and coercions" section in 'TyCoRep', or --- check out Note [Free variables of types]. The functions in this section --- don't output type variables in the order they first appear in in the 'Type'. --- --- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type --- of 'const :: a -> b -> a': --- --- >>> import GHC.Types.Name --- >>> import TyCoRep --- >>> import GHC.Builtin.Types.Prim --- >>> import GHC.Types.Var --- >>> a = TyVarTy alphaTyVar --- >>> b = TyVarTy betaTyVar --- >>> constTy = mkFunTys [a, b] a --- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy) --- ["b","a"] --- --- However, we want to reuse the very optimized traversal machinery there, so --- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`. --- All these do differently is traverse in a different order and ignore --- coercion variables. - --- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order --- of appearance. -tyCoFVsOfType' :: Type -> FV -tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c -tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c -tyCoFVsOfType' (LitTy{}) a b c = emptyFV a b c -tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c -tyCoFVsOfType' (FunTy _ w arg res) a b c = - ( tyCoFVsOfType' res - `unionFV` tyCoFVsOfType' w - `unionFV` tyCoFVsOfType' arg - ) - a - b - c -tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c -tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c -tyCoFVsOfType' (CoercionTy _) a b c = emptyFV a b c - --- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order --- of appearance. -tyCoFVsOfTypes' :: [Type] -> FV -tyCoFVsOfTypes' (ty : tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc -tyCoFVsOfTypes' [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc - --- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of --- appearance. -tyCoFVsBndr' :: TyVarBinder -> FV -> FV -tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv) + :: VarSet -- ^ Free variables to ignore + -> [Type] -- ^ Types to traverse (in order) looking for free variables + -> [TyVar] -- ^ Free type variables, /in the order in which they appear/ +orderedFVs ignore_tvs tys + = dVarSetElems (runEndoOS (runFV get_fvs ignore_tvs) emptyDVarSet) + where + get_fvs :: DVarSetFV + get_fvs = deepDetTypesFV tys ------------------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3f56f61a8433319d611f292ddae0c14... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3f56f61a8433319d611f292ddae0c14... You're receiving this email because of your account on gitlab.haskell.org.