SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion, findAlt,
- simplBinder, simplBinders, simplIds, findDefault,
+import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
+ simplBinder, simplBinders, simplRecIds, simplLetId,
SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
contResultType, discardInline, countArgs, contIsDupable,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
-import Var ( mkSysTyVar, tyVarKind )
+import Var ( mkSysTyVar, tyVarKind, mustHaveLocalBinding )
import VarEnv
-import VarSet ( elemVarSet )
-import Id ( Id, idType, idInfo, isDataConId,
+import Literal ( Literal )
+import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,
idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
idDemandInfo, setIdInfo,
- idOccInfo, setIdOccInfo,
+ idOccInfo, setIdOccInfo,
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
)
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreFVs ( mustHaveLocalBinding, exprFreeVars )
import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
callSiteInline
)
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
- exprIsConApp_maybe, mkPiType,
+ exprIsConApp_maybe, mkPiType, findAlt, findDefault,
exprType, coreAltsType, exprIsValue,
exprOkForSpeculation, exprArity, exprIsCheap,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
mkFunTy, splitTyConApp_maybe, tyConAppArgs,
- funResultTy
+ funResultTy, splitFunTy_maybe, splitFunTy, eqType
)
-import Subst ( mkSubst, substTy,
- isInScope, lookupIdSubst, substIdInfo
+import Subst ( mkSubst, substTy, substEnv, substExpr,
+ isInScope, lookupIdSubst, simplIdInfo
)
import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import OrdList
import Maybes ( maybeToBool )
-import Util ( zipWithEqual )
import Outputable
\end{code}
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- simplIds (bindersOfBinds binds) $ \ bndrs' ->
+ simplRecIds (bindersOfBinds binds) $ \ bndrs' ->
simpl_binds binds bndrs' `thenSmpl` \ (binds', _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (fromOL binds')
simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
-- Simplify an expression, returning floated binds
-simplExprF (Var v) cont
- = simplVar v cont
-
-simplExprF (Lit lit) (Select _ bndr alts se cont)
- = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
-
-simplExprF (Lit lit) cont
- = rebuild (Lit lit) cont
+simplExprF (Var v) cont = simplVar v cont
+simplExprF (Lit lit) cont = simplLit lit cont
+simplExprF expr@(Lam _ _) cont = simplLam expr cont
+simplExprF (Note note expr) cont = simplNote note expr cont
simplExprF (App fun arg) cont
= getSubstEnv `thenSmpl` \ se ->
simplExprF fun (ApplyTo NoDup arg se cont)
+simplExprF (Type ty) cont
+ = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
+ simplType ty `thenSmpl` \ ty' ->
+ rebuild (Type ty') cont
+
simplExprF (Case scrut bndr alts) cont
= getSubstEnv `thenSmpl` \ subst_env ->
getSwitchChecker `thenSmpl` \ chkr ->
(mkStop (contResultType cont))) `thenSmpl` \ case_expr' ->
rebuild case_expr' cont
-
simplExprF (Let (Rec pairs) body) cont
- = simplIds (map fst pairs) $ \ bndrs' ->
+ = simplRecIds (map fst pairs) $ \ bndrs' ->
-- NB: bndrs' don't have unfoldings or spec-envs
-- We add them as we go down, using simplPrags
simplRecBind False pairs bndrs' (simplExprF body cont)
-simplExprF expr@(Lam _ _) cont = simplLam expr cont
-
-simplExprF (Type ty) cont
- = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
- simplType ty `thenSmpl` \ ty' ->
- rebuild (Type ty') cont
-
--- Comments about the Coerce case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- It's worth checking for a coerce in the continuation,
--- in case we can cancel them. For example, in the initial form of a worker
--- we may find (coerce T (coerce S (\x.e))) y
--- and we'd like it to simplify to e[y/x] in one round of simplification
-
-simplExprF (Note (Coerce to from) e) (CoerceIt outer_to cont)
- = simplType from `thenSmpl` \ from' ->
- if outer_to == from' then
- -- The coerces cancel out
- simplExprF e cont
- else
- -- They don't cancel, but the inner one is redundant
- simplExprF e (CoerceIt outer_to cont)
-
-simplExprF (Note (Coerce to from) e) cont
- = simplType to `thenSmpl` \ to' ->
- simplExprF e (CoerceIt to' cont)
-
--- hack: we only distinguish subsumed cost centre stacks for the purposes of
--- inlining. All other CCCSs are mapped to currentCCS.
-simplExprF (Note (SCC cc) e) cont
- = setEnclosingCC currentCCS $
- simplExpr e `thenSmpl` \ e ->
- rebuild (mkSCC cc e) cont
+-- A non-recursive let is dealt with by simplNonRecBind
+simplExprF (Let (NonRec bndr rhs) body) cont
+ = getSubstEnv `thenSmpl` \ se ->
+ simplNonRecBind bndr rhs se (contResultType cont) $
+ simplExprF body cont
-simplExprF (Note InlineCall e) cont
- = simplExprF e (InlinePlease cont)
--- Comments about the InlineMe case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Don't inline in the RHS of something that has an
--- inline pragma. But be careful that the InScopeEnv that
--- we return does still have inlinings on!
---
--- It really is important to switch off inlinings. This function
--- may be inlinined in other modules, so we don't want to remove
--- (by inlining) calls to functions that have specialisations, or
--- that may have transformation rules in an importing scope.
--- E.g. {-# INLINE f #-}
--- f x = ...g...
--- and suppose that g is strict *and* has specialisations.
--- If we inline g's wrapper, we deny f the chance of getting
--- the specialised version of g when f is inlined at some call site
--- (perhaps in some other module).
-
--- It's also important not to inline a worker back into a wrapper.
--- A wrapper looks like
--- wraper = inline_me (\x -> ...worker... )
--- Normally, the inline_me prevents the worker getting inlined into
--- the wrapper (initially, the worker's only call site!). But,
--- if the wrapper is sure to be called, the strictness analyser will
--- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
--- continuation. That's why the keep_inline predicate returns True for
--- ArgOf continuations. It shouldn't do any harm not to dissolve the
--- inline-me note under these circumstances
+---------------------------------
+simplType :: InType -> SimplM OutType
+simplType ty
+ = getSubst `thenSmpl` \ subst ->
+ let
+ new_ty = substTy subst ty
+ in
+ seqType new_ty `seq`
+ returnSmpl new_ty
-simplExprF (Note InlineMe e) cont
- | keep_inline cont -- Totally boring continuation
- = -- Don't inline inside an INLINE expression
- setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' ->
- rebuild (mkInlineMe e') cont
+---------------------------------
+simplLit :: Literal -> SimplCont -> SimplM OutExprStuff
- | otherwise -- Dissolve the InlineMe note if there's
- -- an interesting context of any kind to combine with
- -- (even a type application -- anything except Stop)
- = simplExprF e cont
- where
- keep_inline (Stop _ _) = True -- See notes above
- keep_inline (ArgOf _ _ _) = True -- about this predicate
- keep_inline other = False
+simplLit lit (Select _ bndr alts se cont)
+ = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
--- A non-recursive let is dealt with by simplBeta
-simplExprF (Let (NonRec bndr rhs) body) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplBeta bndr rhs se (contResultType cont) $
- simplExprF body cont
+simplLit lit cont = rebuild (Lit lit) cont
\end{code}
----------------------------------
+%************************************************************************
+%* *
+\subsection{Lambdas}
+%* *
+%************************************************************************
\begin{code}
simplLam fun cont
-- Ordinary beta reduction
go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
= tick (BetaReduction bndr) `thenSmpl_`
- simplBeta zapped_bndr arg arg_se cont_ty
+ simplNonRecBind zapped_bndr arg arg_se cont_ty
(go body body_cont)
where
zapped_bndr = zap_it bndr
Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
where
-- We don't use CoreUtils.etaReduce, because we can be more
- -- efficient here: (a) we already have the binders, (b) we can do
- -- the triviality test before computing the free vars
+ -- efficient here:
+ -- (a) we already have the binders,
+ -- (b) we can do the triviality test before computing the free vars
+ -- [in fact I take the simple path and look for just a variable]
+ -- (c) we don't want to eta-reduce a data con worker or primop
+ -- because we only have to eta-expand them later when we saturate
try_eta body | not opt_SimplDoEtaReduction = Nothing
| otherwise = go rev_bndrs body
go [] body | ok_body body = Just body -- Success!
go _ _ = Nothing -- Failure!
- ok_body body = exprIsTrivial body && not (any (`elemVarSet` exprFreeVars body) rev_bndrs)
- ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+ ok_body (Var v) = not (v `elem` rev_bndrs) && not (hasNoBinding v)
+ ok_body other = False
+ ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
mkLamBndrZapper :: CoreExpr -- Function
-> SimplCont -- The context
\end{code}
----------------------------------
+%************************************************************************
+%* *
+\subsection{Notes}
+%* *
+%************************************************************************
+
\begin{code}
-simplType :: InType -> SimplM OutType
-simplType ty
- = getSubst `thenSmpl` \ subst ->
+simplNote (Coerce to from) body cont
+ = getInScope `thenSmpl` \ in_scope ->
let
- new_ty = substTy subst ty
+ addCoerce s1 k1 (CoerceIt t1 cont)
+ -- coerce T1 S1 (coerce S1 K1 e)
+ -- ==>
+ -- e, if T1=K1
+ -- coerce T1 K1 e, otherwise
+ --
+ -- For example, in the initial form of a worker
+ -- we may find (coerce T (coerce S (\x.e))) y
+ -- and we'd like it to simplify to e[y/x] in one round
+ -- of simplification
+ | t1 `eqType` k1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt t1 cont -- They don't cancel, but
+ -- the inner one is redundant
+
+ addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
+ | Just (s1, s2) <- splitFunTy_maybe s1s2
+ -- (coerce (T1->T2) (S1->S2) F) E
+ -- ===>
+ -- coerce T2 S2 (F (coerce S1 T1 E))
+ --
+ -- t1t2 must be a function type, T1->T2
+ -- but s1s2 might conceivably not be
+ --
+ -- When we build the ApplyTo we can't mix the out-types
+ -- with the InExpr in the argument, so we simply substitute
+ -- to make it all consistent. This isn't a common case.
+ = let
+ (t1,t2) = splitFunTy t1t2
+ new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope arg_se) arg)
+ in
+ ApplyTo dup new_arg emptySubstEnv (addCoerce t2 s2 cont)
+
+ addCoerce to' _ cont = CoerceIt to' cont
in
- seqType new_ty `seq`
- returnSmpl new_ty
+ simplType to `thenSmpl` \ to' ->
+ simplType from `thenSmpl` \ from' ->
+ simplExprF body (addCoerce to' from' cont)
+
+
+-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
+-- inlining. All other CCCSs are mapped to currentCCS.
+simplNote (SCC cc) e cont
+ = setEnclosingCC currentCCS $
+ simplExpr e `thenSmpl` \ e ->
+ rebuild (mkSCC cc e) cont
+
+simplNote InlineCall e cont
+ = simplExprF e (InlinePlease cont)
+
+-- Comments about the InlineMe case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Don't inline in the RHS of something that has an
+-- inline pragma. But be careful that the InScopeEnv that
+-- we return does still have inlinings on!
+--
+-- It really is important to switch off inlinings. This function
+-- may be inlinined in other modules, so we don't want to remove
+-- (by inlining) calls to functions that have specialisations, or
+-- that may have transformation rules in an importing scope.
+-- E.g. {-# INLINE f #-}
+-- f x = ...g...
+-- and suppose that g is strict *and* has specialisations.
+-- If we inline g's wrapper, we deny f the chance of getting
+-- the specialised version of g when f is inlined at some call site
+-- (perhaps in some other module).
+
+-- It's also important not to inline a worker back into a wrapper.
+-- A wrapper looks like
+-- wraper = inline_me (\x -> ...worker... )
+-- Normally, the inline_me prevents the worker getting inlined into
+-- the wrapper (initially, the worker's only call site!). But,
+-- if the wrapper is sure to be called, the strictness analyser will
+-- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+-- continuation. That's why the keep_inline predicate returns True for
+-- ArgOf continuations. It shouldn't do any harm not to dissolve the
+-- inline-me note under these circumstances
+
+simplNote InlineMe e cont
+ | keep_inline cont -- Totally boring continuation
+ = -- Don't inline inside an INLINE expression
+ noInlineBlackList `thenSmpl` \ bl ->
+ setBlackList bl (simplExpr e) `thenSmpl` \ e' ->
+ rebuild (mkInlineMe e') cont
+
+ | otherwise -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ = simplExprF e cont
+ where
+ keep_inline (Stop _ _) = True -- See notes above
+ keep_inline (ArgOf _ _ _) = True -- about this predicate
+ keep_inline other = False
\end{code}
%* *
%************************************************************************
-@simplBeta@ is used for non-recursive lets in expressions,
+@simplNonRecBind@ is used for non-recursive lets in expressions,
as well as true beta reduction.
Very similar to @simplLazyBind@, but not quite the same.
\begin{code}
-simplBeta :: InId -- Binder
+simplNonRecBind :: InId -- Binder
-> InExpr -> SubstEnv -- Arg, with its subst-env
-> OutType -- Type of thing computed by the context
-> SimplM OutExprStuff -- The body
-> SimplM OutExprStuff
#ifdef DEBUG
-simplBeta bndr rhs rhs_se cont_ty thing_inside
+simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| isTyVar bndr
- = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
+ = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
#endif
-simplBeta bndr rhs rhs_se cont_ty thing_inside
+simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally False {- not black listed -} bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
extendSubst bndr (ContEx rhs_se rhs) thing_inside
| otherwise
- = -- Simplify the RHS
- simplBinder bndr $ \ bndr' ->
+ = -- Simplify the binder.
+ -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId bndr $ \ bndr' ->
+ getSubst `thenSmpl` \ bndr_subst ->
let
+ -- Substitute its IdInfo (which simplLetId does not)
+ -- The appropriate substitution env is the one right here,
+ -- not rhs_se. Often they are the same, when all this
+ -- has arisen from an application (\x. E) RHS, perhaps they aren't
+ bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr'
bndr_ty' = idType bndr'
is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
in
+ modifyInScope bndr'' bndr'' $
+
+ -- Simplify the argument
simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-- Now complete the binding and simplify the body
if needsCaseBinding bndr_ty' rhs' then
- addCaseBind bndr' rhs' thing_inside
+ addCaseBind bndr'' rhs' thing_inside
else
- completeBinding bndr bndr' False False rhs' thing_inside
+ completeBinding bndr bndr'' False False rhs' thing_inside
\end{code}
thing_inside
| otherwise
- = getSubst `thenSmpl` \ subst ->
- let
+ = let
-- We make new IdInfo for the new binder by starting from the old binder,
-- doing appropriate substitutions.
-- Then we add arity and unfolding info to get the new binder
- new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
- `setArityInfo` arity_info
+ new_bndr_info = idInfo new_bndr `setArityInfo` arity_info
-- Add the unfolding *only* for non-loop-breakers
-- Making loop breakers not have an unfolding at all
else
-- Simplify the RHS
- getSubstEnv `thenSmpl` \ rhs_se ->
+ getSubst `thenSmpl` \ rhs_subst ->
+ let
+ -- Substitute IdInfo on binder, in the light of earlier
+ -- substitutions in this very letrec, and extend the in-scope
+ -- env so that it can see the new thing
+ bndr'' = simplIdInfo rhs_subst (idInfo bndr) bndr'
+ in
+ modifyInScope bndr'' bndr'' $
+
simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
(idType bndr')
- rhs rhs_se $ \ rhs' ->
+ rhs (substEnv rhs_subst) $ \ rhs' ->
-- Now compete the binding and simplify the body
- completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside
+ completeBinding bndr bndr'' top_lvl black_listed rhs' thing_inside
\end{code}
-- Even though x get's an occurrence of 'many', its RHS looks cheap,
-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
= getBlackList `thenSmpl` \ old_bl ->
- setBlackList noInlineBlackList $
+ noInlineBlackList `thenSmpl` \ ni_bl ->
+ setBlackList ni_bl $
go args $ \ args' ->
setBlackList old_bl $
thing_inside args'
let
(_,_,ex_tyvars,_,_,_) = dataConSig data_con
in
- getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
+ getUniquesSmpl `thenSmpl` \ tv_uniqs ->
let
- ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+ ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys data_con
(inst_tys ++ mkTyVarTys ex_tyvars')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
- handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
+ (con_alts,_) = findDefault alts
+ handled_cons = scrut_cons ++ [con | (con,_,_) <- con_alts]
simpl_alt (DEFAULT, _, rhs)
= -- In the default case we record the constructors that the
-- Consider: let j = if .. then I# 3 else I# 4
-- in case .. of { A -> j; B -> j; C -> ... }
--
- -- Now CPR should not w/w j because it's a thunk, so
+ -- Now CPR doesn't w/w j because it's a thunk, so
-- that means that the enclosing function can't w/w either,
-- which is a lose. Here's the example that happened in practice:
-- kgmod :: Int -> Int -> Int
-- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
-- then 78
-- else 5
+ --
+ -- I have seen a case alternative like this:
+ -- True -> \v -> ...
+ -- It's a bit silly to add the realWorld dummy arg in this case, making
+ -- $j = \s v -> ...
+ -- True -> $j s
+ -- (the \v alone is enough to make CPR happy) but I think it's rare
then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
projects / ghc-hetmet.git / blobdiff