import SimplUtils
import FamInstEnv ( FamInstEnv )
import Id
-import MkId ( mkImpossibleExpr, seqId )
-import Var
+import MkId ( seqId, realWorldPrimId )
+import MkCore ( mkImpossibleExpr )
import IdInfo
import Name ( mkSystemVarName, isExternalName )
-import Coercion
+import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst )
import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
-import CoreMonad ( SimplifierSwitch(..), Tick(..) )
+import CoreMonad ( Tick(..), SimplifierMode(..) )
import CoreSyn
-import Demand ( isStrictDmd, splitStrictSig )
+import Demand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule,
- exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
+import CoreUnfold
import CoreUtils
import qualified CoreSubst
-import CoreArity ( exprArity )
+import CoreArity
import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict, Arity )
import CostCentre ( currentCCS, pushCCisNop )
import TysPrim ( realWorldStatePrimTy )
-import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM )
-import Maybes ( orElse )
+import Maybes ( orElse, isNothing )
import Data.List ( mapAccumL )
import Outputable
import FastString
+import Pair
\end{code}
trace_bind False _ = \x -> x
simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs
- simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
+ simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
where
(env', b') = addBndrRules env b (lookupRecBndr env b)
\end{code}
go env [] = return env
go env ((old_bndr, new_bndr, rhs) : pairs)
- = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+ = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
; go env' pairs }
\end{code}
\begin{code}
simplRecOrTopPair :: SimplEnv
- -> TopLevelFlag
+ -> TopLevelFlag -> RecFlag
-> InId -> OutBndr -> InExpr -- Binder and rhs
-> SimplM SimplEnv -- Returns an env that includes the binding
-simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
| preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline
= do { tick (PreInlineUnconditionally old_bndr)
; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
| otherwise
- = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
- -- May not actually be recursive, but it doesn't matter
+ = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
\end{code}
-> SimplM SimplEnv
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
- = do { let rhs_env = rhs_se `setInScope` env
+ = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
+ do { let rhs_env = rhs_se `setInScope` env
(tvs, body) = case collectTyBinders rhs of
(tvs, body) | not_lam body -> (tvs,body)
| otherwise -> ([], rhs)
-> SimplM SimplEnv
simplNonRecX env bndr new_rhs
- | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
- = return env -- Here b is dead, and we avoid creating
+ | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+ = return env -- Here c is dead, and we avoid creating
+ -- the binding c = (a,b)
+ | Coercion co <- new_rhs
+ = return (extendCvSubst env bndr co)
| otherwise -- the binding b = (a,b)
= do { (env', bndr') <- simplBinder env bndr
; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
= do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
- ; (env2, rhs2) <-
+ ; (env2, rhs2) <-
if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
then do { tick LetFloatFromLet
; return (addFloats env env1, rhs1) } -- Add the floats to the main env
prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
- | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
+ | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type
, not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
= do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
; return (env', Cast rhs' co) }
= do { uniq <- getUniqueM
; let name = mkSystemVarName uniq (fsLit "a")
var = mkLocalIdWithInfo name expr_ty info
- ; env' <- completeNonRecX top_lvl env False var var expr
+ ; env' <- completeNonRecX top_lvl env False var var expr
; expr' <- simplVar env' var
; return (env', expr') }
-- The simplVar is needed becase we're constructing a new binding
-- * or by adding to the floats in the envt
completeBind env top_lvl old_bndr new_bndr new_rhs
- = do { let old_info = idInfo old_bndr
- old_unf = unfoldingInfo old_info
- occ_info = occInfo old_info
+ | isCoVar old_bndr
+ = case new_rhs of
+ Coercion co -> return (extendCvSubst env old_bndr co)
+ _ -> return (addNonRec env new_bndr new_rhs)
- ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
+ | otherwise
+ = ASSERT( isId new_bndr )
+ do { let old_info = idInfo old_bndr
+ old_unf = unfoldingInfo old_info
+ occ_info = occInfo old_info
- ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
+ -- Do eta-expansion on the RHS of the binding
+ -- See Note [Eta-expanding at let bindings] in SimplUtils
+ ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
+
+ -- Simplify the unfolding
+ ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
+
+ ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
-- Inline and discard the binding
- then do { tick (PostInlineUnconditionally old_bndr)
- ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $
- return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+ then do { tick (PostInlineUnconditionally old_bndr)
+ ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
+ else
+ do { let info1 = idInfo new_bndr `setArityInfo` new_arity
+
+ -- Unfolding info: Note [Setting the new unfolding]
+ info2 = info1 `setUnfoldingInfo` new_unfolding
+
+ -- Demand info: Note [Setting the demand info]
+ info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
+ | otherwise = info2
- else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
+ final_id = new_bndr `setIdInfo` info3
+
+ ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
+ return (addNonRec env final_id final_rhs) } }
+ -- The addNonRec adds it to the in-scope set too
------------------------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
-- opportunity to inline 'y' too.
addPolyBind top_lvl env (NonRec poly_id rhs)
- = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
+ = do { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
-- Assumes that poly_id did not have an INLINE prag
-- which is perhaps wrong. ToDo: think about this
- ; return (addNonRecWithUnf env poly_id rhs unfolding) }
-
-addPolyBind _ env bind@(Rec _) = return (extendFloats env bind)
- -- Hack: letrecs are more awkward, so we extend "by steam"
- -- without adding unfoldings etc. At worst this leads to
- -- more simplifier iterations
-
-------------------------------
-addNonRecWithUnf :: SimplEnv
- -> OutId -> OutExpr -- New binder and RHS
- -> Unfolding -- New unfolding
- -> SimplEnv
-addNonRecWithUnf env new_bndr new_rhs new_unfolding
- = let new_arity = exprArity new_rhs
- old_arity = idArity new_bndr
- info1 = idInfo new_bndr `setArityInfo` new_arity
-
- -- Unfolding info: Note [Setting the new unfolding]
- info2 = info1 `setUnfoldingInfo` new_unfolding
+ ; let final_id = setIdInfo poly_id $
+ idInfo poly_id `setUnfoldingInfo` unfolding
+ `setArityInfo` exprArity rhs
- -- Demand info: Note [Setting the demand info]
- info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
- | otherwise = info2
+ ; return (addNonRec env final_id rhs) }
- final_id = new_bndr `setIdInfo` info3
- dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
- in
- ASSERT( isId new_bndr )
- WARN( new_arity < old_arity || new_arity < dmd_arity,
- (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity
- <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) )
- -- Note [Arity decrease]
-
- final_id `seq` -- This seq forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
- addNonRec env final_id new_rhs
- -- The addNonRec adds it to the in-scope set too
+addPolyBind _ env bind@(Rec _)
+ = return (extendFloats env bind)
+ -- Hack: letrecs are more awkward, so we extend "by steam"
+ -- without adding unfoldings etc. At worst this leads to
+ -- more simplifier iterations
------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
- -> Id
- -> OccInfo -> OutExpr
+ -> InId
+ -> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
- = return (DFunUnfolding con ops')
+simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
+ = return (DFunUnfolding ar con ops')
where
- ops' = map (substExpr (text "simplUnfolding") env) ops
+ ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
-simplUnfolding env top_lvl id _ _
+simplUnfolding env top_lvl id _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_src = src, uf_guidance = guide })
- | isInlineRuleSource src
+ | isStableSource src
= do { expr' <- simplExpr rule_env expr
; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
- ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
- -- See Note [Top-level flag on inline rules] in CoreUnfold
+ is_top_lvl = isTopLevel top_lvl
+ ; case guide of
+ UnfWhen sat_ok _ -- Happens for INLINE things
+ -> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
+ -- Refresh the boring-ok flag, in case expr'
+ -- has got small. This happens, notably in the inlinings
+ -- for dfuns for single-method classes; see
+ -- Note [Single-method classes] in TcInstDcls.
+ -- A test case is Trac #4138
+ in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
+ -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+ _other -- Happens for INLINABLE things
+ -> let bottoming = isBottomingId id
+ in bottoming `seq` -- See Note [Force bottoming field]
+ return (mkUnfolding src' is_top_lvl bottoming expr')
+ -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
+ -- unfolding, and we need to make sure the guidance is kept up
+ -- to date with respect to any changes in the unfolding.
+ }
where
act = idInlineActivation id
rule_env = updMode (updModeForInlineRules act) env
- -- See Note [Simplifying gently inside InlineRules] in SimplUtils
-
-simplUnfolding _ top_lvl id _occ_info new_rhs _
- = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
- -- We make an unfolding *even for loop-breakers*.
- -- Reason: (a) It might be useful to know that they are WHNF
- -- (b) In TidyPgm we currently assume that, if we want to
- -- expose the unfolding then indeed we *have* an unfolding
- -- to expose. (We could instead use the RHS, but currently
- -- we don't.) The simple thing is always to have one.
+ -- See Note [Simplifying inside InlineRules] in SimplUtils
+
+simplUnfolding _ top_lvl id new_rhs _
+ = let bottoming = isBottomingId id
+ in bottoming `seq` -- See Note [Force bottoming field]
+ return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
+ -- We make an unfolding *even for loop-breakers*.
+ -- Reason: (a) It might be useful to know that they are WHNF
+ -- (b) In TidyPgm we currently assume that, if we want to
+ -- expose the unfolding then indeed we *have* an unfolding
+ -- to expose. (We could instead use the RHS, but currently
+ -- we don't.) The simple thing is always to have one.
\end{code}
+Note [Force bottoming field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to force bottoming, or the new unfolding holds
+on to the old unfolding (which is part of the id).
+
Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~
Generally speaking the arity of a binding should not decrease. But it *can*
simplExprF env e cont
= -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
- simplExprF' env e cont
+ simplExprF1 env e cont
-simplExprF' :: SimplEnv -> InExpr -> SimplCont
+simplExprF1 :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-simplExprF' env (Var v) cont = simplVarF env v cont
-simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
-simplExprF' env (Note n expr) cont = simplNote env n expr cont
-simplExprF' env (Cast body co) cont = simplCast env body co cont
-simplExprF' env (App fun arg) cont = simplExprF env fun $
+simplExprF1 env (Var v) cont = simplIdF env v cont
+simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont
+simplExprF1 env (Note n expr) cont = simplNote env n expr cont
+simplExprF1 env (Cast body co) cont = simplCast env body co cont
+simplExprF1 env (Coercion co) cont = simplCoercionF env co cont
+simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont )
+ rebuild env (Type (substTy env ty)) cont
+simplExprF1 env (App fun arg) cont = simplExprF env fun $
ApplyTo NoDup arg env cont
-simplExprF' env expr@(Lam _ _) cont
- = simplLam env (map zap bndrs) body cont
+simplExprF1 env expr@(Lam {}) cont
+ = simplLam env zapped_bndrs body cont
-- The main issue here is under-saturated lambdas
-- (\x1. \x2. e) arg1
-- Here x1 might have "occurs-once" occ-info, because occ-info
-- is computed assuming that a group of lambdas is applied
-- all at once. If there are too few args, we must zap the
- -- occ-info.
+ -- occ-info, UNLESS the remaining binders are one-shot
where
- n_args = countArgs cont
- n_params = length bndrs
(bndrs, body) = collectBinders expr
- zap | n_args >= n_params = \b -> b
- | otherwise = \b -> if isTyVar b then b
- else zapLamIdInfo b
- -- NB: we count all the args incl type args
- -- so we must count all the binders (incl type lambdas)
-
-simplExprF' env (Type ty) cont
- = ASSERT( contIsRhsOrArg cont )
- do { ty' <- simplCoercion env ty
- ; rebuild env (Type ty') cont }
-
-simplExprF' env (Case scrut bndr _ alts) cont
- | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+ zapped_bndrs | need_to_zap = map zap bndrs
+ | otherwise = bndrs
+
+ need_to_zap = any zappable_bndr (drop n_args bndrs)
+ n_args = countArgs cont
+ -- NB: countArgs counts all the args (incl type args)
+ -- and likewise drop counts all binders (incl type lambdas)
+
+ zappable_bndr b = isId b && not (isOneShotBndr b)
+ zap b | isTyVar b = b
+ | otherwise = zapLamIdInfo b
+
+simplExprF1 env (Case scrut bndr _ alts) cont
+ | sm_case_case (getMode env)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
| otherwise
= -- If case-of-case is off, simply simplify the case expression
-- in a vanilla Stop context, and rebuild the result around it
- do { case_expr' <- simplExprC env scrut case_cont
+ do { case_expr' <- simplExprC env scrut
+ (Select NoDup bndr alts env mkBoringStop)
; rebuild env case_expr' cont }
- where
- case_cont = Select NoDup bndr alts env mkBoringStop
-simplExprF' env (Let (Rec pairs) body) cont
+simplExprF1 env (Let (Rec pairs) body) cont
= do { env' <- simplRecBndrs env (map fst pairs)
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
; env'' <- simplRecBind env' NotTopLevel pairs
; simplExprF env'' body cont }
-simplExprF' env (Let (NonRec bndr rhs) body) cont
+simplExprF1 env (Let (NonRec bndr rhs) body) cont
= simplNonRecE env bndr (rhs, env) ([], body) cont
---------------------------------
new_ty = substTy env ty
---------------------------------
-simplCoercion :: SimplEnv -> InType -> SimplM OutType
--- The InType isn't *necessarily* a coercion, but it might be
--- (in a type application, say) and optCoercion is a no-op on types
+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
+-- We are simplifying a term of form (Coercion co)
+-- Simplify the InCoercion, and then try to combine with the
+-- context, to implememt the rule
+-- (Coercion co) |> g
+-- = Coercion (syn (nth 0 g) ; co ; nth 1 g)
+simplCoercionF env co cont
+ = do { co' <- simplCoercion env co
+ ; simpl_co co' cont }
+ where
+ simpl_co co (CoerceIt g cont)
+ = simpl_co new_co cont
+ where
+ new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1
+ [g0, g1] = decomposeCo 2 g
+
+ simpl_co co cont
+ = seqCo co `seq` rebuild env (Coercion co) cont
+
+simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion env co
- = seqType new_co `seq` return new_co
- where
- new_co = optCoercion (getTvSubst env) co
+ = let opt_co = optCoercion (getCvSubst env) co
+ in opt_co `seq` return opt_co
\end{code}
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- At this point the substitution in the SimplEnv should be irrelevant
-- only the in-scope set and floats should matter
-rebuild env expr cont0
- = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
- case cont0 of
+rebuild env expr cont
+ = case cont of
Stop {} -> return (env, expr)
- CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
+ CoerceIt co cont -> rebuild env (Cast expr co) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
; simplLam env' bs body cont }
- ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg
+ ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
+ | isSimplified dup_flag -> rebuild env (App expr arg) cont
+ | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
; rebuild env (App expr arg') cont }
\end{code}
where
addCoerce co cont = add_coerce co (coercionKind co) cont
- add_coerce _co (s1, k1) cont -- co :: ty~ty
- | s1 `coreEqType` k1 = cont -- is a no-op
+ add_coerce _co (Pair s1 k1) cont -- co :: ty~ty
+ | s1 `eqType` k1 = cont -- is a no-op
- add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
- | (_l1, t1) <- coercionKind co2
+ add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont)
+ | (Pair _l1 t1) <- coercionKind co2
-- e |> (g1 :: S1~L) |> (g2 :: L~T1)
-- ==>
-- e, if S1=T1
-- we may find (coerce T (coerce S (\x.e))) y
-- and we'd like it to simplify to e[y/x] in one round
-- of simplification
- , s1 `coreEqType` t1 = cont -- The coerces cancel out
- | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
+ , s1 `eqType` t1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt (mkTransCo co1 co2) cont
- add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
+ add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-- (f |> g) ty ---> (f ty) |> (g @ ty)
- -- This implements the PushT and PushC rules from the paper
+ -- This implements the PushT rule from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
- = let
- (new_arg_ty, new_cast)
- | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule
- | otherwise = (ty', mkInstCoercion co ty') -- PushT rule
- in
- ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont)
+ = ASSERT( isTyVar tyvar )
+ ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont)
+ where
+ new_cast = mkInstCo co arg_ty'
+ arg_ty' | isSimplified dup = arg_ty
+ | otherwise = substTy (arg_se `setInScope` env) arg_ty
+
+{-
+ add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Coercion arg_co) arg_se cont)
+ -- This implements the PushC rule from the paper
+ | Just (covar,_) <- splitForAllTy_maybe s1s2
+ = ASSERT( isCoVar covar )
+ ApplyTo Simplified (Coercion new_arg_co) (zapSubstEnv arg_se) (addCoerce co1 cont)
where
- ty' = substTy (arg_se `setInScope` env) arg_ty
- new_arg_co = mkCsel1Coercion co `mkTransCoercion`
- ty' `mkTransCoercion`
- mkSymCoercion (mkCsel2Coercion co)
-
- add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
- | not (isTypeArg arg) -- This implements the Push rule from the paper
- , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
+ [co0, co1] = decomposeCo 2 co
+ [co00, co01] = decomposeCo 2 co0
+
+ arg_co' | isSimplified dup = arg_co
+ | otherwise = substCo (arg_se `setInScope` env) arg_co
+ new_arg_co = co00 `mkTransCo`
+ arg_co' `mkTransCo`
+ mkSymCo co01
+-}
+
+ add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont)
+ | isFunTy s1s2 -- This implements the Push rule from the paper
+ , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg
-- (e |> (g :: s1s2 ~ t1->t2)) f
-- ===>
-- (e (f |> (arg g :: t1~s1))
-- t2 ~ s2 with left and right on the curried form:
-- (->) t1 t2 ~ (->) s1 s2
[co1, co2] = decomposeCo 2 co
- new_arg = mkCoerce (mkSymCoercion co1) arg'
+ new_arg = mkCoerce (mkSymCo co1) arg'
arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg
add_coerce co _ cont = CoerceIt co cont
%* *
%************************************************************************
+Note [Zap unfolding when beta-reducing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound variables can have stable unfoldings, such as
+ $j = \x. \b{Unf=Just x}. e
+See Note [Case binders and join points] below; the unfolding for lets
+us optimise e better. However when we beta-reduce it we want to
+revert to using the actual value, otherwise we can end up in the
+stupid situation of
+ let x = blah in
+ let b{Unf=Just x} = y
+ in ...b...
+Here it'd be far better to drop the unfolding and use the actual RHS.
+
\begin{code}
simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-- Beta reduction
simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
= do { tick (BetaReduction bndr)
- ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
+ ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
+ where
+ zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing]
+ | isId bndr, isStableUnfolding (realIdUnfolding bndr)
+ = setIdUnfolding bndr NoUnfolding
+ | otherwise = bndr
-- Not enough args, so there are real lambdas left to put in the result
simplLam env bndrs body cont
simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
| preInlineUnconditionally env NotTopLevel bndr rhs
= do { tick (PreInlineUnconditionally bndr)
- ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
+ ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
+ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
- | isStrictId bndr
+ | isStrictId bndr -- Includes coercions
= do { simplExprF (rhs_se `setFloats` env) rhs
(StrictBind bndr bndrs body env cont) }
simplVar :: SimplEnv -> InVar -> SimplM OutExpr
-- Look up an InVar in the environment
simplVar env var
- | isTyVar var
- = return (Type (substTyVar env var))
+ | isTyVar var = return (Type (substTyVar env var))
+ | isCoVar var = return (Coercion (substCoVar env var))
| otherwise
= case substId env var of
- DoneId var1 -> return (Var var1)
- DoneEx e -> return e
- ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e
+ DoneId var1 -> return (Var var1)
+ DoneEx e -> return e
+ ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
-simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
-simplVarF env var cont
+simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
+simplIdF env var cont
= case substId env var of
- DoneEx e -> simplExprF (zapSubstEnv env) e cont
- ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
- DoneId var1 -> completeCall env var1 cont
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
+ DoneId var1 -> completeCall env var1 cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
| not (dopt Opt_D_dump_inlinings dflags) = stuff
| not (dopt Opt_D_verbose_core2core dflags)
= if isExternalName (idName var) then
- pprTrace "Inlining done:" (ppr var) stuff
+ pprDefiniteTrace "Inlining done:" (ppr var) stuff
else stuff
| otherwise
- = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
+ = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var))
(vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr cont])
stuff
res = mkApps (Var fun) (reverse rev_args)
res_ty = exprType res
cont_ty = contResultType env res_ty cont
- co = mkUnsafeCoercion res_ty cont_ty
- mk_coerce expr | cont_ty `coreEqType` res_ty = expr
+ co = mkUnsafeCo res_ty cont_ty
+ mk_coerce expr | cont_ty `eqType` res_ty = expr
| otherwise = mkCoerce co expr
-rebuildCall env info (ApplyTo _ (Type arg_ty) se cont)
- = do { ty' <- simplCoercion (se `setInScope` env) arg_ty
- ; rebuildCall env (info `addArgTo` Type ty') cont }
+rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
+ = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
+ else simplType (se `setInScope` env) arg_ty
+ ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
rebuildCall env info@(ArgInfo { ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
- (ApplyTo _ arg arg_se cont)
- | str -- Strict argument
+ (ApplyTo dup_flag arg arg_se cont)
+ | isSimplified dup_flag -- See Note [Avoid redundant simplification]
+ = rebuildCall env (addArgTo info' arg) cont
+
+ | str -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
(StrictArg info' cci cont)
; mb_rule <- tryRules env rules fun args cont
; case mb_rule of {
Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $
- pushArgs env' (drop n_args args) cont ;
+ pushSimplifiedArgs env' (drop n_args args) cont ;
-- n_args says how many args the rule consumed
; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules
} }
It's very desirable to try RULES once the arguments have been simplified, because
doing so ensures that rule cascades work in one pass. Consider
{-# RULES g (h x) = k x
- f (k x) = x #-}
+ f (k x) = x #-}
...f (g (h x))...
Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
we match f's rules against the un-simplified RHS, it won't match. This
op ($p1 ($p2 (df d)))
We want all this to unravel in one sweeep.
+Note [Avoid redundant simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because RULES apply to simplified arguments, there's a danger of repeatedly
+simplifying already-simplified arguments. An important example is that of
+ (>>=) d e1 e2
+Here e1, e2 are simplified before the rule is applied, but don't really
+participate in the rule firing. So we mark them as Simplified to avoid
+re-simplifying them.
+
Note [Shadowing]
~~~~~~~~~~~~~~~~
This part of the simplifier may break the no-shadowing invariant
; case activeRule dflags env of {
Nothing -> return Nothing ; -- No rules apply
Just act_fn ->
- case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of {
+ case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of {
Nothing -> return Nothing ; -- No rule matches
Just (rule, rule_rhs) ->
return (Just (ruleArity rule, rule_rhs)) }}}}
where
trace_dump dflags rule rule_rhs stuff
- | not (dopt Opt_D_dump_rule_firings dflags) = stuff
- | not (dopt Opt_D_verbose_core2core dflags)
+ | not (dopt Opt_D_dump_rule_firings dflags)
+ , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
+
+ | not (dopt Opt_D_dump_rule_rewrites dflags)
+ = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff
- = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
| otherwise
- = pprTrace "Rule fired"
+ = pprDefiniteTrace "Rule fired"
(vcat [text "Rule:" <+> ftext (ru_name rule),
- text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
+ text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont])
stuff
%************************************************************************
%* *
- Rebuilding a cse expression
+ Rebuilding a case expression
%* *
%************************************************************************
The case-elimination transformation discards redundant case expressions.
Start with a simple situation:
- case x# of ===> e[x#/y#]
+ case x# of ===> let y# = x# in e
y# -> e
(when x#, y# are of primitive type, of course). We can't (in general)
DEFAULT, after which it's an instance of the previous case. This
really only shows up in eliminating error-checking code.
-We also make sure that we deal with this very common case:
+Note that SimplUtils.mkCase combines identical RHSs. So
+
+ case e of ===> case e of DEFAULT -> r
+ True -> r
+ False -> r
+
+Now again the case may be elminated by the CaseElim transformation.
+This includes things like (==# a# b#)::Bool so that we simplify
+ case ==# a# b# of { True -> x; False -> x }
+to just
+ x
+This particular example shows up in default methods for
+comparision operations (e.g. in (>=) for Int.Int32)
+
+Note [CaseElimination: lifted case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We also make sure that we deal with this very common case,
+where x has a lifted type:
case e of
x -> ...x...
then we want to inline it. We have to be careful that this doesn't
make the program terminate when it would have diverged before, so we
check that
- - e is already evaluated (it may so if e is a variable)
- - x is used strictly, or
-
-Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
-
- case e of ===> case e of DEFAULT -> r
- True -> r
- False -> r
-
-Now again the case may be elminated by the CaseElim transformation.
+ (a) 'e' is already evaluated (it may so if e is a variable)
+ Specifically we check (exprIsHNF e)
+or
+ (b) the scrutinee is a variable and 'x' is used strictly
+or
+ (c) 'x' is not used at all and e is ok-for-speculation
+
+For the (c), consider
+ case (case a ># b of { True -> (p,q); False -> (q,p) }) of
+ r -> blah
+The scrutinee is ok-for-speculation (it looks inside cases), but we do
+not want to transform to
+ let r = case a ># b of { True -> (p,q); False -> (q,p) }
+ in blah
+because that builds an unnecessary thunk.
Further notes about case elimination
Nothing -> missingAlt env case_bndr alts cont
Just (_, bs, rhs) -> simple_rhs bs rhs }
- | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut
+ | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
-- Works when the scrutinee is a variable with a known unfolding
-- as well as when it's an explicit constructor application
= do { tick (KnownBranch case_bndr)
rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
-- See if we can get rid of the case altogether
- -- See Note [Case eliminiation]
+ -- See Note [Case elimination]
-- mkCase made sure that if all the alternatives are equal,
-- then there is now only one (DEFAULT) rhs
| all isDeadBinder bndrs -- bndrs are [InId]
- -- Check that the scrutinee can be let-bound instead of case-bound
- , exprOkForSpeculation scrut
- -- OK not to evaluate it
- -- This includes things like (==# a# b#)::Bool
- -- so that we simplify
- -- case ==# a# b# of { True -> x; False -> x }
- -- to just
- -- x
- -- This particular example shows up in default methods for
- -- comparision operations (e.g. in (>=) for Int.Int32)
- || exprIsHNF scrut -- It's already evaluated
- || var_demanded_later scrut -- It'll be demanded later
-
--- || not opt_SimplPedanticBottoms) -- Or we don't care!
--- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
--- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
--- its argument: case x of { y -> dataToTag# y }
--- Here we must *not* discard the case, because dataToTag# just fetches the tag from
--- the info pointer. So we'll be pedantic all the time, and see if that gives any
--- other problems
--- Also we don't want to discard 'seq's
+ , if isUnLiftedType (idType case_bndr)
+ then ok_for_spec -- Satisfy the let-binding invariant
+ else elim_lifted
= do { tick (CaseElim case_bndr)
; env' <- simplNonRecX env case_bndr scrut
+ -- If case_bndr is deads, simplNonRecX will discard
; simplExprF env' rhs cont }
where
- -- The case binder is going to be evaluated later,
- -- and the scrutinee is a simple variable
- var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
- && not (isTickBoxOp v)
+ elim_lifted -- See Note [Case elimination: lifted case]
+ = exprIsHNF scrut
+ || (strict_case_bndr && scrut_is_var scrut)
+ -- The case binder is going to be evaluated later,
+ -- and the scrutinee is a simple variable
+
+ || (is_plain_seq && ok_for_spec)
+ -- Note: not the same as exprIsHNF
+
+ ok_for_spec = exprOkForSpeculation scrut
+ is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect
+ strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)
+
+ scrut_is_var (Cast s _) = scrut_is_var s
+ scrut_is_var (Var v) = not (isTickBoxOp v)
-- ugly hack; covering this case is what
-- exprOkForSpeculation was intended for.
- var_demanded_later _ = False
+ scrut_is_var _ = False
+
--------------------------------------------------
-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId
In practice, the scrutinee is almost always a variable, so we pretty
much always zap the OccInfo of the binders. It doesn't matter much though.
-
-Note [Case of cast]
-~~~~~~~~~~~~~~~~~~~
-Consider case (v `cast` co) of x { I# y ->
- ... (case (v `cast` co) of {...}) ...
-We'd like to eliminate the inner case. We can get this neatly by
-arranging that inside the outer case we add the unfolding
- v |-> x `cast` (sym co)
-to v. Then we should inline v at the inner case, cancel the casts, and away we go
-
Note [Improving seq]
~~~~~~~~~~~~~~~~~~~
Consider
so that 'rhs' can take advantage of the form of x'.
-Notice that Note [Case of cast] may then apply to the result.
+Notice that Note [Case of cast] (in OccurAnal) may then apply to the result.
Nota Bene: We only do the [Improving seq] transformation if the
case binder 'x' is actually used in the rhs; that is, if the case
; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
- ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
+ ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
+ ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
+ imposs_deflt_cons case_bndr' cont') in_alts
; return (scrut', case_bndr', alts') }
-> SimplM (SimplEnv, OutExpr, OutId)
-- Note [Improving seq]
improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
- | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note!
+ | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq]
, Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ty2
- ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
+ ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
env2 = extendIdSubst env case_bndr rhs
; return (env2, scrut `Cast` co, case_bndr2) }
------------------------------------
simplAlt :: SimplEnv
- -> [AltCon] -- These constructors can't be present when
- -- matching the DEFAULT alternative
- -> OutId -- The case binder
+ -> Maybe OutId -- Scrutinee
+ -> [AltCon] -- These constructors can't be present when
+ -- matching the DEFAULT alternative
+ -> OutId -- The case binder
-> SimplCont
-> InAlt
-> SimplM OutAlt
-simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
+simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
= ASSERT( null bndrs )
- do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
+ do { let env' = addBinderUnfolding env scrut case_bndr'
+ (mkOtherCon imposs_deflt_cons)
-- Record the constructors that the case-binder *can't* be.
; rhs' <- simplExprC env' rhs cont'
; return (DEFAULT, [], rhs') }
-simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
+simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
= ASSERT( null bndrs )
- do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
+ do { let env' = addBinderUnfolding env scrut case_bndr'
+ (mkSimpleUnfolding (Lit lit))
; rhs' <- simplExprC env' rhs cont'
; return (LitAlt lit, [], rhs') }
-simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
+simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs)
= do { -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the
-- data constructor as certainly-evaluated.
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
con_args = map Type inst_tys' ++ varsToCoreExprs vs'
- env'' = addBinderUnfolding env' case_bndr'
- (mkConApp con con_args)
+ unf = mkSimpleUnfolding (mkConApp con con_args)
+ env'' = addBinderUnfolding env' scrut case_bndr' unf
; rhs' <- simplExprC env'' rhs cont'
; return (DataAlt con, vs', rhs') }
| isMarkedStrict str = evald_v : go vs' strs
| otherwise = zapped_v : go vs' strs
where
- zapped_v = zap_occ_info v
+ zapped_v = zapBndrOccInfo keep_occ_info v
evald_v = zapped_v `setIdUnfolding` evaldUnfolding
go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
-- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
-- ==> case e of t { (a,b) -> ...(a)... }
-- Look, Ma, a is alive now.
- zap_occ_info = zapCasePatIdOcc case_bndr'
-
-addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
-addBinderUnfolding env bndr rhs
- = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
+ keep_occ_info = isDeadBinder case_bndr' && isNothing scrut
-addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
-addBinderOtherCon env bndr cons
- = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
+addBinderUnfolding :: SimplEnv -> Maybe OutId -> Id -> Unfolding -> SimplEnv
+addBinderUnfolding env scrut bndr unf
+ = case scrut of
+ Just v -> modifyInScope env1 (v `setIdUnfolding` unf)
+ _ -> env1
+ where
+ env1 = modifyInScope env bndr_w_unf
+ bndr_w_unf = bndr `setIdUnfolding` unf
-zapCasePatIdOcc :: Id -> Id -> Id
+zapBndrOccInfo :: Bool -> Id -> Id
-- Consider case e of b { (a,b) -> ... }
-- Then if we bind b to (a,b) in "...", and b is not dead,
-- then we must zap the deadness info on a,b
-zapCasePatIdOcc case_bndr
- | isDeadBinder case_bndr = \ pat_id -> pat_id
- | otherwise = \ pat_id -> zapIdOccInfo pat_id
+zapBndrOccInfo keep_occ_info pat_id
+ | keep_occ_info = pat_id
+ | otherwise = zapIdOccInfo pat_id
\end{code}
+Note [Add unfolding for scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general it's unlikely that a variable scrutinee will appear
+in the case alternatives case x of { ...x unlikely to appear... }
+because the binder-swap in OccAnal has got rid of all such occcurrences
+See Note [Binder swap] in OccAnal.
+
+BUT it is still VERY IMPORTANT to add a suitable unfolding for a
+variable scrutinee, in simplAlt. Here's why
+ case x of y
+ (a,b) -> case b of c
+ I# v -> ...(f y)...
+There is no occurrence of 'b' in the (...(f y)...). But y gets
+the unfolding (a,b), and *that* mentions b. If f has a RULE
+ RULE f (p, I# q) = ...
+we want that rule to match, so we must extend the in-scope env with a
+suitable unfolding for 'y'. It's *essential* for rule matching; but
+it's also good for case-elimintation -- suppose that 'f' was inlined
+and did multi-level case analysis, then we'd solve it in one
+simplifier sweep instead of two.
+
+Exactly the same issue arises in SpecConstr;
+see Note [Add scrutinee to ValueEnv too] in SpecConstr
%************************************************************************
%* *
; env'' <- bind_case_bndr env'
; simplExprF env'' rhs cont }
where
- zap_occ = zapCasePatIdOcc bndr -- bndr is an InId
+ zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId
-- Ugh!
bind_args env' [] _ = return env'
\begin{code}
prepareCaseCont :: SimplEnv
-> [InAlt] -> SimplCont
- -> SimplM (SimplEnv, SimplCont,SimplCont)
- -- Return a duplicatable continuation, a non-duplicable part
- -- plus some extra bindings (that scope over the entire
- -- continunation)
-
- -- No need to make it duplicatable if there's only one alternative
-prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
-prepareCaseCont env _ cont = mkDupableCont env cont
+ -> SimplM (SimplEnv, SimplCont, SimplCont)
+-- We are considering
+-- K[case _ of { p1 -> r1; ...; pn -> rn }]
+-- where K is some enclosing continuation for the case
+-- Goal: split K into two pieces Kdup,Knodup so that
+-- a) Kdup can be duplicated
+-- b) Knodup[Kdup[e]] = K[e]
+-- The idea is that we'll transform thus:
+-- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
+--
+-- We also return some extra bindings in SimplEnv (that scope over
+-- the entire continuation)
+
+prepareCaseCont env alts cont
+ | many_alts alts = mkDupableCont env cont
+ | otherwise = return (env, cont, mkBoringStop)
+ where
+ many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
+ many_alts [] = False -- See Note [Bottom alternatives]
+ many_alts [_] = False
+ many_alts (alt:alts)
+ | is_bot_alt alt = many_alts alts
+ | otherwise = not (all is_bot_alt alts)
+
+ is_bot_alt (_,_,rhs) = exprIsBottom rhs
\end{code}
+Note [Bottom alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+ case (case x of { A -> error .. ; B -> e; C -> error ..)
+ of alts
+then we can just duplicate those alts because the A and C cases
+will disappear immediately. This is more direct than creating
+join points and inlining them away; and in some cases we would
+not even create the join points (see Note [Single-alternative case])
+and we would keep the case-of-case which is silly. See Trac #4930.
+
\begin{code}
mkDupableCont :: SimplEnv -> SimplCont
-> SimplM (SimplEnv, SimplCont, SimplCont)
-- let ji = \xij -> ei
-- in case [...hole...] of { pi -> ji xij }
do { tick (CaseOfCase case_bndr)
- ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
- -- NB: call mkDupableCont here, *not* prepareCaseCont
- -- We must make a duplicable continuation, whereas prepareCaseCont
- -- doesn't when there is a single case branch
+ ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
+ -- NB: We call prepareCaseCont here. If there is only one
+ -- alternative, then dup_cont may be big, but that's ok
+ -- becuase we push it into the single alternative, and then
+ -- use mkDupableAlt to turn that simplified alternative into
+ -- a join point if it's too big to duplicate.
+ -- And this is important: see Note [Fusing case continuations]
; let alt_env = se `setInScope` env'
; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
- ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
+ ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
-- Safe to say that there are no handled-cons for the DEFAULT case
-- NB: simplBinder does not zap deadness occ-info, so
-- a dead case_bndr' will still advertise its deadness
DataAlt dc -> setIdUnfolding case_bndr unf
where
-- See Note [Case binders and join points]
- unf = mkInlineRule rhs Nothing
+ unf = mkInlineUnfolding Nothing rhs
rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
++ varsToCoreExprs bndrs')
-- See Note [Duplicated env]
\end{code}
+Note [Fusing case continuations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important to fuse two successive case continuations when the
+first has one alternative. That's why we call prepareCaseCont here.
+Consider this, which arises from thunk splitting (see Note [Thunk
+splitting] in WorkWrap):
+
+ let
+ x* = case (case v of {pn -> rn}) of
+ I# a -> I# a
+ in body
+
+The simplifier will find
+ (Var v) with continuation
+ Select (pn -> rn) (
+ Select [I# a -> I# a] (
+ StrictBind body Stop
+
+So we'll call mkDupableCont on
+ Select [I# a -> I# a] (StrictBind body Stop)
+There is just one alternative in the first Select, so we want to
+simplify the rhs (I# a) with continuation (StricgtBind body Stop)
+Supposing that body is big, we end up with
+ let $j a = <let x = I# a in body>
+ in case v of { pn -> case rn of
+ I# a -> $j a }
+This is just what we want because the rn produces a box that
+the case rn cancels with.
+
+See Trac #4957 a fuller example.
+
Note [Case binders and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
Unlike StrictArg, there doesn't seem anything to gain from
duplicating a StrictBind continuation, so we don't.
-The desire not to duplicate is the entire reason that
-mkDupableCont returns a pair of continuations.
-
Note [Single-alternative cases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
"see" the MkT any more, because it's big and won't get duplicated.
And, what is worse, nothing was gained by the case-of-case transform.
-When should use this case of mkDupableCont?
-However, matching on *any* single-alternative case is a *disaster*;
+So, in circumstances like these, we don't want to build join points
+and push the outer case into the branches of the inner one. Instead,
+don't duplicate the continuation.
+
+When should we use this strategy? We should not use it on *every*
+single-alternative case:
e.g. case (case ....) of (a,b) -> (# a,b #)
- We must push the outer case into the inner one!
+Here we must push the outer case into the inner one!
Other choices:
* Match [(DEFAULT,_,_)], but in the common case of Int,
the *un-simplified* rhs, which is fine. It might get bigger or
smaller after simplification; if it gets smaller, this case might
fire next time round. NB also that we must test contIsDupable
- case_cont *btoo, because case_cont might be big!
+ case_cont *too, because case_cont might be big!
HOWEVER: I found that this version doesn't work well, because
we can get let x = case (...) of { small } in ...case x...
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's another single-alternative where we really want to do case-of-case:
-data Mk1 = Mk1 Int#
-data Mk1 = Mk2 Int#
+data Mk1 = Mk1 Int# | Mk2 Int#
M1.f =
\r [x_s74 y_s6X]
So the outer case is doing *nothing at all*, other than serving as a
join-point. In this case we really want to do case-of-case and decide
-whether to use a real join point or just duplicate the continuation.
+whether to use a real join point or just duplicate the continuation:
+
+ let $j s7c = case x of
+ Mk1 ipv77 -> (==) s7c ipv77
+ Mk1 ipv79 -> (==) s7c ipv79
+ in
+ case y of
+ Mk1 ipv70 -> $j ipv70
+ Mk2 ipv72 -> $j ipv72
Hence: check whether the case binder's type is unlifted, because then
the outer case is *not* a seq.
projects / ghc-hetmet.git / blobdiff