import Var
import IdInfo
import Coercion
-import DataCon ( dataConTyCon, dataConRepStrictness, dataConUnivTyVars )
-import TyCon ( tyConArity )
+import FamInstEnv ( topNormaliseType )
+import DataCon ( dataConRepStrictness, dataConUnivTyVars )
import CoreSyn
import NewDemand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
-> SimplM SimplEnv
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
- = do { let rhs_env = rhs_se `setInScope` env
- rhs_cont = mkRhsStop (idType bndr1)
+ = do { let rhs_env = rhs_se `setInScope` env
+ (tvs, body) = collectTyBinders rhs
+ ; (body_env, tvs') <- simplBinders rhs_env tvs
+ -- See Note [Floating and type abstraction]
+ -- in SimplUtils
-- Simplify the RHS; note the mkRhsStop, which tells
-- the simplifier that this is the RHS of a let.
- ; (rhs_env1, rhs1) <- simplExprF rhs_env rhs rhs_cont
-
- -- If any of the floats can't be floated, give up now
- -- (The canFloat predicate says True for empty floats.)
- ; if (not (canFloat top_lvl is_rec False rhs_env1))
- then completeBind env top_lvl bndr bndr1
- (wrapFloats rhs_env1 rhs1)
- else do
+ ; let rhs_cont = mkRhsStop (applyTys (idType bndr1) (mkTyVarTys tvs'))
+ ; (body_env1, body1) <- simplExprF body_env body rhs_cont
+
-- ANF-ise a constructor or PAP rhs
- { (rhs_env2, rhs2) <- prepareRhs rhs_env1 rhs1
- ; (env', rhs3) <- chooseRhsFloats top_lvl is_rec False env rhs_env2 rhs2
- ; completeBind env' top_lvl bndr bndr1 rhs3 } }
-
-chooseRhsFloats :: TopLevelFlag -> RecFlag -> Bool
- -> SimplEnv -- Env for the let
- -> SimplEnv -- Env for the RHS, with RHS floats in it
- -> OutExpr -- ..and the RHS itself
- -> SimplM (SimplEnv, OutExpr) -- New env for let, and RHS
-
-chooseRhsFloats top_lvl is_rec is_strict env rhs_env rhs
- | not (isEmptyFloats rhs_env) -- Something to float
- , canFloat top_lvl is_rec is_strict rhs_env -- ...that can float
- , (isTopLevel top_lvl || exprIsCheap rhs) -- ...and we want to float
- = do { tick LetFloatFromLet -- Float
- ; return (addFloats env rhs_env, rhs) } -- Add the floats to the main env
- | otherwise -- Don't float
- = return (env, wrapFloats rhs_env rhs) -- Wrap the floats around the RHS
-\end{code}
+ ; (body_env2, body2) <- prepareRhs body_env1 body1
+ ; (env', rhs')
+ <- if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
+ then -- No floating, just wrap up!
+ do { rhs' <- mkLam tvs' (wrapFloats body_env2 body2)
+ ; return (env, rhs') }
-%************************************************************************
-%* *
-\subsection{simplNonRec}
-%* *
-%************************************************************************
+ else if null tvs then -- Simple floating
+ do { tick LetFloatFromLet
+ ; return (addFloats env body_env2, body2) }
+
+ else -- Do type-abstraction first
+ do { tick LetFloatFromLet
+ ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
+ ; rhs' <- mkLam tvs' body3
+ ; return (extendFloats env poly_binds, rhs') }
+
+ ; completeBind env' top_lvl bndr bndr1 rhs' }
+\end{code}
A specialised variant of simplNonRec used when the RHS is already simplified,
notably in knownCon. It uses case-binding where necessary.
completeNonRecX env top_lvl is_rec is_strict old_bndr new_bndr new_rhs
= do { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
- ; (env2, rhs2) <- chooseRhsFloats top_lvl is_rec is_strict env env1 rhs1
+ ; (env2, rhs2) <-
+ if doFloatFromRhs top_lvl is_rec is_strict rhs1 env1
+ then do { tick LetFloatFromLet
+ ; return (addFloats env env1, rhs1) } -- Add the floats to the main env
+ else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
\end{code}
= return (False, env, other)
\end{code}
+
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
(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}
-- 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 env of
+ maybe_rule = case activeRule dflags env of
Nothing -> Nothing -- No rules apply
Just act_fn -> lookupRule act_fn in_scope
rules var args
-- 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
-- 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)
+ && not (isTickBoxOp v)
+ -- ugly hack; covering this case is what
+ -- exprOkForSpeculation was intended for.
var_demanded_later other = False
(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