import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
import CoreSyn
-import NewDemand ( isStrictDmd, splitStrictSig )
+import Demand ( isStrictDmd, splitStrictSig )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule,
exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
import CostCentre ( currentCCS, pushCCisNop )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
-import BasicTypes ( TopLevelFlag(..), isTopLevel,
- RecFlag(..), isNonRuleLoopBreaker )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM )
import Maybes ( orElse )
import Data.List ( mapAccumL )
= do { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs
; return (env', Cast rhs' co) }
where
- sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info
- `setNewDemandInfo` newDemandInfo info
+ sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
+ `setDemandInfo` demandInfo info
info = idInfo id
prepareRhs env0 _ rhs0
; 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)) }
+ ; 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
| otherwise = info2
final_id = new_bndr `setIdInfo` info3
- dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+ dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
in
ASSERT( isId new_bndr )
WARN( new_arity < old_arity || new_arity < dmd_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
+simplUnfolding _ top_lvl _ _occ_info new_rhs _
+ = return (mkUnfolding (isTopLevel top_lvl) 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 [Arity decrease]
where
-- The case binder is going to be evaluated later,
-- and the scrutinee is a simple variable
- var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
+ var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
&& not (isTickBoxOp v)
-- ugly hack; covering this case is what
-- 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 [User-defined 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
-- 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}
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,_,_)]
- | 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)
-\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!
-
-
\begin{code}
simplAlts :: SimplEnv
-> OutExpr
-> 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