import Var
import IdInfo
import Coercion
+import FamInstEnv ( topNormaliseType )
import DataCon ( dataConRepStrictness, dataConUnivTyVars )
import CoreSyn
import NewDemand ( isStrictDmd )
else -- Do type-abstraction first
do { tick LetFloatFromLet
- ; (poly_binds, body3) <- abstractFloats tvs body_env2 body2
+ ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
; rhs' <- mkLam tvs' body3
; return (extendFloats env poly_binds, rhs') }
(StrictBind bndr bndrs body env cont) }
| otherwise
- = do { (env, bndr') <- simplBinder env bndr
+ = do { (env, bndr') <- simplNonRecBndr env bndr
; env <- simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se
; simplLam env bndrs body cont }
\end{code}
-- See notes with SimplMonad.inlineMode
simplNote env InlineMe e cont
- | contIsRhsOrArg cont -- Totally boring continuation; see notes above
+ | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above
= do { -- Don't inline inside an INLINE expression
- e' <- simplExpr (setMode inlineMode env) e
- ; rebuild env (mkInlineMe e') cont }
+ 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
-- the wrapper didn't occur for things that have specialisations till a
-- later phase, so but now we just try RULES first
--
+ -- Note [Self-recursive rules]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- You might think that we shouldn't apply rules for a loop breaker:
-- doing so might give rise to an infinite loop, because a RULE is
-- rather like an extra equation for the function:
-- is recursive, and hence a loop breaker:
-- foldr k z (build g) = g k z
-- So it's up to the programmer: rules can cause divergence
+ ; rules <- getRules
; let in_scope = getInScope env
- rules = getRules env
maybe_rule = case activeRule dflags env of
Nothing -> Nothing -- No rules apply
Just act_fn -> lookupRule act_fn in_scope
-- Then, especially in the first of these cases, we'd like to discard
-- 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 thia if there is a non-trivial
+ | not (contIsTrivial cont) -- Only do this if there is a non-trivial
= return (env, mk_coerce fun) -- contination to discard, else we do it
where -- again and again!
cont_ty = contResultType cont
(env, dup_cont, nodup_cont) <- prepareCaseCont env alts cont
-- Simplify the alternatives
- ; (case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
+ ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts dup_cont
; let res_ty' = contResultType dup_cont
- ; case_expr <- mkCase scrut case_bndr' res_ty' alts'
+ ; case_expr <- mkCase scrut' case_bndr' res_ty' alts'
-- Notice that rebuildDone returns the in-scope set from env, not alt_env
-- The case binder *not* scope over the whole returned case-expression
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
+ type family F :: * -> *
+ type instance F Int = Int
+
+ ... case e of x { DEFAULT -> rhs } ...
+
+where x::F Int. Then we'd like to rewrite (F Int) to Int, getting
+
+ case e `cast` co of x'::Int
+ I# x# -> let x = x' `cast` sym co
+ in rhs
+
+so that 'rhs' can take advantage of hte form of x'. Notice that Note
+[Case of cast] may then apply to the result.
+
+This showed up in Roman's experiments. Example:
+ foo :: F Int -> Int -> Int
+ foo t n = t `seq` bar n
+ where
+ bar 0 = 0
+ bar n = bar (n - case t of TI i -> i)
+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.)
Note [Case elimination]
~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId)
-simplCaseBinder env scrut case_bndr
- | switchIsOn (getSwitchChecker env) NoCaseOfCase
- -- See Note [no-case-of-case]
- = do { (env, case_bndr') <- simplBinder env case_bndr
- ; return (env, case_bndr') }
-
-simplCaseBinder env (Var v) case_bndr
--- Failed try [see Note 2 above]
--- not (isEvaldUnfolding (idUnfolding v))
- = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
- ; return (modifyInScope env v case_bndr', case_bndr') }
- -- 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.
-
-simplCaseBinder env (Cast (Var v) co) case_bndr -- Note [Case of cast]
- = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
- ; let rhs = Cast (Var case_bndr') (mkSymCoercion co)
- ; return (addBinderUnfolding env v rhs, case_bndr') }
-
-simplCaseBinder env other_scrut case_bndr
- = do { (env, case_bndr') <- simplBinder env case_bndr
- ; return (env, case_bndr') }
+simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
+ -> SimplM (SimplEnv, OutExpr, OutId)
+simplCaseBinder env scrut case_bndr alts
+ = do { (env1, case_bndr1) <- simplBinder env case_bndr
+
+ ; fam_envs <- getFamEnvs
+ ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
+ case_bndr case_bndr1 alts
+ -- Note [Improving seq]
+
+ ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
+ -- Note [Case of cast]
+
+ ; return (env3, scrut2, case_bndr3) }
+ where
+
+ improve_seq fam_envs env1 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 env1 case_bndr rhs
+ ; return (env2, scrut `Cast` co, case_bndr2) }
+
+ improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
+ = return (env1, scrut, case_bndr1)
+
+
+ improve_case_bndr env scrut case_bndr
+ | switchIsOn (getSwitchChecker env) NoCaseOfCase
+ -- See Note [no-case-of-case]
+ = (env, case_bndr)
+
+ | otherwise -- Failed try [see Note 2 above]
+ -- 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)
+
+ other -> (env, case_bndr)
+ where
+ case_bndr' = zapOccInfo case_bndr
+ env1 = modifyInScope env case_bndr case_bndr'
+
zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
zapOccInfo b = b `setIdOccInfo` NoOccInfo
-> OutExpr
-> InId -- Case binder
-> [InAlt] -> SimplCont
- -> SimplM (OutId, [OutAlt]) -- Includes the continuation
+ -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
-- Like simplExpr, this just returns the simplified alternatives;
-- it not return an environment
simplAlts env scrut case_bndr alts cont'
= -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
do { let alt_env = zapFloats env
- ; (alt_env, case_bndr') <- simplCaseBinder alt_env scrut case_bndr
+ ; (alt_env, scrut', case_bndr') <- simplCaseBinder 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 (case_bndr', alts') }
+ ; return (scrut', case_bndr', alts') }
------------------------------------
simplAlt :: SimplEnv
projects / ghc-hetmet.git / blobdiff