\begin{code}
module SimplUtils (
- mkLam, prepareAlts, mkCase,
+ mkLam, mkCase,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
contIsDupable, contResultType,
countValArgs, countArgs, pushContArgs,
- mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
- getContArgs, interestingCallContext, interestingArg, isStrictType
+ mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
+ getContArgs, interestingCallContext, interestingArgContext,
+ interestingArg, isStrictType
) where
import SimplEnv
import DynFlags ( SimplifierSwitch(..), SimplifierMode(..),
- DynFlag(..), dopt )
+ DynFlags, DynFlag(..), dopt )
import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
opt_RulesOff )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
- etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
- findDefault, exprOkForSpeculation, exprIsHNF
+import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
+ etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+ findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts,
+ applyTypeToArgs
)
import Literal ( mkStringLit )
import CoreUnfold ( smallEnoughToInline )
-import MkId ( eRROR_ID )
-import Id ( idType, isDataConWorkId, idOccInfo, isDictId,
- mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
- idUnfolding, idNewStrictness, idInlinePragma,
+import MkId ( eRROR_ID, wrapNewTypeBody )
+import Id ( Id, idType, isDataConWorkId, idOccInfo, isDictId,
+ isDeadBinder, idNewDemandInfo, isExportedId, mkSysLocal,
+ idUnfolding, idNewStrictness, idInlinePragma, idHasRules
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
+import Var ( tyVarKind, mkTyVar )
+import Name ( mkSysTvName )
import Type ( Type, splitFunTys, dropForAlls, isStrictType,
- splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
+ splitTyConApp_maybe, tyConAppArgs, mkTyVarTys )
+import Coercion ( isEqPredTy
)
-import Name ( mkSysTvName )
-import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon ( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
-import Var ( tyVarKind, mkTyVar )
+import Coercion ( Coercion, mkUnsafeCoercion, coercionKind )
+import TyCon ( tyConDataCons_maybe, isClosedNewTyCon )
+import DataCon ( DataCon, dataConRepArity, dataConInstArgTys, dataConTyCon )
import VarSet
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive )
\begin{code}
data SimplCont -- Strict contexts
- = Stop OutType -- Type of the result
+ = Stop OutType -- Type of the result
LetRhsFlag
- Bool -- True <=> This is the RHS of a thunk whose type suggests
- -- that update-in-place would be possible
- -- (This makes the inliner a little keener.)
-
- | CoerceIt OutType -- The To-type, simplified
+ Bool -- True <=> There is something interesting about
+ -- the context, and hence the inliner
+ -- should be a bit keener (see interestingCallContext)
+ -- Two cases:
+ -- (a) This is the RHS of a thunk whose type suggests
+ -- that update-in-place would be possible
+ -- (b) This is an argument of a function that has RULES
+ -- Inlining the call might allow the rule to fire
+
+ | CoerceIt OutCoercion -- The coercion simplified
SimplCont
- | InlinePlease -- This continuation makes a function very
- SimplCont -- keen to inline itelf
-
| ApplyTo DupFlag
- InExpr SimplEnv -- The argument, as yet unsimplified,
- SimplCont -- and its environment
+ CoreExpr -- The argument
+ (Maybe SimplEnv) -- (Just se) => the arg is un-simplified and this is its subst-env
+ -- Nothing => the arg is already simplified; don't repeatedly simplify it!
+ SimplCont -- and its environment
| Select DupFlag
InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
| ArgOf LetRhsFlag -- An arbitrary strict context: the argument
-- of a strict function, or a primitive-arg fn
-- or a PrimOp
- -- No DupFlag because we never duplicate it
+ -- No DupFlag, because we never duplicate it
OutType -- arg_ty: type of the argument itself
OutType -- cont_ty: the type of the expression being sought by the context
-- f (error "foo") ==> coerce t (error "foo")
ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
- ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
- ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
+ ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
data DupFlag = OkToDup | NoDup
ppr NoDup = ptext SLIT("nodup")
+
-------------------
-mkBoringStop, mkRhsStop :: OutType -> SimplCont
-mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
-mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty AnArg False
+
+mkLazyArgStop :: OutType -> Bool -> SimplCont
+mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules)
+
+mkRhsStop :: OutType -> SimplCont
+mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop _ AnRhs _) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
contIsDupable (CoerceIt _ cont) = contIsDupable cont
-contIsDupable (InlinePlease cont) = contIsDupable cont
contIsDupable other = False
-------------------
discardableCont :: SimplCont -> Bool
discardableCont (Stop _ _ _) = False
discardableCont (CoerceIt _ cont) = discardableCont cont
-discardableCont (InlinePlease cont) = discardableCont cont
discardableCont other = True
-discardCont :: SimplCont -- A continuation, expecting
+discardCont :: Type -- The type expected
+ -> SimplCont -- A continuation, expecting the previous type
-> SimplCont -- Replace the continuation with a suitable coerce
-discardCont cont = case cont of
+discardCont from_ty cont = case cont of
Stop to_ty is_rhs _ -> cont
- other -> CoerceIt to_ty (mkBoringStop to_ty)
+ other -> CoerceIt co (mkBoringStop to_ty)
where
- to_ty = contResultType cont
+ co = mkUnsafeCoercion from_ty to_ty
+ to_ty = contResultType cont
-------------------
contResultType :: SimplCont -> OutType
contResultType (ArgOf _ _ to_ty _) = to_ty
contResultType (ApplyTo _ _ _ cont) = contResultType cont
contResultType (CoerceIt _ cont) = contResultType cont
-contResultType (InlinePlease cont) = contResultType cont
contResultType (Select _ _ _ _ cont) = contResultType cont
-------------------
countArgs other = 0
-------------------
-pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
+pushContArgs ::[OutArg] -> SimplCont -> SimplCont
-- Pushes args with the specified environment
-pushContArgs env [] cont = cont
-pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
+pushContArgs [] cont = cont
+pushContArgs (arg : args) cont = ApplyTo NoDup arg Nothing (pushContArgs args cont)
\end{code}
\begin{code}
getContArgs :: SwitchChecker
-> OutId -> SimplCont
- -> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
- SimplCont, -- Remaining continuation
- Bool) -- Whether we came across an InlineCall
+ -> ([(InExpr, Maybe SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
+ SimplCont) -- Remaining continuation
-- getContArgs id k = (args, k', inl)
-- args are the leading ApplyTo items in k
-- (i.e. outermost comes first)
stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
| otherwise = computed_stricts
in
- go [] stricts False orig_cont
+ go [] stricts orig_cont
where
----------------------------
-- Type argument
- go acc ss inl (ApplyTo _ arg@(Type _) se cont)
- = go ((arg,se,False) : acc) ss inl cont
+ go acc ss (ApplyTo _ arg@(Type _) se cont)
+ = go ((arg,se,False) : acc) ss cont
-- NB: don't bother to instantiate the function type
-- Value argument
- go acc (s:ss) inl (ApplyTo _ arg se cont)
- = go ((arg,se,s) : acc) ss inl cont
-
- -- An Inline continuation
- go acc ss inl (InlinePlease cont)
- = go acc ss True cont
+ go acc (s:ss) (ApplyTo _ arg se cont)
+ = go ((arg,se,s) : acc) ss cont
-- We're run out of arguments, or else we've run out of demands
-- The latter only happens if the result is guaranteed bottom
-- 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.
- go acc ss inl cont
- | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
- | otherwise = (reverse acc, cont, inl)
+ go acc ss cont
+ | null ss && discardableCont cont = (args, discardCont hole_ty cont)
+ | otherwise = (args, cont)
+ where
+ args = reverse acc
+ hole_ty = applyTypeToArgs (Var fun) (idType fun)
+ [substExpr_mb se arg | (arg,se,_) <- args]
+ substExpr_mb Nothing arg = arg
+ substExpr_mb (Just se) arg = substExpr se arg
+
----------------------------
vanilla_stricts, computed_stricts :: [Bool]
vanilla_stricts = repeat False
computed_stricts = zipWith (||) fun_stricts arg_stricts
----------------------------
- (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
+ (val_arg_tys, res_ty) = splitFunTys (dropForAlls (idType fun))
arg_stricts = map isStrictType val_arg_tys ++ repeat False
-- These argument types are used as a cheap and cheerful way to find
-- unboxed arguments, which must be strict. But it's an InType
interestingCallContext some_args some_val_args cont
= interesting cont
where
- interesting (InlinePlease _) = True
- interesting (Select _ _ _ _ _) = some_args
- interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
+ interesting (Select {}) = some_args
+ interesting (ApplyTo {}) = True -- Can happen if we have (coerce t (f x)) y
-- Perhaps True is a bit over-keen, but I've
-- seen (coerce f) x, where f has an INLINE prag,
-- So we have to give some motivaiton for inlining it
- interesting (ArgOf _ _ _ _) = some_val_args
- interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
+ interesting (ArgOf {}) = some_val_args
+ interesting (Stop ty _ interesting) = some_val_args && interesting
interesting (CoerceIt _ cont) = interesting cont
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
-------------------
+interestingArgContext :: Id -> SimplCont -> Bool
+-- If the argument has form (f x y), where x,y are boring,
+-- and f is marked INLINE, then we don't want to inline f.
+-- But if the context of the argument is
+-- g (f x y)
+-- where g has rules, then we *do* want to inline f, in case it
+-- exposes a rule that might fire. Similarly, if the context is
+-- h (g (f x x))
+-- where h has rules, then we do want to inline f.
+-- The interesting_arg_ctxt flag makes this happen; if it's
+-- set, the inliner gets just enough keener to inline f
+-- regardless of how boring f's arguments are, if it's marked INLINE
+--
+-- The alternative would be to *always* inline an INLINE function,
+-- regardless of how boring its context is; but that seems overkill
+-- For example, it'd mean that wrapper functions were always inlined
+interestingArgContext fn cont
+ = idHasRules fn || go cont
+ where
+ go (Select {}) = False
+ go (ApplyTo {}) = False
+ go (ArgOf {}) = True
+ go (CoerceIt _ c) = go c
+ go (Stop _ _ interesting) = interesting
+
+-------------------
canUpdateInPlace :: Type -> Bool
-- Consider let x = <wurble> in ...
-- If <wurble> returns an explicit constructor, we might be able
==> ...(case x of I# x# -> case fw x# of ...)...
and now the redex (f x) isn't floatable any more.
-The no-inling thing is also important for Template Haskell. You might be
+The no-inlining thing is also important for Template Haskell. You might be
compiling in one-shot mode with -O2; but when TH compiles a splice before
running it, we don't want to use -O2. Indeed, we don't want to inline
anything, because the byte-code interpreter might get confused about
story for now.
\begin{code}
-postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -> OccInfo -> OutExpr -> Unfolding -> Bool
+postInlineUnconditionally
+ :: SimplEnv -> TopLevelFlag
+ -> InId -- The binder (an OutId would be fine too)
+ -> OccInfo -- From the InId
+ -> OutExpr
+ -> Unfolding
+ -> Bool
postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
| not active = False
| isLoopBreaker occ_info = False
| exprIsTrivial rhs = True
| otherwise
= case occ_info of
- OneOcc in_lam one_br int_cxt
- -> (one_br || smallEnoughToInline unfolding) -- Small enough to dup
+ -- The point of examining occ_info here is that for *non-values*
+ -- that occur outside a lambda, the call-site inliner won't have
+ -- a chance (becuase it doesn't know that the thing
+ -- only occurs once). The pre-inliner won't have gotten
+ -- it either, if the thing occurs in more than one branch
+ -- So the main target is things like
+ -- let x = f y in
+ -- case v of
+ -- True -> case x of ...
+ -- False -> case x of ...
+ -- I'm not sure how important this is in practice
+ OneOcc in_lam one_br int_cxt -- OneOcc => no work-duplication issue
+ -> smallEnoughToInline unfolding -- Small enough to dup
-- ToDo: consider discount on smallEnoughToInline if int_cxt is true
--
- -- NB: Do we want to inline arbitrarily big things becuase
- -- one_br is True? that can lead to inline cascades. But
- -- preInlineUnconditionlly has dealt with all the common cases
- -- so perhaps it's worth the risk. Here's an example
- -- let f = if b then Left (\x.BIG) else Right (\y.BIG)
- -- in \y. ....f....
- -- We can't preInlineUnconditionally because that woud invalidate
- -- the occ info for b. Yet f is used just once, and duplicating
- -- the case work is fine (exprIsCheap).
+ -- NB: Do NOT inline arbitrarily big things, even if one_br is True
+ -- Reason: doing so risks exponential behaviour. We simplify a big
+ -- expression, inline it, and simplify it again. But if the
+ -- very same thing happens in the big expression, we get
+ -- exponential cost!
+ -- PRINCIPLE: when we've already simplified an expression once,
+ -- make sure that we only inline it if it's reasonably small.
&& ((isNotTopLevel top_lvl && not in_lam) ||
-- But outside a lambda, we want to be reasonably aggressive
-- int_cxt to prevent us inlining inside a lambda without some
-- good reason. See the notes on int_cxt in preInlineUnconditionally
+ IAmDead -> True -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+
other -> False
- -- The point here is that for *non-values* that occur
- -- outside a lambda, the call-site inliner won't have
- -- a chance (becuase it doesn't know that the thing
- -- only occurs once). The pre-inliner won't have gotten
- -- it either, if the thing occurs in more than one branch
- -- So the main target is things like
- -- let x = f y in
- -- case v of
- -- True -> case x of ...
- -- False -> case x of ...
- -- I'm not sure how important this is in practice
+
+-- Here's an example that we don't handle well:
+-- let f = if b then Left (\x.BIG) else Right (\y.BIG)
+-- in \y. ....case f of {...} ....
+-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
+-- But
+-- * We can't preInlineUnconditionally because that woud invalidate
+-- the occ info for b.
+-- * We can't postInlineUnconditionally because the RHS is big, and
+-- that risks exponential behaviour
+-- * We can't call-site inline, because the rhs is big
+-- Alas!
+
where
active = case getMode env of
SimplGently -> isAlwaysActive prag
| dopt Opt_DoLambdaEtaExpansion dflags,
any isRuntimeVar bndrs
- = tryEtaExpansion body `thenSmpl` \ body' ->
+ = tryEtaExpansion dflags body `thenSmpl` \ body' ->
returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the
actually computing the expansion.
\begin{code}
-tryEtaExpansion :: OutExpr -> SimplM OutExpr
+tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
-- There is at least one runtime binder in the binders
-tryEtaExpansion body
+tryEtaExpansion dflags body
= getUniquesSmpl `thenSmpl` \ us ->
returnSmpl (etaExpand fun_arity us body (exprType body))
where
- fun_arity = exprEtaExpandArity body
+ fun_arity = exprEtaExpandArity dflags body
\end{code}
%************************************************************************
%* *
-\subsection{Case alternative filtering
-%* *
-%************************************************************************
-
-prepareAlts 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.
-
-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}
-prepareAlts :: OutExpr -- Scrutinee
- -> InId -- Case binder (passed only to use in statistics)
- -> [InAlt] -- Increasing order
- -> SimplM ([InAlt], -- Better alternatives, still incresaing order
- [AltCon]) -- These cases are handled
-
-prepareAlts scrut case_bndr alts
- = let
- (alts_wo_default, maybe_deflt) = findDefault alts
-
- impossible_cons = case scrut of
- Var v -> otherCons (idUnfolding v)
- other -> []
-
- -- Filter out alternatives that can't possibly match
- better_alts | null impossible_cons = alts_wo_default
- | otherwise = [alt | alt@(con,_,_) <- alts_wo_default,
- not (con `elem` impossible_cons)]
-
- -- "handled_cons" are handled either by the context,
- -- or by a branch in this case expression
- -- (Don't add DEFAULT to the handled_cons!!)
- handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
- in
- -- Filter out the default, if it can't happen,
- -- or replace it with "proper" alternative if there
- -- is only one constructor left
- prepareDefault scrut case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
-
- returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
- -- We need the mergeAlts in case the new default_alt
- -- has turned into a constructor alternative.
-
-prepareDefault scrut case_bndr handled_cons (Just rhs)
- | Just (tycon, inst_tys) <- splitTyConApp_maybe (exprType scrut),
- -- Use exprType scrut here, rather than idType case_bndr, because
- -- case_bndr is an InId, so exprType scrut may have more information
- -- Test simpl013 is an example
- isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
- not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
- -- case x of { DEFAULT -> e }
- -- and we don't want to fill in a default for them!
- Just all_cons <- tyConDataCons_maybe tycon,
- not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
- -- which GHC allows, then the case expression will have at most a default
- -- alternative. We don't want to eliminate that alternative, because the
- -- invariant is that there's always one alternative. It's more convenient
- -- to leave
- -- case x of { DEFAULT -> e }
- -- as it is, rather than transform it to
- -- error "case cant match"
- -- which would be quite legitmate. But it's a really obscure corner, and
- -- not worth wasting code on.
- let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
- let missing_cons = [con | con <- all_cons,
- not (con `elem` handled_data_cons)]
- = case missing_cons of
- [] -> returnSmpl [] -- Eliminate the default alternative
- -- if it can't match
-
- [con] -> -- It matches exactly one constructor, so fill it in
- tick (FillInCaseDefault case_bndr) `thenSmpl_`
- mk_args con inst_tys `thenSmpl` \ args ->
- returnSmpl [(DataAlt con, args, rhs)]
-
- two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
-
- | otherwise
- = returnSmpl [(DEFAULT, [], rhs)]
-
-prepareDefault scrut case_bndr handled_cons Nothing
- = returnSmpl []
-
-mk_args missing_con inst_tys
- = mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
- getUniquesSmpl `thenSmpl` \ id_uniqs ->
- let arg_tys = dataConInstArgTys missing_con inst_tys'
- arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
- in
- returnSmpl (tv_bndrs ++ arg_ids)
-
-mk_tv_bndrs missing_con inst_tys
- | isVanillaDataCon missing_con
- = returnSmpl ([], inst_tys)
- | otherwise
- = getUniquesSmpl `thenSmpl` \ tv_uniqs ->
- let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con)
- mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
- in
- returnSmpl (new_tvs, mkTyVarTys new_tvs)
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Case absorption and identity-case elimination}
%* *
%************************************************************************
+
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
------------------------------------------------
mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
-
-
----------------------------------
-mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
--- Merge preserving order; alternatives in the first arg
--- shadow ones in the second
-mergeAlts [] as2 = as2
-mergeAlts as1 [] = as1
-mergeAlts (a1:as1) (a2:as2)
- = case a1 `cmpAlt` a2 of
- LT -> a1 : mergeAlts as1 (a2:as2)
- EQ -> a1 : mergeAlts as1 as2 -- Discard a2
- GT -> a2 : mergeAlts (a1:as1) as2
\end{code}
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 = mkConApp con (arg_tys ++ map varToCoreExpr 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 = 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 _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) 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
+
--------------------------------------------------
projects / ghc-hetmet.git / blobdiff