import MkId ( mkImpossibleExpr, seqId )
import Var
import IdInfo
+import Name ( mkSystemVarName )
import Coercion
import FamInstEnv ( topNormaliseType )
-import DataCon ( dataConRepStrictness, dataConUnivTyVars )
+import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
import CoreSyn
import NewDemand ( isStrictDmd, splitStrictSig )
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
+import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule,
+ exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
import CoreUtils
+import qualified CoreSubst
import CoreArity ( exprArity )
import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict, Arity )
-import CostCentre ( currentCCS )
+import CostCentre ( currentCCS, pushCCisNop )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRuleLoopBreaker )
+import MonadUtils ( foldlM, mapAccumLM )
import Maybes ( orElse )
import Data.List ( mapAccumL )
import Outputable
%************************************************************************
\begin{code}
-simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
simplTopBinds env0 binds0
= do { -- Put all the top-level binders into scope at the start
dopt Opt_D_dump_rule_firings dflags
; env2 <- simpl_binds dump_flag env1 binds0
; freeTick SimplifierDone
- ; return (getFloats env2) }
+ ; return env2 }
where
-- We need to track the zapped top-level binders, because
-- they should have their fragile IdInfo zapped (notably occurrence info)
-- See Note [Floating and type abstraction] in SimplUtils
-- Simplify the RHS
- ; (body_env1, body1) <- simplExprF body_env body mkBoringStop
-
+ ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
-- ANF-ise a constructor or PAP rhs
- ; (body_env2, body2) <- prepareRhs body_env1 body1
+ ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1
; (env', rhs')
<- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam env tvs' body3
- ; let env' = foldl (addPolyBind top_lvl) env poly_binds
+ ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
; return (env', rhs') }
; completeBind env' top_lvl bndr bndr1 rhs' }
-> SimplM SimplEnv
completeNonRecX env is_strict old_bndr new_bndr new_rhs
- = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
+ = do { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs
; (env2, rhs2) <-
if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
then do { tick LetFloatFromLet
That's what the 'go' loop in prepareRhs does
\begin{code}
-prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
+prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
-prepareRhs env (Cast rhs co) -- Note [Float coercions]
+prepareRhs env id (Cast rhs co) -- Note [Float coercions]
| (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') <- makeTrivial env rhs
+ = do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs
; return (env', Cast rhs' co) }
+ where
+ sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info
+ `setNewDemandInfo` newDemandInfo info
+ info = idInfo id
-prepareRhs env0 rhs0
+prepareRhs env0 _ rhs0
= do { (_is_val, env1, rhs1) <- go 0 env0 rhs0
; return (env1, rhs1) }
where
is_val = n_val_args > 0 -- There is at least one arg
-- ...and the fun a constructor or PAP
&& (isConLikeId fun || n_val_args < idArity fun)
+ -- See Note [CONLIKE pragma] in BasicTypes
go _ env other
= return (False, env, other)
\end{code}
go n = case x of { T m -> go (n-m) }
-- This case should optimise
+Note [Preserve strictness when floating coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the Note [Float coercions] transformation, keep the strictness info.
+Eg
+ f = e `cast` co -- f has strictness SSL
+When we transform to
+ f' = e -- f' also has strictness SSL
+ f = f' `cast` co -- f still has strictness SSL
+
+Its not wrong to drop it on the floor, but better to keep it.
+
Note [Float coercions (unlifted)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
BUT don't do [Float coercions] if 'e' has an unlifted type.
\begin{code}
makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Binds the expression to a variable, if it's not trivial, returning the variable
-makeTrivial env expr
+makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr
+
+makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
+-- Propagate strictness and demand info to the new binder
+-- Note [Preserve strictness when floating coercions]
+makeTrivialWithInfo env info expr
| exprIsTrivial expr
= return (env, expr)
| otherwise -- See Note [Take care] below
- = do { var <- newId (fsLit "a") (exprType expr)
+ = do { uniq <- getUniqueM
+ ; let name = mkSystemVarName uniq (fsLit "a")
+ var = mkLocalIdWithInfo name (exprType expr) info
; env' <- completeNonRecX env False var var expr
--- pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var)))
--- , ppr expr
--- , ppr (substExpr env' (Var var))
--- , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $
; return (env', substExpr env' (Var var)) }
-- The substitution is needed becase we're constructing a new binding
-- a = rhs
-- * or by adding to the floats in the envt
completeBind env top_lvl old_bndr new_bndr new_rhs
- | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
- -- Inline and discard the binding
- = do { tick (PostInlineUnconditionally old_bndr)
- ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
- return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
- -- Use the substitution to make quite, quite sure that the
- -- substitution will happen, since we are going to discard the binding
+ = do { let old_info = idInfo old_bndr
+ old_unf = unfoldingInfo old_info
+ occ_info = occInfo old_info
- | otherwise
- = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
- where
- unfolding | omit_unfolding = NoUnfolding
- | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
- wkr = substWorker env (workerInfo old_info)
- omit_unfolding = isNonRuleLoopBreaker occ_info
- -- or not (activeInline env old_bndr)
- -- Do *not* trim the unfolding in SimplGently, else
- -- the specialiser can't see it!
-
------------------
-addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv
+ ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
+
+ ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
+ -- Inline and discard the binding
+ then do { tick (PostInlineUnconditionally old_bndr)
+ ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+ -- Use the substitution to make quite, quite sure that the
+ -- substitution will happen, since we are going to discard the binding
+
+ else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
+
+------------------------------
+addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
-- Add a new binding to the environment, complete with its unfolding
-- but *do not* do postInlineUnconditionally, because we have already
-- processed some of the scope of the binding
-- opportunity to inline 'y' too.
addPolyBind top_lvl env (NonRec poly_id rhs)
- = addNonRecWithUnf env poly_id rhs unfolding NoWorker
- where
- unfolding | not (activeInline env poly_id) = NoUnfolding
- | otherwise = mkUnfolding (isTopLevel top_lvl) rhs
- -- addNonRecWithInfo adds the new binding in the
- -- proper way (ie complete with unfolding etc),
- -- and extends the in-scope set
+ = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo 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 _) = extendFloats env bind
+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 -> WorkerInfo -- and unfolding
- -> SimplEnv
--- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
-addNonRecWithUnf env new_bndr rhs unfolding wkr
- = ASSERT( isId new_bndr )
+ -> 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
+
+ -- Demand info: Note [Setting the demand info]
+ info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
+ | otherwise = info2
+
+ final_id = new_bndr `setIdInfo` info3
+ dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness 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 rhs )
+ <+> ppr new_arity <+> ppr dmd_arity) )
-- Note [Arity decrease]
- final_id `seq` -- This seq forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- addNonRec env final_id rhs
- -- The addNonRec adds it to the in-scope set too
- where
- dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
- old_arity = idArity new_bndr
- -- Arity info
- new_arity = exprArity rhs
- new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
-
- -- Unfolding info
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
-
- -- Demand info
- -- If the unfolding is a value, the demand info may
- -- go pear-shaped, so we nuke it. Example:
- -- let x = (a,b) in
- -- case x of (p,q) -> h p q x
- -- Here x is certainly demanded. But after we've nuked
- -- the case, we'll get just
- -- let x = (a,b) in h a b x
- -- and now x is not demanded (I'm assuming h is lazy)
- -- This really happens. Similarly
- -- let f = \x -> e in ...f..f...
- -- After inlining f at some of its call sites the original binding may
- -- (for example) be no longer strictly demanded.
- -- The solution here is a bit ad hoc...
- info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
- `setWorkerInfo` wkr
-
- final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
- | otherwise = info_w_unf
-
- final_id = new_bndr `setIdInfo` final_info
+ 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
+
+------------------------------
+simplUnfolding :: SimplEnv-> TopLevelFlag
+ -> Id -- Debug output only
+ -> OccInfo -> OutExpr
+ -> Unfolding -> SimplM Unfolding
+-- Note [Setting the new unfolding]
+simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
+ = return (DFunUnfolding con ops')
+ where
+ ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops
+
+simplUnfolding env top_lvl _ _ _
+ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
+ , uf_guidance = guide@(InlineRule {}) })
+ = do { expr' <- simplExpr (updMode updModeForInlineRules env) expr
+ -- See Note [Simplifying gently inside InlineRules] in SimplUtils
+ ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide)
+ ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity
+ (guide { ir_info = mb_wkr' })) }
+ -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+simplUnfolding _ top_lvl _ occ_info new_rhs _
+ | omit_unfolding = return NoUnfolding
+ | otherwise = return (mkUnfolding (isTopLevel top_lvl) new_rhs)
+ where
+ omit_unfolding = isNonRuleLoopBreaker occ_info
\end{code}
Note [Arity decrease]
That's why Specialise goes to a little trouble to pin the right arity
on specialised functions too.
+Note [Setting the new unfolding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* If there's an INLINE pragma, we simplify the RHS gently. Maybe we
+ should do nothing at all, but simplifying gently might get rid of
+ more crap.
+
+* If not, we make an unfolding from the new RHS. But *only* for
+ non-loop-breakers. Making loop breakers not have an unfolding at all
+ means that we can avoid tests in exprIsConApp, for example. This is
+ important: if exprIsConApp says 'yes' for a recursive thing, then we
+ can get into an infinite loop
+
+If there's an InlineRule on a loop breaker, we hang on to the inlining.
+It's pretty dodgy, but the user did say 'INLINE'. May need to revisit
+this choice.
+
+Note [Setting the demand info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the unfolding is a value, the demand info may
+go pear-shaped, so we nuke it. Example:
+ let x = (a,b) in
+ case x of (p,q) -> h p q x
+Here x is certainly demanded. But after we've nuked
+the case, we'll get just
+ let x = (a,b) in h a b x
+and now x is not demanded (I'm assuming h is lazy)
+This really happens. Similarly
+ let f = \x -> e in ...f..f...
+After inlining f at some of its call sites the original binding may
+(for example) be no longer strictly demanded.
+The solution here is a bit ad hoc...
+
%************************************************************************
%* *
simplExprF' env (Type ty) cont
= ASSERT( contIsRhsOrArg cont )
- do { ty' <- simplType env ty
+ do { ty' <- simplCoercion env ty
; rebuild env (Type ty') cont }
simplExprF' env (Case scrut bndr _ alts) cont
seqType new_ty `seq` return new_ty
where
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
+simplCoercion env co
+ = do { co' <- simplType env co
+ ; return (optCoercion co') }
\end{code}
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
- StrictArg fun _ info cont -> rebuildCall env (fun `App` expr) info 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
simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
-> SimplM (SimplEnv, OutExpr)
simplCast env body co0 cont0
- = do { co1 <- simplType env co0
+ = do { co1 <- simplCoercion env co0
; simplExprF env body (addCoerce co1 cont0) }
where
addCoerce co cont = add_coerce co (coercionKind co) cont
add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-- (f |> g) ty ---> (f ty) |> (g @ ty)
- -- This implements the PushT rule from the paper
+ -- This implements the PushT and PushC rules from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
- , not (isCoVar tyvar)
- = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
+ = 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)
where
ty' = substTy (arg_se `setInScope` env) arg_ty
-
- -- ToDo: the PushC rule is not implemented at all
+ 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
-- But it isn't a common case.
--
-- Example of use: Trac #995
- = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
+ = ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont)
where
-- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
-- t2 ~ s2 with left and right on the curried form:
------------------
simplNonRecE :: SimplEnv
- -> InId -- The binder
+ -> InBndr -- The binder
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
-> ([InBndr], InExpr) -- Body of the let/lambda
-- \xs.e
simplNote :: SimplEnv -> Note -> CoreExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
simplNote env (SCC cc) e cont
+ | pushCCisNop cc (getEnclosingCC env) -- scc "f" (...(scc "f" e)...)
+ = simplExprF env e cont -- ==> scc "f" (...e...)
+ | otherwise
= do { e' <- simplExpr (setEnclosingCC env currentCCS) e
; rebuild env (mkSCC cc e') cont }
--- See notes with SimplMonad.inlineMode
-simplNote env InlineMe e cont
- | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
- = do { -- Don't inline inside an INLINE expression
- e' <- simplExprC (setMode inlineMode env) e inside
- ; rebuild env (mkInlineMe e') outside }
-
- | otherwise -- Dissolve the InlineMe note if there's
- -- an interesting context of any kind to combine with
- -- (even a type application -- anything except Stop)
- = simplExprF env e cont
-
-simplNote env (CoreNote s) e cont = do
- e' <- simplExpr env e
- rebuild env (Note (CoreNote s) e') cont
+simplNote env (CoreNote s) e cont
+ = do { e' <- simplExpr env e
+ ; rebuild env (Note (CoreNote s) e') cont }
\end{code}
= 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 (zapSubstEnv env) var1 cont
+ DoneId var1 -> completeCall env var1 cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
completeCall env var cont
- = do { let (args,call_cont) = contArgs cont
+ = do { ------------- Try inlining ----------------
+ dflags <- getDOptsSmpl
+ ; let (args,call_cont) = contArgs cont
-- The args are OutExprs, obtained by *lazily* substituting
-- in the args found in cont. These args are only examined
-- to limited depth (unless a rule fires). But we must do
-- the substitution; rule matching on un-simplified args would
-- be bogus
- ------------- First try rules ----------------
- -- Do this before trying inlining. Some functions have
- -- rules *and* are strict; in this case, we don't want to
- -- inline the wrapper of the non-specialised thing; better
- -- to call the specialised thing instead.
- --
- -- We used to use the black-listing mechanism to ensure that inlining of
- -- the wrapper didn't occur for things that have specialisations till a
- -- later phase, so but now we just try RULES first
- --
- -- See also Note [Rules for recursive functions]
- ; mb_rule <- tryRules env var args call_cont
- ; case mb_rule of {
- Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ;
- -- The ruleArity says how many args the rule consumed
- ; Nothing -> do -- No rules
-
-
- ------------- Next try inlining ----------------
- { dflags <- getDOptsSmpl
- ; let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
- n_val_args = length arg_infos
- interesting_cont = interestingCallContext call_cont
- active_inline = activeInline env var
- maybe_inline = callSiteInline dflags active_inline var
- (null args) arg_infos interesting_cont
+ arg_infos = [interestingArg arg | arg <- args, isValArg arg]
+ n_val_args = length arg_infos
+ interesting_cont = interestingCallContext call_cont
+ active_inline = activeInline env var
+ maybe_inline = callSiteInline dflags active_inline var
+ (null args) arg_infos interesting_cont
; case maybe_inline of {
Just unfolding -- There is an inlining!
-> do { tick (UnfoldingDone var)
text "Cont: " <+> ppr call_cont])
else
id)
- simplExprF env unfolding cont }
+ simplExprF (zapSubstEnv env) unfolding cont }
- ; Nothing -> -- No inlining!
+ ; Nothing -> do -- No inlining!
- ------------- No inlining! ----------------
- -- Next, look for rules or specialisations that match
- --
- rebuildCall env (Var var)
- (mkArgInfo var n_val_args call_cont) cont
- }}}}
+ { rule_base <- getSimplRules
+ ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
+ ; rebuildCall env info cont
+ }}}
rebuildCall :: SimplEnv
- -> OutExpr -- Function
-> ArgInfo
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
-rebuildCall env fun (ArgInfo { ai_strs = [] }) cont
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
-- When we run out of strictness args, it means
-- that the call is definitely bottom; see SimplUtils.mkArgInfo
-- Then we want to discard the entire strict continuation. E.g.
-- the continuation, leaving just the bottoming expression. But the
-- type might not be right, so we may have to add a coerce.
| not (contIsTrivial cont) -- Only do this if there is a non-trivial
- = return (env, mk_coerce fun) -- contination to discard, else we do it
+ = return (env, mk_coerce res) -- contination to discard, else we do it
where -- again and again!
- fun_ty = exprType fun
- cont_ty = contResultType env fun_ty cont
- co = mkUnsafeCoercion fun_ty cont_ty
- mk_coerce expr | cont_ty `coreEqType` fun_ty = expr
+ 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
| otherwise = mkCoerce co expr
-rebuildCall env fun info (ApplyTo _ (Type arg_ty) se cont)
- = do { ty' <- simplType (se `setInScope` env) arg_ty
- ; rebuildCall env (fun `App` Type ty') info cont }
+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 fun
- (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs })
- (ApplyTo _ arg arg_se 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
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
- (StrictArg fun cci arg_info' cont)
+ (StrictArg info' cci cont)
-- Note [Shadowing]
| otherwise -- Lazy argument
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScope` env) arg
(mkLazyArgStop cci)
- ; rebuildCall env (fun `App` arg') arg_info' cont }
+ ; rebuildCall env (addArgTo info' arg') cont }
where
- arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs }
- cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here
- | otherwise = BoringCtxt -- Nothing interesting
-
-rebuildCall env fun _ cont
- = rebuild env fun cont
+ info' = info { ai_strs = strs, ai_discs = discs }
+ cci | encl_rules || disc > 0 = ArgCtxt encl_rules -- Be keener here
+ | otherwise = BoringCtxt -- Nothing interesting
+
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
+ = do { -- We've accumulated a simplified call in <fun,rev_args>
+ -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
+ -- See also Note [Rules for recursive functions]
+ ; let args = reverse rev_args
+ env' = zapSubstEnv env
+ ; 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 ;
+ -- n_args says how many args the rule consumed
+ ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules
+ } }
\end{code}
+Note [RULES apply to simplified arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 (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
+makes a particularly big difference when superclass selectors are involved:
+ op ($p1 ($p2 (df d)))
+We want all this to unravel in one sweeep.
+
Note [Shadowing]
~~~~~~~~~~~~~~~~
This part of the simplifier may break the no-shadowing invariant
%************************************************************************
\begin{code}
-tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont
+tryRules :: SimplEnv -> [CoreRule]
+ -> Id -> [OutExpr] -> SimplCont
-> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of
-- args consumed by the rule
-tryRules env fn args call_cont
- = do { dflags <- getDOptsSmpl
- ; rule_base <- getSimplRules
- ; let in_scope = getInScope env
- rules = getRules rule_base fn
- maybe_rule = case activeRule dflags env of
- Nothing -> Nothing -- No rules apply
- Just act_fn -> lookupRule act_fn in_scope
- fn args rules
- ; case (rules, maybe_rule) of {
- ([], _) -> return Nothing ;
- (_, Nothing) -> return Nothing ;
- (_, Just (rule, rule_rhs)) -> do
-
- { tick (RuleFired (ru_name rule))
- ; (if dopt Opt_D_dump_rule_firings dflags then
- pprTrace "Rule fired" (vcat [
+tryRules env rules fn args call_cont
+ | null rules
+ = return Nothing
+ | otherwise
+ = do { dflags <- getDOptsSmpl
+ ; case activeRule dflags env of {
+ Nothing -> return Nothing ; -- No rules apply
+ Just act_fn ->
+ case lookupRule act_fn (getInScope env) fn args rules of {
+ Nothing -> return Nothing ; -- No rule matches
+ Just (rule, rule_rhs) ->
+
+ do { tick (RuleFired (ru_name rule))
+ ; (if dopt Opt_D_dump_rule_firings dflags then
+ pprTrace "Rule fired" (vcat [
text "Rule:" <+> ftext (ru_name rule),
text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont])
- else
+ else
id) $
- return (Just (ruleArity rule, rule_rhs)) }}}
+ return (Just (ruleArity rule, rule_rhs)) }}}}
\end{code}
Note [Rules for recursive functions]
--------------------------------------------------
rebuildCase env scrut case_bndr alts cont
- | Just (con,args) <- exprIsConApp_maybe scrut
- -- Works when the scrutinee is a variable with a known unfolding
- -- as well as when it's an explicit constructor application
- = knownCon env scrut (DataAlt con) args case_bndr alts cont
-
| Lit lit <- scrut -- No need for same treatment as constructors
-- because literals are inlined more vigorously
- = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
+ = do { tick (KnownBranch case_bndr)
+ ; case findAlt (LitAlt lit) alts of
+ Nothing -> missingAlt env case_bndr alts cont
+ Just (_, bs, rhs) -> simple_rhs bs rhs }
+
+ | Just (con, ty_args, other_args) <- exprIsConApp_maybe 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)
+ ; case findAlt (DataAlt con) alts of
+ Nothing -> missingAlt env case_bndr alts cont
+ Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
+ Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args
+ case_bndr bs rhs cont
+ }
+ where
+ simple_rhs bs rhs = ASSERT( null bs )
+ do { env' <- simplNonRecX env case_bndr scrut
+ ; simplExprF env' rhs cont }
--------------------------------------------------
-- exprOkForSpeculation was intended for.
var_demanded_later _ = False
+--------------------------------------------------
+-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId
+--------------------------------------------------
+
rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
| all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
- = -- For this case, see Note [Rules for seq] in MkId
- do { let rhs' = substExpr env rhs
+ = do { let rhs' = substExpr env rhs
out_args = [Type (substTy env (idType case_bndr)),
Type (exprType rhs'), scrut, rhs']
-- Lazily evaluated, so we don't do most of this
- ; mb_rule <- tryRules env seqId out_args cont
+
+ ; rule_base <- getSimplRules
+ ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont
; case mb_rule of
Just (n_args, res) -> simplExprF (zapSubstEnv env)
(mkApps res (drop n_args out_args))
-- Check for empty alternatives
; if null alts' then missingAlt env case_bndr alts cont
else do
- { case_expr <- mkCase scrut' case_bndr' alts'
+ { dflags <- getDOptsSmpl
+ ; case_expr <- mkCase dflags scrut' case_bndr' alts'
- -- Notice that rebuild gets the in-scope set from env, not alt_env
+ -- Notice that rebuild gets the in-scope set from env', not alt_env
+ -- (which in any case is only build in simplAlts)
-- The case binder *not* scope over the whole returned case-expression
; rebuild env' case_expr nodup_cont } }
\end{code}
after the outer case, and that makes (a,b) alive. At least we do unless
the case binder is guaranteed dead.
+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
I# x# -> let x = x' `cast` sym co
in rhs
-so that 'rhs' can take advantage of the form of x'. Notice that Note
-[Case of cast] may then apply to the result.
-
-This showed up in Roman's experiments. Example:
+so that 'rhs' can take advantage of the form of x'.
+
+Notice that Note [Case of cast] 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
+is *not* a *pure* seq.
+ a) There is no point in adding the cast to a pure seq.
+ b) There is a good reason not to: doing so would interfere
+ with seq rules (Note [Built-in RULES for seq] in MkId).
+ In particular, this [Improving seq] thing *adds* a cast
+ while [Built-in RULES for seq] *removes* one, so they
+ just flip-flop.
+
+You might worry about
+ case v of x { __DEFAULT ->
+ ... case (v `cast` co) of y { I# -> ... }}
+This is a pure seq (since x is unused), so [Improving seq] won't happen.
+But it's ok: the simplifier will replace 'v' by 'x' in the rhs to get
+ case v of x { __DEFAULT ->
+ ... case (x `cast` co) of y { I# -> ... }}
+Now the outer case is not a pure seq, so [Improving seq] will happen,
+and then the inner case will disappear.
+
+The need for [Improving seq] showed up in Roman's experiments. Example:
foo :: F Int -> Int -> Int
foo t n = t `seq` bar n
where
Here we'd like to avoid repeated evaluating t inside the loop, by
taking advantage of the `seq`.
-At one point I did transformation in LiberateCase, but it's more robust here.
-(Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before
-LiberateCase gets to see it.)
-
-
-
-
-\begin{code}
-improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
- -> OutExpr -> InId -> OutId -> [InAlt]
- -> SimplM (SimplEnv, OutExpr, OutId)
--- Note [Improving seq]
-improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
- | 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)
- env2 = extendIdSubst env case_bndr rhs
- ; return (env2, scrut `Cast` co, case_bndr2) }
-
-improveSeq _ env scrut _ case_bndr1 _
- = return (env, scrut, case_bndr1)
-
-{-
- improve_case_bndr env scrut case_bndr
- -- See Note [no-case-of-case]
- -- | switchIsOn (getSwitchChecker env) NoCaseOfCase
- -- = (env, case_bndr)
-
- | otherwise -- Failed try; see Note [Suppressing the case binder-swap]
- -- not (isEvaldUnfolding (idUnfolding v))
- = case scrut of
- Var v -> (modifyInScope env1 v case_bndr', case_bndr')
- -- Note about using modifyInScope for v here
- -- We could extend the substitution instead, but it would be
- -- a hack because then the substitution wouldn't be idempotent
- -- any more (v is an OutId). And this does just as well.
-
- Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
- where
- rhs = Cast (Var case_bndr') (mkSymCoercion co)
-
- _ -> (env, case_bndr)
- where
- case_bndr' = zapIdOccInfo case_bndr
- env1 = modifyInScope env case_bndr case_bndr'
--}
-\end{code}
-
-
-simplAlts does two things:
-
-1. Eliminate alternatives that cannot match, including the
- DEFAULT alternative.
-
-2. If the DEFAULT alternative can match only one possible constructor,
- then make that constructor explicit.
- e.g.
- case e of x { DEFAULT -> rhs }
- ===>
- case e of x { (a,b) -> rhs }
- where the type is a single constructor type. This gives better code
- when rhs also scrutinises x or e.
-
-Here "cannot match" includes knowledge from GADTs
-
-It's a good idea do do this stuff before simplifying the alternatives, to
-avoid simplifying alternatives we know can't happen, and to come up with
-the list of constructors that are handled, to put into the IdInfo of the
-case binder, for use when simplifying the alternatives.
-
-Eliminating the default alternative in (1) isn't so obvious, but it can
-happen:
-
-data Colour = Red | Green | Blue
-
-f x = case x of
- Red -> ..
- Green -> ..
- DEFAULT -> h x
-
-h y = case y of
- Blue -> ..
- DEFAULT -> [ case y of ... ]
-
-If we inline h into f, the default case of the inlined h can't happen.
-If we don't notice this, we may end up filtering out *all* the cases
-of the inner case y, which give us nowhere to go!
-
+At one point I did transformation in LiberateCase, but it's more
+robust here. (Otherwise, there's a danger that we'll simply drop the
+'seq' altogether, before LiberateCase gets to see it.)
\begin{code}
simplAlts :: SimplEnv
-> SimplCont
-> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
-- Like simplExpr, this just returns the simplified alternatives;
--- it not return an environment
+-- it does not return an environment
simplAlts env scrut case_bndr alts cont'
= -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut
case_bndr case_bndr1 alts
- ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts
+ ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
; return (scrut', case_bndr', alts') }
+
+------------------------------------
+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
+ -> OutExpr -> InId -> OutId -> [InAlt]
+ -> 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!
+ , 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)
+ env2 = extendIdSubst env case_bndr rhs
+ ; return (env2, scrut `Cast` co, case_bndr2) }
+
+improveSeq _ env scrut _ case_bndr1 _
+ = return (env, scrut, case_bndr1)
+
+
------------------------------------
simplAlt :: SimplEnv
-> [AltCon] -- These constructors can't be present when
All this should happen in one sweep.
\begin{code}
-knownCon :: SimplEnv -> OutExpr -> AltCon
- -> [OutExpr] -- Args *including* the universal args
- -> InId -> [InAlt] -> SimplCont
- -> SimplM (SimplEnv, OutExpr)
-
-knownCon env scrut con args bndr alts cont
- = do { tick (KnownBranch bndr)
- ; case findAlt con alts of
- Nothing -> missingAlt env bndr alts cont
- Just alt -> knownAlt env scrut args bndr alt cont
- }
-
--------------------
-knownAlt :: SimplEnv -> OutExpr -> [OutExpr]
- -> InId -> InAlt -> SimplCont
+knownCon :: SimplEnv
+ -> OutExpr -- The scrutinee
+ -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)
+ -> InId -> [InBndr] -> InExpr -- The alternative
+ -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont
- = do { let n_drop_tys = length (dataConUnivTyVars dc)
- ; env' <- bind_args env bs (drop n_drop_tys the_args)
+knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
+ = do { env' <- bind_args env bs dc_args
; let
-- It's useful to bind bndr to scrut, rather than to a fresh
-- binding x = Con arg1 .. argn
-- BUT, if scrut is a not a variable, we must be careful
-- about duplicating the arg redexes; in that case, make
-- a new con-app from the args
- bndr_rhs = case scrut of
- Var _ -> scrut
- _ -> con_app
- con_app = mkConApp dc (take n_drop_tys the_args ++ con_args)
- con_args = [substExpr env' (varToCoreExpr b) | b <- bs]
- -- args are aready OutExprs, but bs are InIds
+ bndr_rhs | exprIsTrivial scrut = scrut
+ | otherwise = con_app
+ con_app = Var (dataConWorkId dc)
+ `mkTyApps` dc_ty_args
+ `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs]
+ -- dc_ty_args are aready OutTypes, but bs are InBndrs
; env'' <- simplNonRecX env' bndr bndr_rhs
; simplExprF env'' rhs cont }
; bind_args env'' bs' args }
bind_args _ _ _ =
- pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$
+ pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
text "scrut:" <+> ppr scrut
-knownAlt env scrut _ bndr (_, bs, rhs) cont
- = ASSERT( null bs ) -- Works for LitAlt and DEFAULT
- do { env' <- simplNonRecX env bndr scrut
- ; simplExprF env' rhs cont }
-
-
-------------------
missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- This isn't strictly an error, although it is unusual.
= return (env, mkBoringStop, cont)
-- See Note [Duplicating StrictBind]
-mkDupableCont env (StrictArg fun cci ai cont)
+mkDupableCont env (StrictArg info cci cont)
-- See Note [Duplicating StrictArg]
= do { (env', dup, nodup) <- mkDupableCont env cont
- ; (env'', fun') <- mk_dupable_call env' fun
- ; return (env'', StrictArg fun' cci ai dup, nodup) }
- where
- mk_dupable_call env (Var v) = return (env, Var v)
- mk_dupable_call env (App fun arg) = do { (env', fun') <- mk_dupable_call env fun
- ; (env'', arg') <- makeTrivial env' arg
- ; return (env'', fun' `App` arg') }
- mk_dupable_call _ other = pprPanic "mk_dupable_call" (ppr other)
- -- The invariant of StrictArg is that the first arg is always an App chain
+ ; (env'', args') <- mapAccumLM makeTrivial env' (ai_args info)
+ ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
mkDupableCont env (ApplyTo _ arg se cont)
= -- e.g. [...hole...] (...arg...)
mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr)
-> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr))
-mkDupableAlt env case_bndr' (con, bndrs', rhs')
+mkDupableAlt env case_bndr (con, bndrs', rhs')
| exprIsDupable rhs' -- Note [Small alternative rhs]
= return (env, (con, bndrs', rhs'))
| otherwise
- = do { let rhs_ty' = exprType rhs'
- used_bndrs' = filter abstract_over (case_bndr' : bndrs')
+ = do { let rhs_ty' = exprType rhs'
+ scrut_ty = idType case_bndr
+ case_bndr_w_unf
+ = case con of
+ DEFAULT -> case_bndr
+ DataAlt dc -> setIdUnfolding case_bndr unf
+ where
+ -- See Note [Case binders and join points]
+ unf = mkInlineRule InlSat rhs 0
+ rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
+ ++ varsToCoreExprs bndrs')
+
+ LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
+ <+> ppr case_bndr <+> ppr con )
+ case_bndr
+ -- The case binder is alive but trivial, so why has
+ -- it not been substituted away?
+
+ used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs'
+ | otherwise = bndrs' ++ [case_bndr_w_unf]
+
abstract_over bndr
| isTyVar bndr = True -- Abstract over all type variables just in case
| otherwise = not (isDeadBinder bndr)
join_rhs = mkLams really_final_bndrs rhs'
join_call = mkApps (Var join_bndr) final_args
- ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) }
+ ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs)
+ ; return (env', (con, bndrs', join_call)) }
-- See Note [Duplicated env]
\end{code}
+Note [Case binders and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+ case (case .. ) of c {
+ I# c# -> ....c....
+
+If we make a join point with c but not c# we get
+ $j = \c -> ....c....
+
+But if later inlining scrutines the c, thus
+
+ $j = \c -> ... case c of { I# y -> ... } ...
+
+we won't see that 'c' has already been scrutinised. This actually
+happens in the 'tabulate' function in wave4main, and makes a significant
+difference to allocation.
+
+An alternative plan is this:
+
+ $j = \c# -> let c = I# c# in ...c....
+
+but that is bad if 'c' is *not* later scrutinised.
+
+So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
+that it's really I# c#, thus
+
+ $j = \c# -> \c[=I# c#] -> ...c....
+
+Absence analysis may later discard 'c'.
+
+
Note [Duplicated env]
~~~~~~~~~~~~~~~~~~~~~
Some of the alternatives are simplified, but have not been turned into a join point