[Git][ghc/ghc][wip/T20264] 2 commits: More progress
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Nov 1 17:36:42 UTC 2024
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
cef80573 by Simon Peyton Jones at 2024-11-01T17:36:04+00:00
More progress
- - - - -
8ab34802 by Simon Peyton Jones at 2024-11-01T17:36:15+00:00
Temp debug printing
- - - - -
11 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.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/Ppr.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Utils/Trace.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -1618,6 +1618,9 @@ arityType env (Case scrut bndr _ alts)
alts_type = foldr1 (andArityType env) (map arity_type_alt alts)
arityType env (Let (NonRec b rhs) e)
+ | isTyCoVar b -- Totally ignore a type-let or coercion-let
+ = arityType env e
+ | otherwise
= -- See Note [arityType for non-recursive let-bindings]
floatIn rhs_cost (arityType env' e)
where
@@ -2667,7 +2670,7 @@ Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when
(such as dropping of `seq`s when arity > 0) will no longer work in the RHS.
Plus it requires non-trivial refactorings to both the simple optimiser (in
the way `subst_opt_bndr` is used) as well as the Simplifier (in the way
- `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's
+ `simplIdBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's
substitution twice in the process. A very complicated stop-gap.
Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -344,7 +344,7 @@ cprTransform env id args
-- Other local Ids that respond True to 'isDataStructure' but don't have an
-- expandable unfolding, such as NOINLINE bindings. They all get a top sig
| isLocalId id
- = assertPpr (isDataStructure id) (ppr id) topCprType
+ = assertPpr (isDataStructure id) (ppr id <+> ppr (idArity id) $$ ppr (maybeUnfoldingTemplate (idUnfolding id))) topCprType
-- See Note [CPR for DataCon wrappers]
| Just rhs <- dataConWrapUnfolding_maybe id
= fst $ cprAnalApp env rhs args
@@ -512,9 +512,10 @@ cprAnalBind env id rhs
= (id, rhs, extendSigEnv env id topCprSig)
-- See Note [CPR for data structures]
| isDataStructure id -- Data structure => no code => no need to analyse rhs
- = (id, rhs, env)
+ = pprTrace "cprAnalBind" (ppr id <+> ppr (maybeUnfoldingTemplate (idUnfolding id))) $
+ (id, rhs, env)
| otherwise
- = -- pprTrace "cprAnalBind" (ppr id <+> ppr sig <+> ppr sig')
+ = pprTrace "cprAnalBind2" (ppr id <+> ppr sig <+> ppr sig')
(id `setIdCprSig` sig', rhs', env')
where
(rhs_ty, rhs') = cprAnal env rhs
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -354,10 +354,11 @@ through RULES. It only happens for rules whose head is an imported
function (B.f in the example above).
Solution:
- - When simplifying, bring all top level identifiers into
- scope at the start, ignoring the Rec/NonRec structure, so
- that when 'h' pops up in f's rhs, we find it in the in-scope set
- (as the simplifier generally expects). This happens in simplTopBinds.
+
+ - When simplifying, bring all top level identifiers into scope at the start,
+ ignoring the Rec/NonRec structure, so that when '$sf' pops up in foo's rhs
+ (during simplification, when applying the RULE), we find it in the in-scope
+ set (as the simplifier generally expects). This happens in simplTopBinds.
- In the occurrence analyser, if there are any out-of-scope
occurrences that pop out of the top, which will happen after
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -28,7 +28,8 @@ module GHC.Core.Opt.Simplify.Env (
SimplSR(..), mkContEx, substId, lookupRecBndr,
-- * Simplifying binders
- simplTopBndrs, simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
+ simplTyVarBndr, simplIdBndr, simplIdBndrs,
+ simplNonRecJoinBndr, simplRecJoinBndrs,
simplBinder, simplBinders,
substTy, substTyVar, getSubst,
substCo, substCoVar,
@@ -740,13 +741,15 @@ andFF FltOkSpec _ = FltOkSpec
andFF FltLifted flt = flt
-doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
+doFloatFromRhs :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool
+ -> [OutTyVar] -> SimplFloats -> OutExpr -> Bool
-- If you change this function look also at FloatIn.noFloatIntoRhs
-doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
- = floatEnabled lvl fe
- && not (isNilOL fs)
- && want_to_float
- && can_float
+doFloatFromRhs env lvl rec strict_bind tvs (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
+ = not (isNilOL fs)
+ && floatEnabled lvl (seFloatEnable env)
+ && want_to_float
+ && can_float
+ && not cant_float_types
where
want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
-- See Note [Float when cheap or expandable]
@@ -761,6 +764,19 @@ doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs
floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl)
floatEnabled _ FloatEnabled = True
+ float_bndrs = bindersOfBinds $ fromOL fs
+
+ -- Currently we sadly can't float if we have
+ -- /\a. let @b = [a] in blah
+ -- becuase we don't have type-lambda
+ cant_float_types
+ | not (null tvs), any isTyCoVar float_bndrs
+ = (pprTraceWhen (any isId float_bndrs)
+ "WARNING-TyCo: skipping abstractFloats" (ppr fs)) $
+ True
+ | otherwise
+ = False
+
{-
Note [Float when cheap or expandable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -894,9 +910,10 @@ addJoinFlts = appOL
mkRecFloats :: SimplFloats -> SimplFloats
-- Flattens the floats into a single Rec group,
--- They must either all be lifted LetFloats or all JoinFloats
+-- They must either all be lifted LetFloats or all JoinFloats
-- If any are type bindings they must be non-recursive, so
--- do not need to be joined into a letrec
+-- do not need to be joined into a letrec; indeed they must not
+-- since Rec{} is not allowed to have type binders
mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff
, sfJoinFloats = join_bs
, sfInScope = in_scope })
@@ -995,7 +1012,7 @@ refineFromInScope in_scope v
| otherwise = v
lookupRecBndr :: SimplEnv -> InId -> OutId
--- Look up an Id which has been put into the envt by simplRecBndrs,
+-- Look up an Id which has been put into the envt by simplIdBndrs,
-- but where we have not yet done its RHS
-- lookupRecBndr (SimplEnv { seInScope = in_scope, seTvSubst = tvs }) v
-- | isTyVar v
@@ -1061,44 +1078,40 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- The substitution is extended only if the variable is cloned, because
-- we *don't* need to use it to track occurrence info.
simplBinder !env bndr
- | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
- ; seqTyVar tv `seq` return (env', tv) }
- | otherwise = do { let (env', id) = substIdBndr env bndr
- ; seqId id `seq` return (env', id) }
+ | isTyVar bndr = simplTyVarBndr env bndr
+ | otherwise = simplIdBndr env bndr
---------------
-simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
--- A non-recursive let binder
-simplNonRecBndr !env bndr
- -- See Note [Bangs in the Simplifier]
- = do { let (!env1, bndr1) = substBndr env bndr
- ; seqVar bndr1 `seq` return (env1, bndr1) }
+simplTyVarBndr :: SimplEnv -> InTyVar -> SimplM (SimplEnv, OutTyVar)
+simplTyVarBndr env tv
+ = do { let (env', tv1) = substTyVarBndr env tv
+ ; seqTyVar tv1 `seq` return (env', tv1) }
---------------
-simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
--- Recursive let binders
-simplRecBndrs env@(SimplEnv {}) bndrs
+simplIdBndr :: SimplEnv -> InId -> SimplM (SimplEnv, OutId)
+-- A non-recursive let binder
+-- The returned Id has no unfolding or rules; we add those later
+simplIdBndr !env id
-- See Note [Bangs in the Simplifier]
- = assert (all (not . isJoinId) bndrs) $
- do { let (!env1, bndrs1) = mapAccumL substIdBndr env bndrs
- ; seqVars bndrs1 `seq` return env1 }
+ = do { let (!env1, id1) = substIdBndr env id
+ ; seqId id1 `seq` return (env1, id1) }
---------------
-simplTopBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
-simplTopBndrs env@(SimplEnv {}) bndrs
+simplIdBndrs :: SimplEnv -> [InId] -> SimplM SimplEnv
+-- Used for recursive let binders: Ids only
+-- No fancy knot-tying! We simply go through the binders in
+-- (arbitrary) order. For each:
+-- - applying the substitution to its type
+-- - clone the Unique if it's already in scope
+-- The returned Ids have no unfolding or rules; we add those later
+simplIdBndrs env@(SimplEnv {}) ids
-- See Note [Bangs in the Simplifier]
- = assert (all (not . isJoinId) bndrs) $
- do { let (!env1, bndrs1) = mapAccumL substBndr env bndrs
- ; seqVars bndrs1 `seq` return env1 }
-
----------------
-substBndr :: HasDebugCallStack => SimplEnv -> InBndr -> (SimplEnv, OutBndr)
-substBndr env bndr
- | isTyVar bndr = substTyVarBndr env bndr
- | otherwise = substIdBndr env bndr
+ = assert (all (not . isJoinId) ids) $
+ do { let (!env1, ids1) = mapAccumL substIdBndr env ids
+ ; seqIds ids1 `seq` return env1 }
---------------
-substIdBndr :: HasDebugCallStack => SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+substIdBndr :: HasDebugCallStack => SimplEnv -> InId -> (SimplEnv, OutId)
-- Might be a coercion variable
substIdBndr env bndr
| isCoVar bndr = substCoVarBndr env bndr
@@ -1196,15 +1209,6 @@ seqIds :: [Id] -> ()
seqIds [] = ()
seqIds (id:ids) = seqId id `seq` seqIds ids
-seqVar :: Var -> ()
-seqVar var
- | isTyVar var = seqTyVar var
- | otherwise = seqId var
-
-seqVars :: [Var] -> ()
-seqVars [] = ()
-seqVars (var:vars) = seqVar var `seq` seqVars vars
-
{-
Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -54,7 +54,7 @@ import GHC.Types.Demand
import GHC.Types.Unique ( hasKey )
import GHC.Types.Basic
import GHC.Types.Tickish
-import GHC.Types.Var ( isTyCoVar )
+import GHC.Types.Var ( isTyCoVar, setTyVarUnfolding )
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
import GHC.Builtin.Names( runRWKey, seqHashKey )
@@ -205,22 +205,26 @@ simplTopBinds env0 binds0
-- It's rather as if the top-level binders were imported.
-- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".
-- See Note [Bangs in the Simplifier]
- ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplTopBndrs env0 (bindersOfBinds binds0)
- ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
+ ; (ty_floats, env1) <- {-#SCC "simplTopBinds-simplRecBndrs" #-}
+ simplTopTyVarBinds env0 binds0
+ ; (val_floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-}
+ simpl_binds env1 binds0
; freeTick SimplifierDone
- ; return (floats, env2) }
+ ; return (ty_floats `addFloats` val_floats, env2) }
where
- -- We need to track the zapped top-level binders, because
- -- they should have their fragile IdInfo zapped (notably occurrence info)
- -- That's why we run down binds and bndrs' simultaneously.
- --
simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
- simpl_binds env [] = return (emptyFloats env, env)
- simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind
- ; (floats, env2) <- simpl_binds env1 binds
- -- See Note [Bangs in the Simplifier]
- ; let !floats1 = float `addFloats` floats
- ; return (floats1, env2) }
+ simpl_binds env []
+ = return (emptyFloats env, env)
+
+ simpl_binds env (bind:binds)
+ | isTypeBind bind -- Already done!
+ = simpl_binds env binds
+ | otherwise
+ = do { (float, env1) <- simpl_bind env bind
+ ; (floats, env2) <- simpl_binds env1 binds
+ -- See Note [Bangs in the Simplifier]
+ ; let !floats1 = float `addFloats` floats
+ ; return (floats1, env2) }
simpl_bind env (Rec pairs)
= simplRecBind env (BC_Let TopLevel Recursive) pairs
@@ -230,6 +234,80 @@ simplTopBinds env0 binds0
; (env', b') <- addBndrRules env bind_cxt b b'
; simplRecOrTopPair env' bind_cxt b b' r }
+
+-------------------------------------------
+simplTopTyVarBinds :: SimplEnv -> [InBind]
+ -> SimplM (SimplFloats, SimplEnv)
+-- Simplify the /type/ bindings, and bring them all to the front
+-- Substitute in the binders of the /value/ bindings, and bring
+-- them into scope
+simplTopTyVarBinds env []
+ = return (emptyFloats env, env)
+
+simplTopTyVarBinds env (b:bs)
+ | Just (tv, rhs_ty) <- isTypeBind_maybe b
+ = assertPpr (isTyVar tv) (ppr tv) $
+ do { (tbs1, env1) <- simplTyVarBind env tv rhs_ty
+ ; (tbs2, env') <- simplTopTyVarBinds env1 bs
+ ; return (tbs1 `addFloats` tbs2, env') }
+
+ | otherwise
+ = do { env1 <- simplIdBndrs env (bindersOf b)
+ -- Bring all the value binders into scope
+ -- in env1, substituting in their types
+ ; simplTopTyVarBinds env1 bs }
+
+{- Note [Top level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When simplifying the top level bindings, we do two slightly surprising things:
+
+* We add all the top level Ids into the InScopeSet right at the start. Why?
+ See Note [Glomming] in GHC.Core.Opt.OccurAnal. This consists mainly of
+ calling simplIdBndrs on all the top-level value binders. They'll get added
+ to the InScopeSet shorn of their unfoldings and rules, but that's fine;
+ only back-refs will see these less-useful versions.
+
+* When we bring them into scope, we'd better add them /with their correct type/.
+ That's a bit tricky becuase of type bindings.
+ @a = Int
+ f :: a = 3
+ We might decide to inline a unconditionally, dropping its binding. If so,
+ we should not add (f::a) to the InScopeSet
+
+ Solution, implemented in `simplTopVarBinds`:
+ * First, simplify all the type-bindings, and bring them to the front.
+ * Then we can apply that substitution to the type of `f`, before
+ adding it to the in-scope set
+-}
+
+{- *********************************************************************
+* *
+ TyVar bindings
+* *
+********************************************************************* -}
+
+simplTyVarBind :: SimplEnv -> InTyVar -> InType
+ -> SimplM (SimplFloats, SimplEnv)
+-- Returned SimplFloats is empty, or singleton type binding
+simplTyVarBind env tv ty
+ | Just env' <- preInlineTypeUnconditionally env tv ty
+ = return (emptyFloats env', env')
+ | otherwise
+ = do { ty' <- simplType env ty
+ ; completeTyVarBindX env tv ty' }
+
+completeTyVarBindX :: SimplEnv -> InTyVar -> OutType
+ -> SimplM (SimplFloats, SimplEnv)
+completeTyVarBindX env in_tv out_ty
+ | postInlineTypeUnconditionally out_ty
+ = return (emptyFloats env, extendTvSubst env in_tv out_ty)
+
+ | otherwise
+ = do { (env1, out_tv) <- simplTyVarBndr env in_tv
+ ; let out_tv_w_unf = out_tv `setTyVarUnfolding` out_ty
+ env2 = extendTvSubst env1 in_tv (mkTyVarTy out_tv_w_unf)
+ ; return (mkFloatBind env2 (NonRec out_tv_w_unf (Type out_ty))) }
+
{-
************************************************************************
* *
@@ -277,6 +355,7 @@ simplRecOrTopPair :: SimplEnv
-> BindContext
-> InId -> OutBndr -> InExpr -- Binder and rhs
-> SimplM (SimplFloats, SimplEnv)
+-- Precondition: not a TyVar binding
simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
| Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)
@@ -286,10 +365,6 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
do { tick (PreInlineUnconditionally old_bndr)
; return ( emptyFloats env, env' ) }
- | Type ty <- rhs
- = do { ty' <- simplType env ty
- ; return (mkTyVarFloatBind env old_bndr new_bndr ty') }
-
| otherwise
= assertPpr (isId old_bndr) (ppr old_bndr) $
case bind_cxt of
@@ -318,15 +393,15 @@ simplLazyBind :: TopLevelFlag -> RecFlag
-> SimplM (SimplFloats, SimplEnv)
-- Precondition: Ids only, no TyVars; not a JoinId
-- Precondition: rhs obeys the let-can-float invariant
-simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
- = assert (isId bndr )
- assertPpr (not (isJoinId bndr)) (ppr bndr) $
- -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
+simplLazyBind top_lvl is_rec (in_bndr,unf_se) (out_bndr,env) (rhs,rhs_se)
+ = assert (isId in_bndr )
+ assertPpr (not (isJoinId in_bndr)) (ppr in_bndr) $
+ -- pprTrace "simplLazyBind" ((ppr in_bndr <+> ppr out_bndr) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]
- (tvs, body) = case collectTyAndValBinders rhs of
- (tvs, [], body)
- | surely_not_lam body -> (tvs, body)
- _ -> ([], rhs)
+ (in_tvs, body) = case collectTyAndValBinders rhs of
+ (tvs, [], body)
+ | surely_not_lam body -> (tvs, body)
+ _ -> ([], rhs)
surely_not_lam (Lam {}) = False
surely_not_lam (Tick t e)
@@ -338,53 +413,45 @@ simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
-- f = /\a. \x. g a x
-- should eta-reduce.
- ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs
+ ; (body_env, out_tvs) <- {-#SCC "simplBinders" #-} simplBinders rhs_env in_tvs
-- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils
-- Simplify the RHS
; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
- is_rec (idDemandInfo bndr)
+ is_rec (idDemandInfo in_bndr)
; (body_floats0, body0) <- {-#SCC "simplExprF" #-}
simplExprF body_env body rhs_cont
- ; (if isTopLevel top_lvl then pprTrace "simplLazyBind" (ppr bndr <+> ppr body_floats0 $$ ppr body0) else id) $
- return ()
+-- ; (if isTopLevel top_lvl
+-- then pprTrace "simplLazyBind" (ppr in_bndr <+> ppr body_floats0 $$ ppr body0)
+-- else id) $
+-- return ()
-- ANF-ise a constructor or PAP rhs
; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}
prepareBinding env top_lvl is_rec
False -- Not strict; this is simplLazyBind
- bndr1 body_floats0 body0
- -- Subtle point: we do not need or want tvs' in the InScope set
+ out_bndr out_tvs body_floats0 body0
+ -- Subtle point: we do not need or want out_tvs in the InScope set
-- of body_floats2, so we pass in 'env' not 'body_env'.
- -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do
+ -- Don't want: if out_tvs are in-scope in the scope of this let-binding, we may do
-- more renaming than necessary => extra work (see !7777 and test T16577).
- -- Don't need: we wrap tvs' around the RHS anyway.
-
- ; let float_bndrs2 = bindersOfBinds $ letFloatBinds $ sfLetFloats body_floats2
- -- float_bndrs2 used only in debugging
+ -- Don't need: we wrap out_tvs around the RHS anyway.
; (rhs_floats, body3)
- <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating
+ <- if isEmptyFloats body_floats2 || null in_tvs then -- Simple floating
{-#SCC "simplLazyBind-simple-floating" #-}
return (body_floats2, body2)
- else if any isTyCoVar float_bndrs2
- then (if not (any isId float_bndrs2) then id
- else pprTrace "WARNING-TyCo: skipping abstractFloats"
- (ppr bndr $$ ppr body_floats2)) $
- -- No Float because of the type bindings
- return (emptyFloats env, wrapFloats body_floats2 body2)
-
else -- Non-empty floats, and non-empty tyvars: do type-abstraction first
{-#SCC "simplLazyBind-type-abstraction-first" #-}
do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl
- tvs' body_floats2 body2
+ out_tvs body_floats2 body2
; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds
; return (poly_floats, body3) }
; let env1 = env `setInScopeFromF` rhs_floats
- ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont
- ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)
+ ; rhs' <- rebuildLam env1 out_tvs body3 rhs_cont
+ ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (in_bndr,unf_se) (out_bndr,rhs',env1)
; return (rhs_floats `addFloats` bind_float, env2) }
--------------------------
@@ -615,7 +682,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
is_strict = isStrictId bndr
; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict
- work_id (emptyFloats env) rhs
+ work_id [] (emptyFloats env) rhs
; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs
; let work_id_w_unf = work_id `setIdUnfolding` work_unf
@@ -667,9 +734,9 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)
_ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs
tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings
- = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr
- , text "rhs:" <+> ppr rhs ])
- ; return (mkFloatBind env (NonRec bndr rhs)) }
+ = do { -- traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr
+ -- , text "rhs:" <+> ppr rhs ])
+ return (mkFloatBind env (NonRec bndr rhs)) }
mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
-- See Note [Cast worker/wrapper]
@@ -694,8 +761,10 @@ mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, i
********************************************************************* -}
prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool
- -> Id -- Used only for its OccName; can be InId or OutId
- -> SimplFloats -> OutExpr
+ -> OutId -- Used only for its OccName
+ -> [OutTyVar] -- Type lambdas wrapped around this RHS
+ -> SimplFloats -- Floats from the RHS
+ -> OutExpr -- The rest of the RHS, inside the floats
-> SimplM (SimplFloats, OutExpr)
-- In (prepareBinding ... bndr floats rhs), the binding is really just
-- bndr = let floats in rhs
@@ -708,7 +777,7 @@ prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool
-- That's what prepareBinding does
-- Precondition: binder is not a JoinId
-- Postcondition: the returned SimplFloats contains only let-floats
-prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs
+prepareBinding env top_lvl is_rec strict_bind bndr tvs rhs_floats rhs
= do { -- Never float join-floats out of a non-join let-binding (which this is)
-- So wrap the body in the join-floats right now
-- Hence: rhs_floats1 consists only of let-floats
@@ -725,7 +794,7 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs
-- Finally, decide whether or not to float
; let all_floats = rhs_floats1 `addLetFloats` anf_floats
- ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2
+ ; if doFloatFromRhs env top_lvl is_rec strict_bind tvs all_floats rhs2
then -- Float!
do { tick LetFloatFromLet
; return (all_floats, rhs2) }
@@ -1263,6 +1332,12 @@ simplExprF1 env (Let (Rec pairs) body) cont
= {-#SCC "simplRecE" #-} simplRecE env pairs body cont
simplExprF1 env (Let (NonRec bndr rhs) body) cont
+ | Type ty <- rhs
+ = assert (isTyVar bndr) $
+ do { (floats1, env1) <- simplTyVarBind env bndr ty
+ ; (floats2, expr') <- simplExprF env1 body cont
+ ; return (floats1 `addFloats` floats2, expr') }
+
| Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env
-- Because of the let-can-float invariant, it's ok to
-- inline freely, or to drop the binding if it is dead.
@@ -1575,7 +1650,7 @@ completeBindX :: SimplEnv
completeBindX env from_what bndr rhs body cont
| FromBeta arg_levity <- from_what
, needsCaseBindingL arg_levity rhs -- Enforcing the let-can-float-invariant
- = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules
+ = do { (env1, bndr1) <- simplIdBndr env bndr -- Lambda binders don't have rules
; (floats, expr') <- simplNonRecBody env1 from_what body cont
-- Do not float floats past the Case binder below
; let expr'' = wrapFloats floats expr'
@@ -1583,7 +1658,7 @@ completeBindX env from_what bndr rhs body cont
; return (emptyFloats env, case_expr) }
| otherwise -- Make a let-binding
- = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ = do { (env1, bndr1) <- simplIdBndr env bndr
; (env2, bndr2) <- addBndrRules env1 (BC_Let NotTopLevel NonRecursive) bndr bndr1
; let is_strict = isStrictId bndr2
@@ -1592,7 +1667,7 @@ completeBindX env from_what bndr rhs body cont
-- c.f. Note [Dark corner with representation polymorphism]
; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
- bndr2 (emptyFloats env) rhs
+ bndr2 [] (emptyFloats env) rhs
-- NB: it makes a surprisingly big difference (5% in compiler allocation
-- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
-- because this is completeBindX, so bndr is not in scope in the RHS.
@@ -1890,8 +1965,7 @@ simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
simplNonRecE :: HasDebugCallStack
=> SimplEnv
-> FromWhat
- -> InVar -- The binder, may be a TyVar
- -- Never a join point
+ -> InId -- Never a TyVar, nor a join point
-- The static env for its unfolding (if any) is the first parameter
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
-> InExpr -- Body of the let/lambda
@@ -1906,6 +1980,8 @@ simplNonRecE :: HasDebugCallStack
-- = let env in
-- cont< let b = rhs_se(rhs) in body >
--
+-- preInlineUnconditionally is already dealt with, as are join points
+--
-- It deals with strict bindings, via the StrictBind continuation,
-- which may abort the whole process.
--
@@ -1913,13 +1989,6 @@ simplNonRecE :: HasDebugCallStack
-- Otherwise it may or may not satisfy it.
simplNonRecE env from_what bndr (rhs, rhs_se) body cont
- | Type ty <- rhs
- = assert (isTyVar bndr) $
- do { ty' <- simplType (rhs_se `setInScopeFromE` env) ty
- ; (floats1, env1) <- completeTyVarBindX env bndr ty'
- ; (floats2, expr') <- simplNonRecBody env1 from_what body cont
- ; return (floats1 `addFloats` floats2, expr') }
-
| assert (isId bndr && not (isJoinId bndr) ) $
is_strict_bind
= -- Evaluate RHS strictly
@@ -1928,7 +1997,7 @@ simplNonRecE env from_what bndr (rhs, rhs_se) body cont
, sc_env = env, sc_cont = cont, sc_dup = NoDup })
| otherwise -- Evaluate RHS lazily
- = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ = do { (env1, bndr1) <- simplIdBndr env bndr
; (env2, bndr2) <- addBndrRules env1 (BC_Let NotTopLevel NonRecursive) bndr bndr1
; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive
(bndr,env) (bndr2,env2) (rhs,rhs_se)
@@ -1945,14 +2014,6 @@ simplNonRecE env from_what bndr (rhs, rhs_se) body cont
-- (FromBeta Lifted) or FromLet: look at the demand info
_ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)
-completeTyVarBindX :: SimplEnv -> InTyVar -> OutType -> SimplM (SimplFloats, SimplEnv)
-completeTyVarBindX env tv rhs_ty
- | postInlineTypeUnconditionally rhs_ty
- = return (emptyFloats env, extendTvSubst env tv rhs_ty)
- | otherwise
- = do { (env1, tv1) <- simplNonRecBndr env tv
- ; return (mkTyVarFloatBind env1 tv tv1 rhs_ty) }
-
------------------
simplRecE :: SimplEnv
-> [(InId, InExpr)]
@@ -1966,7 +2027,7 @@ simplRecE :: SimplEnv
simplRecE env pairs body cont
= do { let bndrs = map fst pairs
; massert (all (not . isJoinId) bndrs)
- ; env1 <- simplRecBndrs env bndrs
+ ; env1 <- simplIdBndrs env bndrs
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs
@@ -3397,9 +3458,9 @@ simplAlts :: SimplEnv
-> SimplM OutExpr -- Returns the complete simplified case expression
simplAlts env0 scrut case_bndr alts cont'
- = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr
- , text "cont':" <+> ppr cont'
- , text "in_scope" <+> ppr (seInScope env0) ])
+ = do { -- traceSmpl "simplAlts" (vcat [ ppr case_bndr
+ -- , text "cont':" <+> ppr cont'
+ -- , text "in_scope" <+> ppr (seInScope env0) ])
; (env1, case_bndr1) <- simplBinder env0 case_bndr
; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding
env2 = modifyInScope env1 case_bndr2
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -12,8 +12,8 @@ module GHC.Core.Opt.Simplify.Utils (
tryEtaExpandRhs, wantEtaExpansion,
-- Inlining,
- preInlineUnconditionally, postInlineUnconditionally,
- postInlineTypeUnconditionally,
+ preInlineUnconditionally, preInlineTypeUnconditionally,
+ postInlineUnconditionally, postInlineTypeUnconditionally,
activeRule,
getUnfoldingInRuleMatch,
updModeForStableUnfoldings, updModeForRules,
@@ -1455,9 +1455,23 @@ is a term (not a coercion) so we can't necessarily inline the latter in
the former.
-}
+preInlineTypeUnconditionally :: SimplEnv -> InTyVar -> InType -> Maybe SimplEnv
+preInlineTypeUnconditionally env tv rhs_ty
+ | not (sePreInline env)
+ = Nothing
+
+ -- Inline unconditionally if it occurs exactly once, inside a lambda or not.
+ -- No work is wasted by substituting inside a lambda, although if the
+ -- lambda is inlined a lot, we migth duplicate the type.
+ | OneOcc{ occ_n_br = 1 } <- tyVarOccInfo tv
+ = Just $! extendTvSubst env tv $! substTy env rhs_ty
+
+ | otherwise
+ = Nothing
+
preInlineUnconditionally
:: SimplEnv -> TopLevelFlag
- -> InVar -- Works for TyVar, CoVar, and Id
+ -> InId -- Works for CoVar, and Id; not a TyVar
-> InExpr -> StaticEnv -- These two go together
-> Maybe SimplEnv -- Returned env has extended substitution
-- Precondition: rhs satisfies the let-can-float invariant
@@ -1465,18 +1479,8 @@ preInlineUnconditionally
-- Reason: we don't want to inline single uses, or discard dead bindings,
-- for unlifted, side-effect-ful bindings
preInlineUnconditionally env top_lvl bndr rhs rhs_env
- | not pre_inline_unconditionally = Nothing
-
- -- First deal with type variables; inline unconditionally
- -- if it occurs exactly once, inside a lambda or not
- -- No work is wasted by substituting inside a lambda, although
- -- if the lambea is inlined a lot, we migth dupliate the type.
- | isTyVar bndr
- = case (tyVarOccInfo bndr, rhs) of
- (OneOcc{ occ_n_br = 1 }, Type ty) -> Just $! (extend_tv_subst_with ty)
- _ -> Nothing
-
- -- Now we are onto Ids
+ | assertPpr (isId bndr) (ppr bndr) $
+ not pre_inline_unconditionally = Nothing
| not active = Nothing
| isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]
| isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally]
@@ -1492,7 +1496,6 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
where
unf = idUnfolding bndr
extend_id_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
- extend_tv_subst_with ty = extendTvSubst env bndr $! (substTy rhs_env ty)
one_occ IAmDead = True -- Happens in ((\x.1) v)
one_occ OneOcc{ occ_n_br = 1
@@ -1604,7 +1607,7 @@ rules] for details.
-}
postInlineTypeUnconditionally :: Type -> Bool
-postInlineTypeUnconditionally _ = False
+postInlineTypeUnconditionally _ = False -- For now
postInlineUnconditionally
:: SimplEnv -> BindContext
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -191,7 +191,7 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
-ppr_expr add_par (Var id) = ppr_id_occ add_par id
+ppr_expr add_par (Var id) = ppr_id_occ add_par id <> braces (text $ case (maybeUnfoldingTemplate (idUnfolding id)) of { Just{} -> "has-unf" ; Nothing -> "no-unf" })
ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird
ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)
ppr_expr add_par (Lit lit) = pprLiteral add_par lit
@@ -234,7 +234,7 @@ ppr_expr add_par expr@(App {})
_ -> parens (hang fun_doc 2 pp_args)
where
- fun_doc = ppr_id_occ noParens f
+ fun_doc = ppr_id_occ noParens f <> braces (text $ case (maybeUnfoldingTemplate (idUnfolding f)) of { Just{} -> "has-unf" ; Nothing -> "no-unf" })
_ -> parens (hang (pprParendExpr fun) 2 pp_args)
}
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -43,8 +43,7 @@ import GHC.Core.Utils
-- We are defining local versions
import GHC.Core.Type hiding ( substTy )
-import GHC.Core.Coercion
- ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr )
+import GHC.Core.Coercion ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr )
import GHC.Types.Var.Set
import GHC.Types.Var.Env as InScopeSet
@@ -370,11 +369,7 @@ substIdBndr :: HasDebugCallStack
-> (Subst, Id) -- ^ Transformed pair
-- NB: unfolding may be zapped
-substIdBndr _doc rec_subst subst old_id
- = assertPpr (isId old_id) (ppr old_id) $
- substIdBndr' _doc rec_subst subst old_id
-
-substIdBndr' _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
+substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
= (Subst new_in_scope new_env tvs cvs, new_id)
where
id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -1077,10 +1077,11 @@ scopedSort = go [] []
| otherwise
= (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)
where
- -- If tv has an unfolding, expand it instead of looking at its kind
- fv_tv = case tyVarUnfolding_maybe tv of
+ -- If tv has an unfolding, expand it
+ fv_tv = tyCoVarsOfType (tyVarKind tv) `unionVarSet`
+ case tyVarUnfolding_maybe tv of
Just ty -> tyCoVarsOfType ty
- Nothing -> tyCoVarsOfType (tyVarKind tv)
+ Nothing -> emptyVarSet
-- lists not in correspondence
insert _ _ _ = panic "scopedSort"
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -54,7 +54,7 @@ module GHC.Core.Utils (
collectMakeStaticArgs,
-- * Predicates on binds
- isJoinBind, isTypeBind, isTyCoBind,
+ isJoinBind, isTypeBind, isTypeBind_maybe, isTyCoBind,
-- * Tag inference
mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,
@@ -2775,6 +2775,10 @@ isTypeBind :: Bind b -> Bool
isTypeBind (NonRec _ (Type {})) = True
isTypeBind _ = False
+isTypeBind_maybe :: Bind b -> Maybe (b, Type)
+isTypeBind_maybe (NonRec tv (Type rhs_ty)) = Just (tv,rhs_ty)
+isTypeBind_maybe _ = Nothing
+
-- | `isTypeBind` is True of type bindings (@a = Type ty)
isTyCoBind :: Bind b -> Bool
isTyCoBind (NonRec _ (Type {})) = True
=====================================
compiler/GHC/Utils/Trace.hs
=====================================
@@ -1,6 +1,7 @@
-- | Tracing utilities
module GHC.Utils.Trace
( pprTrace
+ , pprTraceWhen
, pprTraceM
, pprTraceDebug
, pprTraceIt
@@ -42,6 +43,12 @@ pprTrace str doc x
| unsafeHasNoDebugOutput = x
| otherwise = pprDebugAndThen traceSDocContext trace (text str) doc x
+pprTraceWhen :: Bool -> String -> SDoc -> a -> a
+pprTraceWhen do_trace str doc x
+ | not do_trace = x
+ | unsafeHasNoDebugOutput = x
+ | otherwise = pprDebugAndThen traceSDocContext trace (text str) doc x
+
pprTraceM :: Applicative f => String -> SDoc -> f ()
pprTraceM str doc = pprTrace str doc (pure ())
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc780436d233e1ea8d892ea659f28721efca09d9...8ab348029e635aef41670ea094cc4ba11f47fd30
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc780436d233e1ea8d892ea659f28721efca09d9...8ab348029e635aef41670ea094cc4ba11f47fd30
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241101/7b98a683/attachment-0001.html>
More information about the ghc-commits
mailing list