)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
-import Var ( tyVarKind, mkTyVar )
import Name ( mkSysTvName )
import Type ( Type, splitFunTys, dropForAlls, isStrictType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys )
import Coercion ( isEqPredTy
)
import Coercion ( Coercion, mkUnsafeCoercion, coercionKind )
-import TyCon ( tyConDataCons_maybe, isNewTyCon )
-import DataCon ( DataCon, dataConRepArity, dataConExTyVars,
- dataConInstArgTys, dataConTyCon )
+import TyCon ( tyConDataCons_maybe, isClosedNewTyCon )
+import DataCon ( DataCon, dataConRepArity, dataConInstArgTys, dataConTyCon )
import VarSet
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive )
-> Bool
postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
| not active = False
- | isLoopBreaker occ_info = False
+ | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, dont' inline
+ -- because it might be referred to "earlier"
| isExportedId bndr = False
| exprIsTrivial rhs = True
| otherwise
SimplPhase n -> isActive n prag
prag = idInlinePragma bndr
-activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
-activeInline env id occ
+activeInline :: SimplEnv -> OutId -> Bool
+activeInline env id
= case getMode env of
- SimplGently -> isOneOcc occ && isAlwaysActive prag
+ SimplGently -> False
-- No inlining at all when doing gentle stuff,
-- except for local things that occur once
-- The reason is that too little clean-up happens if you
mkCase1 scrut case_bndr ty alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
- returnSmpl (re_note scrut)
+ returnSmpl (re_cast scrut)
where
- identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
+ identity_alt (con, args, rhs) = de_cast rhs `cheapEqExpr` mk_id_rhs con args
- identity_rhs (DataAlt con) args
- | isNewTyCon (dataConTyCon con)
- = wrapNewTypeBody (dataConTyCon con) arg_tys (varToCoreExpr $ head args)
- | otherwise
- = mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)
- identity_rhs (LitAlt lit) _ = Lit lit
- identity_rhs DEFAULT _ = Var case_bndr
+ mk_id_rhs (DataAlt con) args = mkConApp con (arg_tys ++ varsToCoreExprs args)
+ mk_id_rhs (LitAlt lit) _ = Lit lit
+ mk_id_rhs DEFAULT _ = Var case_bndr
- arg_tys = (tyConAppArgs (idType case_bndr))
- arg_ty_exprs = map Type arg_tys
+ arg_tys = map Type (tyConAppArgs (idType case_bndr))
-- We've seen this:
- -- case coerce T e of x { _ -> coerce T' x }
- -- And we definitely want to eliminate this case!
- -- So we throw away notes from the RHS, and reconstruct
- -- (at least an approximation) at the other end
- de_note (Note _ e) = de_note e
- de_note e = e
-
- -- re_note wraps a coerce if it might be necessary
- re_note scrut = case head alts of
- (_,_,rhs1@(Note _ _)) ->
- let co = mkUnsafeCoercion (idType case_bndr) (exprType rhs1) in
- -- this unsafeCoercion is bad, make this better
- mkCoerce co scrut
- other -> scrut
+ -- case e of x { _ -> x `cast` c }
+ -- And we definitely want to eliminate this case, to give
+ -- e `cast` c
+ -- So we throw away the cast from the RHS, and reconstruct
+ -- it at the other end. All the RHS casts must be the same
+ -- if (all identity_alt alts) holds.
+ --
+ -- Don't worry about nested casts, because the simplifier combines them
+ de_cast (Cast e _) = e
+ de_cast e = e
+
+ re_cast scrut = case head alts of
+ (_,_,Cast _ co) -> Cast scrut co
+ other -> scrut