Simon Peyton Jones pushed to branch wip/T26543b at Glasgow Haskell Compiler / GHC Commits: e2f4f707 by Simon Peyton Jones at 2026-09-09T10:09:22+01:00 Improve the atvFolder stuff ...to use the same idiom that we already use in exprFreeVars. - - - - - 3 changed files: - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Types/Var/FV.hs Changes: ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -223,11 +223,11 @@ addCoreBndrsFV bndrs fv = foldr addCoreBndrFV fv bndrs unitFV :: Var -> SelectiveDFV -- Deals with an occurrence -- Shallow: does not look at the kind -unitFV v = MkFV (\bvs -> EndoOS (do_it bvs)) +unitFV v = MkFV (\env -> EndoOS (do_it env)) where - do_it (is_interesting,bvs) acc + do_it (bvs, is_interesting) acc + | v `elemVarSet` bvs = acc -- First exclude the bound vars | not (is_interesting v) = acc -- The "selective" bit - | v `elemVarSet` bvs = acc | v `elemDVarSet` acc = acc | otherwise = acc `extendDVarSet` v ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -443,11 +443,11 @@ selectiveTcvFolder , tcf_hole = do_hole , tcf_tycobinder = addBndrSelectiveFV } where - do_tcv v = MkFV (\bvs -> EndoOS (do_it bvs)) + do_tcv v = MkFV (\env -> EndoOS (do_it env)) where - do_it (is_interesting,bvs) acc + do_it (bvs,is_interesting) acc + | v `elemVarSet` bvs = acc -- First exclude bound variables | not (is_interesting v) = acc -- The "selective" bit - | v `elemVarSet` bvs = acc | v `elemDVarSet` acc = acc | otherwise = acc `extendDVarSet` v @@ -847,43 +847,67 @@ invisibleVarsOfTypes = foldr (unionVarSet . invisibleVarsOfType) emptyVarSet * * ********************************************************************* -} -{-# INLINE afvFolder #-} -- so that specialization to (const True) works -afvFolder :: (TyCoVar -> Bool) -> TyCoFolder (FV TyCoVarSet DM.Any) +{- Note [Any-free-var folder] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "any-free-var" folders take a `check_fv` predicate (TyCoVar -> Bool) and +check if any free variable of the type/coercion satisfies it. Our main folders +look like: + + afv_type :: Type -> FV (BoundVars, TyVar -> Bool) Any + +where we cleverly pair the predicate with the forall-bound variables of the type +in the "env" field of (FV env Any). This way we can build the /folder/ once and +for all (independent of the `check_fv` predicate), and the loop passes down +the pair. + +The same idiom is used in `exprFreeVarsDSet` and friends. + +However we are careful to inline `atvFolder` and `runAny` so that we get those +nice tight loops. +-} + +{-# INLINE afvFolder #-} -- See Note [Inlining any-fvs] +afvFolder :: TyCoFolder (FV (BoundVars, TyCoVar -> Bool) DM.Any) -- 'afvFolder' is short for "any-free-var folder", good for checking --- if any shallow 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 = addBndrFV } +-- if any shallow free var of a type satisfies a predicate `check_fv` +-- The "env" of the (FV env Any) is a pair (bvs,pred) of +-- the bound variables (which are definitely not free), and +-- an "interesting var" predicate which the client supplies +afvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole + , tcf_tycobinder = addBndrSelectiveFV } where - do_tcv tv = MkFV $ \ bvs -> + do_tcv tv = MkFV $ \ (bvs,check_fv) -> Any (not (tv `elemVarSet` bvs) && check_fv tv) do_hole hole = do_tcv (coHoleCoVar hole) +afv_type :: Type -> FV (BoundVars, TyVar -> Bool) DM.Any +afv_types :: [Type] -> FV (BoundVars, TyVar -> Bool) DM.Any +afv_co :: Coercion -> FV (BoundVars, TyVar -> Bool) DM.Any +(afv_type, afv_types, afv_co, _) = foldTyCo afvFolder + +runAny :: (TyVar -> Bool) -> FV (BoundVars, TyCoVar -> Bool) DM.Any -> Bool +{-# INLINE runAny #-} +runAny check_fv fvs = DM.getAny $ runFV fvs (emptyVarSet, check_fv) + anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool -anyFreeVarsOfType check_fv ty = DM.getAny (runFVTop (f ty)) - where (f, _, _, _) = foldTyCo (afvFolder check_fv) +anyFreeVarsOfType check_fv ty = runAny check_fv (afv_type ty) anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool -anyFreeVarsOfTypes check_fv tys = DM.getAny (runFVTop (f tys)) - where (_, f, _, _) = foldTyCo (afvFolder check_fv) +anyFreeVarsOfTypes check_fv tys = runAny check_fv (afv_types tys) anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool -anyFreeVarsOfCo check_fv co = DM.getAny (runFVTop (f co)) - where (_, _, f, _) = foldTyCo (afvFolder check_fv) +anyFreeVarsOfCo check_fv co = runAny check_fv (afv_co co) noFreeVarsOfType :: Type -> Bool -noFreeVarsOfType ty = not $ DM.getAny (runFVTop (f ty)) - where (f, _, _, _) = foldTyCo (afvFolder (const True)) +noFreeVarsOfType ty = not $ runAny (const True) (afv_type ty) noFreeVarsOfTypes :: [Type] -> Bool -noFreeVarsOfTypes tys = not $ DM.getAny (runFVTop (f tys)) - where (_, f, _, _) = foldTyCo (afvFolder (const True)) +noFreeVarsOfTypes tys = not $ runAny (const True) (afv_types tys) noFreeVarsOfCo :: Coercion -> Bool -noFreeVarsOfCo co = not $ DM.getAny (runFVTop (f co)) - where (_, _, f, _) = foldTyCo (afvFolder (const True)) - +noFreeVarsOfCo co = not $ runAny (const True) (afv_co co) {- ************************************************************************ ===================================== compiler/GHC/Types/Var/FV.hs ===================================== @@ -9,7 +9,7 @@ module GHC.Types.Var.FV ( runFVSelective, runFVSelectiveList, runFVSelectiveSet, InterestingVarFun, - addBndrFV, addBndrsFV, addBndrSelectiveFV, addBndrsSelectiveFV, + updEnvFV, addBndrFV, addBndrsFV, addBndrSelectiveFV, addBndrsSelectiveFV, emptyFV, -- or `mempty` unionFV, -- or `mappend` mapUnionFV @@ -138,7 +138,7 @@ type BoundVars = TyCoVarSet type VarSetFV = FV BoundVars (EndoOS TyCoVarSet) type DVarSetFV = FV BoundVars (EndoOS DTyCoVarSet) -type SelectiveDFV = FV (InterestingVarFun, BoundVars) (EndoOS DVarSet) +type SelectiveDFV = FV (BoundVars, InterestingVarFun) (EndoOS DVarSet) -- VarSetFV: collects a VarSet -- DVarSetFV: collects a DVarSet (deterministic) -- SelectiveDFV: selectively collects a DVarSet @@ -174,28 +174,28 @@ emptyFV = MkFV (\_ -> mempty) unionFV :: Semigroup a => FV env a -> FV env a -> FV env a unionFV (MkFV' f1) (MkFV' f2) = MkFV (\env -> f1 env <> f2 env) -upd_bndrs_fv :: (env -> env) -> FV env a -> FV env a -{-# INLINE addBndrFV #-} -upd_bndrs_fv upd f = MkFV (\bvs -> runFV f $! upd bvs) +updEnvFV :: (env -> env) -> FV env a -> FV env a +updEnvFV upd f = MkFV (\bvs -> runFV f $! upd bvs) -- Strict application to avoid making a thunk addBndrFV :: TyCoVar -> FV BoundVars a -> FV BoundVars a -addBndrFV tcv = upd_bndrs_fv (\bvs -> extendVarSet bvs tcv) +{-# INLINE addBndrFV #-} +addBndrFV tcv = updEnvFV (\bvs -> extendVarSet bvs tcv) addBndrsFV :: [Var] -> FV BoundVars a -> FV BoundVars a -addBndrsFV tcvs = upd_bndrs_fv (\bvs -> extendVarSetList bvs tcvs) +addBndrsFV tcvs = updEnvFV (\bvs -> extendVarSetList bvs tcvs) -addBndrSelectiveFV :: TyCoVar -> FV (f, BoundVars) a -> FV (f, BoundVars) a +addBndrSelectiveFV :: TyCoVar -> FV (BoundVars, f) a -> FV (BoundVars, f) a addBndrSelectiveFV tcv - = upd_bndrs_fv (\(f,bvs) -> let !bvs' = extendVarSet bvs tcv + = updEnvFV (\(bvs,f) -> let !bvs' = extendVarSet bvs tcv -- Strict let to avoid thunks - in (f,bvs')) + in (bvs',f)) -addBndrsSelectiveFV :: [Var] -> FV (f, BoundVars) a -> FV (f, BoundVars) a +addBndrsSelectiveFV :: [Var] -> FV (BoundVars, f) a -> FV (BoundVars, f) a addBndrsSelectiveFV bs - = upd_bndrs_fv (\(f,bvs) -> let !bvs' = extendVarSetList bvs bs + = updEnvFV (\(bvs,f) -> let !bvs' = extendVarSetList bvs bs -- Strict let to avoid thunks - in (f,bvs')) + in (bvs',f)) mapUnionFV :: (Foldable t, Monoid acc) => (a -> FV env acc) -> t a -> FV env acc @@ -221,7 +221,7 @@ runTyCoVarsDSet f = runFVAcc f emptyDVarSet runFVSelective :: InterestingVarFun -> SelectiveDFV -> DVarSet runFVSelective interesting f - = runEndoOS (runFV f (interesting, emptyVarSet)) emptyDVarSet + = runEndoOS (runFV f (emptyVarSet, interesting)) emptyDVarSet runFVSelectiveList :: InterestingVarFun -> SelectiveDFV -> [Var] runFVSelectiveList interesting f = dVarSetElems (runFVSelective interesting f) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2f4f707b4ea34b99a04a7611618562d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2f4f707b4ea34b99a04a7611618562d... 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