; 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
-- 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
projects / ghc-hetmet.git / blobdiff