Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: c72a1a15 by Simon Peyton Jones at 2026-01-02T17:37:33+00:00 Wibbles - - - - - bea0ee5a by Simon Peyton Jones at 2026-01-04T23:46:18+00:00 Progress on not-inlining coercions - - - - - 12 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Iface/Tidy.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -172,7 +172,6 @@ import qualified Data.Monoid as Monoid import Data.List.NonEmpty ( NonEmpty (..) ) import Control.DeepSeq -import GHC.Exts {- %************************************************************************ @@ -2473,40 +2472,6 @@ seqCos :: [Coercion] -> () seqCos [] = () seqCos (co:cos) = seqCo co `seq` seqCos cos -coercionIsSmall :: Coercion -> Bool --- This function should return False quickly on a big coercion --- It should /not/ traverse the big coercion! -coercionIsSmall co - = not (isTrue# ((go co 100#) <# 0#)) - where - go :: Coercion -> Int# -> Int# - go _co n | isTrue# (n <# 0#) = n - go (Refl {}) n = dec n - go (GRefl _ _ mco) n = go_mco mco (dec n) - go (TyConAppCo _ _ cos) n = go_cos cos (dec n) - go (AxiomCo _ cos) n = go_cos cos (dec n) - go (UnivCo _ _ _ _ cos) n = go_cos cos (dec n) - go (AppCo co1 co2) n = go co1 (go co2 (dec n)) - go (CoVarCo {}) n = dec n - go (HoleCo {}) n = dec n - go (SymCo co) n = go co (dec n) - go (KindCo co) n = go co (dec n) - go (SubCo co) n = go co (dec n) - go (TransCo co1 co2) n = go co1 (go co2 (dec n)) - go (SelCo _ co) n = go co (dec n) - go (LRCo _ co) n = go co (dec n) - go (InstCo co1 co2) n = go co1 (go co2 (dec n)) - go (ForAllCo _ _ _ kco co) n = go co (go_mco kco (dec n)) - go (FunCo _ _ _ mco aco rco) n = go mco (go aco (go rco (dec n))) - - go_cos [] n = n - go_cos (co:cos) n = go_cos cos (go co n) - - go_mco MRefl n = dec n - go_mco (MCo co) n = go co n - - dec n = n -# 1# - {- %************************************************************************ %* * ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -29,12 +29,14 @@ module GHC.Core.FVs ( idUnfoldingVars, idFreeVars, dIdFreeVars, bndrRuleAndUnfoldingVarsDSet, bndrRuleAndUnfoldingIds, - idFVs, - idRuleVars, stableUnfoldingVars, + idFVs, idRuleVars, + stableUnfoldingVars, + unfoldingFVs, ruleFreeVars, rulesFreeVars, rulesFreeVarsDSet, mkRuleInfo, ruleLhsFreeIds, ruleLhsFreeIdsList, ruleRhsFreeVars, rulesRhsFreeIds, + rulesFVs, RuleFVsFrom(..), exprFVs, exprLocalFVs, addBndrFV, addBndrsFV, @@ -645,17 +647,18 @@ idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV stableUnfoldingVars :: Unfolding -> Maybe VarSet stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf -stableUnfoldingFVs :: Unfolding -> Maybe FV stableUnfoldingFVs unf - = case unf of - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isStableSource src - -> Just (exprLocalFVs rhs) - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprsFVs args) - -- DFuns are top level, so no fvs from types of bndrs - _other -> Nothing - + | isStableUnfolding unf = Just (unfoldingFVs unf) + | otherwise = Nothing + +unfoldingFVs :: Unfolding -> FV +unfoldingFVs (CoreUnfolding { uf_tmpl = rhs }) + = exprLocalFVs rhs +unfoldingFVs (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = FV.delFVs (mkVarSet bndrs) $ exprsLocalFVs args + -- DFuns are top level, so no fvs from types of bndrs +unfoldingFVs _ + = emptyFV {- ************************************************************************ ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -82,7 +82,6 @@ import GHC.Types.Basic import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) import GHC.Builtin.Names -import GHC.Builtin.Types.Prim import GHC.Data.Bag import GHC.Data.List.SetOps @@ -589,19 +588,20 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- Check the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core - ; checkL ( isJoinId binder - || mightBeLiftedType binder_ty - || (isNonRec rec_flag && exprOkForSpeculation rhs) - || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed - || exprIsTickedString rhs) - (badBndrTyMsg binder (text "unlifted")) - - -- Check that if the binder is at the top level and has type Addr#, - -- that it is a string literal. + ; checkL ( isTopLevel top_lvl + || isJoinId binder + || mightBeLiftedType binder_ty + || (isNonRec rec_flag && exprOkForSpeculation rhs)) $ + badBndrTyMsg binder (text "unlifted") + + -- Check that if the binder is at the top level the binding + -- satisfies exprIsTopLevelBindable -- See Note [Core top-level string literals]. - ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) - || exprIsTickedString rhs) - (mkTopNonLitStrMsg binder) + ; checkL ( not (isTopLevel top_lvl) + || exprIsTopLevelBindable rhs binder_ty + || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed + ) $ + mkTopNonLitStrMsg binder ; flags <- getLintFlags @@ -942,7 +942,7 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body) | isTyVar tv = -- See Note [Linting type lets] do { ty' <- lintTypeAndSubst ty - ; lintTyCoBndr tv $ \ tv' -> + ; lintTyVarBndr tv $ \ tv' -> do { addLoc (RhsOf tv) $ lintTyKind tv' ty' -- Now extend the substitution so we -- take advantage of it in the body @@ -1796,24 +1796,24 @@ lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> -- See Note [GHC Formalism] lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a lintBinder site var linterF - | isTyCoVar var = lintTyCoBndr var linterF - | otherwise = lintIdBndr NotTopLevel site var linterF + | isTyVar var = lintTyVarBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF -lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a -lintTyCoBndr tcv thing_inside +lintTyCoBndr :: HasDebugCallStack => InTyCoVar + -> (OutTyCoVar -> LintM a) -> LintM a +lintTyCoBndr var linterF + | isTyVar var = lintTyVarBndr var linterF + | otherwise = lintIdBndr NotTopLevel LambdaBind var linterF + +lintTyVarBndr :: HasDebugCallStack => InTyVar -> (OutTyVar -> LintM a) -> LintM a +lintTyVarBndr tcv thing_inside = do { tcv_type' <- lintTypeAndSubst (varType tcv) ; let tcv_kind' = typeKind tcv_type' - -- See (FORALL1) and (FORALL2) in GHC.Core.Type - ; if (isTyVar tcv) - then -- Check that in (forall (a:ki). blah) we have ki:Type - lintL (isLiftedTypeKind tcv_kind') $ + -- See (FORALL1) in GHC.Core.Type + ; lintL (isLiftedTypeKind tcv_kind') $ hang (text "TyVar whose kind does not have kind Type:") 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind') - else -- Check that in (forall (cv::ty). blah), - -- then ty looks like (t1 ~# t2) - lintL (isCoVarType tcv_type') $ - text "CoVar with non-coercion type:" <+> pprTyVar tcv ; addInScopeTyCoVar tcv tcv_type' thing_inside } @@ -1858,19 +1858,21 @@ lintIdBndr top_lvl bind_site id thing_inside checkL (not is_top_lvl && is_let_bind) $ mkBadJoinBindMsg id - -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); - -- if so, it should be a CoVar, and checked by lintCoVarBndr - ; lintL (not (isCoVarType id_ty)) - (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) + -- Check that the Id is a CoVar <=> has type (t1 ~# t2) or (t1 ~R# t2); + ; lintL (isCoVar id == isCoVarType id_ty) $ + hang (text "CoVar with non-coercion type or vice versa:") + 2 (ppr id <+> dcolon <+> ppr id_ty) -- Check that the lambda binder has no value or OtherCon unfolding. -- See #21496 ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) - (text "Lambda binder with value or OtherCon unfolding.") + (text "Lambda binder with value or OtherCon unfolding.") ; out_ty <- addLoc (IdTy id) (lintValueType id_ty) - ; addInScopeId id out_ty thing_inside } + ; if isCoVar id + then addInScopeTyCoVar id out_ty thing_inside + else addInScopeId id out_ty thing_inside } where id_ty = idType id ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -934,6 +934,8 @@ addJoinFlts = appOL mkRecFloats :: SimplFloats -> SimplFloats -- Flattens the floats into a single Rec group, -- They must either all be lifted LetFloats or all JoinFloats +-- +-- ToDo: explain about CoVar floats mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff , sfJoinFloats = jbs , sfInScope = in_scope }) @@ -944,9 +946,24 @@ mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff where -- See Note [Bangs in the Simplifier] !floats' | isNilOL bs = emptyLetFloats - | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) + | otherwise = LetFloats (flatten_rec bs) FltLifted !jfloats' | isNilOL jbs = emptyJoinFloats - | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) + | otherwise = flatten_rec jbs + + flatten_rec :: OrdList OutBind -> OrdList OutBind + -- Put CoVar bindings first (guaranteed non-recursive) + -- then one recursive value binding + flatten_rec bs = let !(covar_bs, prs) = foldrOL do_one (nilOL, []) bs + in covar_bs `snocOL` Rec prs + + do_one :: OutBind -> (OrdList OutBind,[(OutId,OutExpr)]) + -> (OrdList OutBind,[(OutId,OutExpr)]) + do_one bind (cvbs, prs) + = case bind of + NonRec bndr rhs + | isCoVar bndr -> (bind `consOL` cvbs, prs) + | otherwise -> (cvbs, (bndr,rhs):prs) + Rec prs1 -> (cvbs, prs1 ++ prs) wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -298,6 +298,7 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs (old_bndr,env) (new_bndr,env) (rhs,env) simplTrace :: String -> SDoc -> SimplM a -> SimplM a +-- Spit out a trace with `-dverbose-core2core` simplTrace herald doc thing_inside = do logger <- getLogger if logHasDumpFlag logger Opt_D_verbose_core2core @@ -762,18 +763,15 @@ prepareRhs :: HasDebugCallStack -- See Note [prepareRhs] prepareRhs env top_lvl occ rhs0 | is_expandable = do { (flts,rhs) <- anfise rhs0 - ; pprTrace "prepareRhs" (ppr rhs0 $$ text "new" <+> ppr rhs) $ - return (flts, rhs) } + ; return (flts, rhs) } | otherwise = return (emptyLetFloats, rhs0) where - -- We can't use exprIsExpandable because the WHOLE POINT is that - -- we want to treat (K <big>) as expandable, because we are just - -- about "anfise" the <big> expression. exprIsExpandable would - -- just say no! + -- We can't use exprIsExpandable because the WHOLE POINT is that we want to + -- treat (K <big>) as expandable, because we are just about "anfise" the + -- <big> expression. exprIsExpandable would just say no! is_expandable = go rhs0 0 where - go (Var fun) n_val_args = pprTrace "is_exp" (ppr fun <+> ppr n_val_args $$ ppr (isExpandableApp fun n_val_args)) $ - isExpandableApp fun n_val_args + go (Var fun) n_val_args = isExpandableApp fun n_val_args go (App fun arg) n_val_args | isTypeArg arg = go fun n_val_args | otherwise = go fun (n_val_args + 1) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -2251,9 +2251,12 @@ new binding is abstracted. Several points worth noting abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats -> OutExpr -> SimplM ([OutBind], OutExpr) abstractFloats uf_opts top_lvl main_tvs floats body - = assert (notNull body_floats) $ + | assert (notNull body_floats) $ assert (isNilOL (sfJoinFloats floats)) $ - do { let sccs = concatMap to_sccs body_floats + any isCoVar (bindersOfBinds body_floats) -- ToDo: Explain this case + = return ([], wrapFloats floats body) + | otherwise + = do { let sccs = concatMap to_sccs body_floats ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs ; return (float_binds, GHC.Core.Subst.substExpr subst body) } where ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# OPTIONS_HADDOCK not-home #-} {- @@ -63,7 +64,7 @@ module GHC.Core.TyCo.Rep ( TyCoFolder(..), foldTyCo, noView, -- * Sizes - typeSize, typesSize, coercionSize, + typeSize, typesSize, coercionSize, coercionIsSmall, -- * Multiplicities Scaled(..), scaledMult, scaledThing, mapScaledType, Mult @@ -96,8 +97,8 @@ import GHC.Utils.Panic import GHC.Utils.Binary -- libraries +import GHC.Exts import qualified Data.Data as Data hiding ( TyCon ) -import Data.Coerce import Data.IORef ( IORef ) -- for CoercionHole import Control.DeepSeq @@ -2093,6 +2094,61 @@ mCoercionSize :: MCoercion -> Int mCoercionSize MRefl = 0 mCoercionSize (MCo co) = coercionSize co +coercionIsSmall :: Coercion -> Bool +-- This function is called inside `exprIsTrivial` so it needs to be +-- pretty efficient. It should return False quickly on a big coercion; +-- it should /not/ traverse the big coercion! +coercionIsSmall co + = not (isTrue# ((coercion_is_small co 100#) <# 0#)) + +coercion_is_small :: Coercion -> Int# -> Int# +coercion_is_small co n = go co n + where + go :: Coercion -> Int# -> Int# + go _co n | isTrue# (n <# 0#) = n + go (Refl ty) n = type_is_small ty n + go (GRefl _ ty mco) n = type_is_small ty $ go_mco mco n + go (TyConAppCo _ _ cos) n = go_cos cos $ dec n + go (AxiomCo _ cos) n = go_cos cos $ dec n + go (UnivCo _ _ _ _ cos) n = go_cos cos $ dec n + go (AppCo co1 co2) n = go co1 $ go co2 $ dec n + go (CoVarCo {}) n = dec n + go (HoleCo {}) n = dec n + go (SymCo co) n = go co $ dec n + go (KindCo co) n = go co $ dec n + go (SubCo co) n = go co $ dec n + go (TransCo co1 co2) n = go co1 $ go co2 $ dec n + go (SelCo _ co) n = go co $ dec n + go (LRCo _ co) n = go co $ dec n + go (InstCo co1 co2) n = go co1 $ go co2 $ dec n + go (ForAllCo _ _ _ kco co) n = go co $ go_mco kco $ dec n + go (FunCo _ _ _ mco aco rco) n = go mco $ go aco $ go rco $ dec n + + go_cos [] n = n + go_cos (co:cos) n = go_cos cos (go co n) + + go_mco MRefl n = dec n + go_mco (MCo co) n = go co n + +type_is_small :: Type -> Int# -> Int# +type_is_small ty n = go ty n + where + go _ty n | isTrue# (n <# 0#) = n + go (TyVarTy {}) n = dec n + go (LitTy {}) n = dec n + go (AppTy t1 t2) n = go t1 $ go t2 $ dec n + go (TyConApp _ tys) n = go_tys tys $ dec n + go (ForAllTy _ ty) n = go ty $ dec n + go (FunTy _ m a r) n = go m $ go a $ go r $ dec n + go (CastTy ty co) n = go ty $ coercion_is_small co $ dec n + go (CoercionTy co) n = coercion_is_small co n + + go_tys [] n = n + go_tys (ty:tys) n = go ty $ go_tys tys n + +dec :: Int# -> Int# +dec n = n -# 1# + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -31,7 +31,7 @@ module GHC.Core.Utils ( exprIsWorkFree, exprIsConLike, isCheapApp, isExpandableApp, isSaturatedConApp, exprIsTickedString, exprIsTickedString_maybe, - exprIsTopLevelBindable, + exprIsCoercion, exprIsTopLevelBindable, exprIsUnaryClassFun, isUnaryClassId, altsAreExhaustive, etaExpansionTick, @@ -1331,8 +1331,7 @@ exprIsTrivial e = trivial_expr_fold (const True) -- Literals (const True) -- Types coercionIsSmall -- Coercions - (\ r co -> pprTrace "exprIsTrivial" (ppr (coercionIsSmall co) $$ ppr co) $ - r && coercionIsSmall co) -- Casts + (\ r co -> r && coercionIsSmall co) -- Casts False e {- ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -599,8 +599,10 @@ getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg -- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. -- Good thing we can just call `trivial_expr_fold` here. getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg - panic panic panic panic e + panic panic get_cast panic e where + get_cast r _ = r + panic :: forall a. a panic = pprPanic "getStgArgFromTrivialArg" (ppr e) ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -2169,6 +2169,7 @@ data FloatInfoArgs , fia_is_hnf :: Bool , fia_is_triv :: Bool , fia_is_string :: Bool + , fia_is_coercion :: Bool , fia_is_dc_worker :: Bool , fia_ok_for_spec :: Bool } @@ -2181,14 +2182,17 @@ defFloatInfoArgs bndr rhs , fia_is_hnf = exprIsHNF rhs , fia_is_triv = exprIsTrivial rhs , fia_is_string = exprIsTickedString rhs + , fia_is_coercion = exprIsCoercion rhs , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval } decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo) decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, - fia_is_triv=is_triv, fia_is_string=is_string, + fia_is_triv=is_triv, fia_is_string=is_string, fia_is_coercion = is_coercion, fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec} + -- NB: this function should line up with exprIsTopLevelBindable + -- ToDo: explain a bit more | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs @@ -2199,8 +2203,9 @@ decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, -- We need this special case for nullary unlifted DataCon -- workers/wrappers (top-level bindings) until #17521 is fixed | is_string = (CaseBound, TopLvlFloatable) + | is_coercion = (LetBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to - -- the top-level + -- the top-level. Coercion are ok at top level too. | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable Lifted -> TopLvlFloatable) -- See Note [Speculative evaluation] ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -149,10 +149,12 @@ perPassFlags dflags pass _ -> AllowAnywhere -- See Note [Linting linearity] - check_linearity = gopt Opt_DoLinearCoreLinting dflags || ( - case pass of + check_linearity = gopt Opt_DoLinearCoreLinting dflags + -- `-dlinear-core-lint`: check linearity in every pass + || -- Always check linearity just after desugaring + case pass of CoreDesugar -> True - _ -> False) + _ -> False -- See Note [Checking for rubbish literals] in GHC.Core.Lint check_rubbish = case pass of ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -58,6 +58,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Iface.Tidy.StaticPtrTable import GHC.Iface.Env +import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic @@ -89,7 +90,6 @@ import GHC.Unit.Module.Deps import GHC.Data.Maybe -import Control.Monad import Data.Function import Data.List ( sortBy, mapAccumL ) import qualified Data.Set as S @@ -826,71 +826,7 @@ See Note [Choosing external Ids] -} bndrFvsInOrder :: Bool -> Id -> [Id] -bndrFvsInOrder show_unfold id - = run (dffvLetBndr show_unfold id) - -run :: DFFV () -> [Id] -run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of - ((_,ids),_) -> ids - -newtype DFFV a - = DFFV (VarSet -- Envt: non-top-level things that are in scope - -- we don't want to record these as free vars - -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far - -> ((VarSet,[Var]),a)) -- Output state - deriving (Functor) - -instance Applicative DFFV where - pure a = DFFV $ \_ st -> (st, a) - (<*>) = ap - -instance Monad DFFV where - (DFFV m) >>= k = DFFV $ \env st -> - case m env st of - (st',a) -> case k a of - DFFV f -> f env st' - -extendScope :: Var -> DFFV a -> DFFV a -extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) - -extendScopeList :: [Var] -> DFFV a -> DFFV a -extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) - -insert :: Var -> DFFV () -insert v = DFFV $ \ env (set, ids) -> - let keep_me = isLocalId v && - not (v `elemVarSet` env) && - not (v `elemVarSet` set) - in if keep_me - then ((extendVarSet set v, v:ids), ()) - else ((set, ids), ()) - - -dffvExpr :: CoreExpr -> DFFV () -dffvExpr (Var v) = insert v -dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 -dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e -dffvExpr (Tick _other e) = dffvExpr e -dffvExpr (Cast e _) = dffvExpr e -dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) -dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ - (mapM_ dffvBind prs >> dffvExpr e) -dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) -dffvExpr _other = return () - -dffvAlt :: CoreAlt -> DFFV () -dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r) - -dffvBind :: (Id, CoreExpr) -> DFFV () -dffvBind(x,r) - | not (isId x) = dffvExpr r - | otherwise = dffvLetBndr False x >> dffvExpr r - -- Pass False because we are doing the RHS right here - -- If you say True you'll get *exponential* behaviour! - -dffvLetBndr :: Bool -> Id -> DFFV () --- Gather the free vars of the RULES and unfolding of a binder +-- Gather the free vars of the type, RULES and unfolding of an Id bindeb -- We always get the free vars of a *stable* unfolding, but -- for a *vanilla* one (VanillaSrc), the flag controls what happens: -- True <=> get fvs of even a *vanilla* unfolding @@ -899,24 +835,21 @@ dffvLetBndr :: Bool -> Id -> DFFV () -- we are taking the fvs of the RHS anyway -- For top-level bindings (call from addExternal, via bndrFvsInOrder) -- we say "True" if we are exposing that unfolding -dffvLetBndr vanilla_unfold id - = do { go_unf (realUnfoldingInfo idinfo) - ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } +bndrFvsInOrder show_unfold id + = fvVarList $ + filterFV isId $ -- Include CoVars, which can be top-level bound + tyCoFVsOfType (idType id) `unionFV` + unf_fvs `unionFV` + rules_fvs where idinfo = idInfo id - go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src = dffvExpr rhs - | vanilla_unfold = dffvExpr rhs - | otherwise = return () - - go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = extendScopeList bndrs $ mapM_ dffvExpr args - go_unf _ = return () + unf_fvs :: FV + unf_fvs | show_unfold = unfoldingFVs (realUnfoldingInfo idinfo) + | otherwise = emptyFV - go_rule (BuiltinRule {}) = return () - go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) - = extendScopeList bndrs (dffvExpr rhs) + rules_fvs :: FV + rules_fvs = rulesFVs RhsOnly (ruleInfoRules (ruleInfo idinfo)) {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/760fe6e02a2b9be0ef0b23d73a9b9fd... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/760fe6e02a2b9be0ef0b23d73a9b9fd... You're receiving this email because of your account on gitlab.haskell.org.