idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda
)
-import MkId ( eRROR_ID )
-import Literal ( mkStringLit )
-import IdInfo ( OccInfo(..), isLoopBreaker,
- setArityInfo, zapDemandInfo,
- setUnfoldingInfo,
- occInfo
+import IdInfo ( OccInfo(..), setArityInfo, zapDemandInfo,
+ setUnfoldingInfo, occInfo
)
import NewDemand ( isStrictDmd )
import TcGadt ( dataConCanMatch )
-import DataCon ( DataCon, dataConTyCon, dataConRepStrictness )
+import DataCon ( dataConTyCon, dataConRepStrictness )
import TyCon ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity,
mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
- dataConInstPat
+ dataConRepInstPat
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
- splitFunTy_maybe, splitFunTy, coreEqType, splitTyConApp_maybe,
- isTyVarTy, mkTyVarTys, isFunTy, tcEqType
+ coreEqType, splitTyConApp_maybe,
+ isTyVarTy, isFunTy, tcEqType
)
import Coercion ( Coercion, coercionKind,
- mkTransCoercion, mkLeftCoercion, mkRightCoercion,
- mkSymCoercion, splitCoercionKind_maybe, decomposeCo )
-import Var ( tyVarKind, mkTyVar )
+ mkTransCoercion, mkSymCoercion, splitCoercionKind_maybe, decomposeCo )
import VarEnv ( elemVarEnv, emptyVarEnv )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
- RecFlag(..), isNonRec
+ RecFlag(..), isNonRec, isNonRuleLoopBreaker
)
import OrdList
import List ( nub )
| otherwise
= let
- -- Add arity info
+ -- Arity info
new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+ -- 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
final_id `seq`
-- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
returnSmpl (unitFloat env final_id new_rhs, env)
-
where
unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
- loop_breaker = isLoopBreaker occ_info
+ loop_breaker = isNonRuleLoopBreaker occ_info
old_info = idInfo old_bndr
occ_info = occInfo old_info
\end{code}
way, there's a chance that v will now only be used once, and hence
inlined.
-Note 1
-~~~~~~
+Note [no-case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~
There is a time we *don't* want to do that, namely when
-fno-case-of-case is on. This happens in the first simplifier pass,
and enhances full laziness. Here's the bad case:
[(m,n) | m <- [1..max], n <- [1..max]]
Hence the check for NoCaseOfCase.
+Note [Case of cast]
+~~~~~~~~~~~~~~~~~~~
+Consider case (v `cast` co) of x { I# ->
+ ... (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 2
~~~~~~
There is another situation when we don't want to do it. If we have
x1) has unfolding MkT y1. THe straightforward thing to do is to do
the binder-swap. So this whole note is a no-op.
-Note 3
-~~~~~~
+Note [zapOccInfo]
+~~~~~~~~~~~~~~~~~
If we replace the scrutinee, v, by tbe case binder, then we have to nuke
any occurrence info (eg IAmDead) in the case binder, because the
case-binder now effectively occurs whenever v does. AND we have to do
the case binder is guaranteed dead.
\begin{code}
-simplCaseBinder env (Var v) case_bndr
- | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+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))
-
- = simplBinder env (zapOccInfo case_bndr) `thenSmpl` \ (env, case_bndr') ->
- returnSmpl (modifyInScope env v case_bndr', case_bndr')
+ = 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
- = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
- returnSmpl (env, case_bndr')
+ = do { (env, case_bndr') <- simplBinder env case_bndr
+ ; return (env, case_bndr') }
-zapOccInfo :: InId -> InId
+zapOccInfo :: InId -> InId -- See Note [zapOccInfo]
zapOccInfo b = b `setIdOccInfo` NoOccInfo
\end{code}
[con] -> -- It matches exactly one constructor, so fill it in
do { tick (FillInCaseDefault case_bndr')
- ; con_alt <- mkDataConAlt con inst_tys rhs
+ ; us <- getUniquesSmpl
+ ; let (ex_tvs, co_tvs, arg_ids) =
+ dataConRepInstPat us con inst_tys
+ ; let con_alt = (DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)
; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
-- The simplAlt must succeed with Just because we have
-- already filtered out construtors that can't match
cant_match tys data_con = not (dataConCanMatch data_con tys)
simplify_default imposs_cons
- = do { let env' = mk_rhs_env env case_bndr' (mkOtherCon imposs_cons)
+ = do { let env' = addBinderOtherCon env case_bndr' imposs_cons
-- Record the constructors that the case-binder *can't* be.
; rhs' <- simplExprC env' rhs cont
; return [(DEFAULT, [], rhs')] }
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs')))
where
- env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons)
+ env' = addBinderOtherCon env case_bndr' handled_cons
-- Record the constructors that the case-binder *can't* be.
simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs')))
where
- env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit))
+ env' = addBinderUnfolding env case_bndr' (Lit lit)
simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
= -- Deal with the pattern-bound variables
simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
-- Bind the case-binder to (con args)
- let unf = mkUnfolding False (mkConApp con con_args)
- inst_tys' = tyConAppArgs (idType case_bndr')
+ let inst_tys' = tyConAppArgs (idType case_bndr')
con_args = map Type inst_tys' ++ varsToCoreExprs vs'
- env' = mk_rhs_env env case_bndr' unf
+ env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
in
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
zap_occ_info | isDeadBinder case_bndr' = \id -> id
| otherwise = zapOccInfo
-mk_rhs_env env case_bndr' case_bndr_unf
- = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf)
+addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
+addBinderUnfolding env bndr rhs
+ = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
+
+addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
+addBinderOtherCon env bndr cons
+ = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
\end{code}
-- Note that the binder might be "dead", because it doesn't occur
-- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
-- Nevertheless we must keep it if the case-binder is alive, because it may
- -- be used in teh con_app
+ -- be used in the con_app. See Note [zapOccInfo]
in
simplNonRecX env b' arg $ \ env ->
bind_args env dead_bndr bs args thing_inside