#include "HsVersions.h"
-import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
+import DynFlags ( dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..)
)
import SimplMonad
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
- setIdOccInfo, zapLamIdInfo, setOneShotLambda,
+ setIdOccInfo, zapLamIdInfo, setOneShotLambda
)
import MkId ( eRROR_ID )
import Literal ( mkStringLit )
import TyCon ( tyConArity )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline )
+import CoreUnfold ( mkUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
- exprType, exprIsValue,
+ exprType, exprIsHNF,
exprOkForSpeculation, exprArity,
mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
)
RecFlag(..), isNonRec
)
import OrdList
-import Maybe ( Maybe )
import Maybes ( orElse )
import Outputable
import Util ( notNull )
#endif
simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
- | preInlineUnconditionally env NotTopLevel bndr
+ = simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside
+
+simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr rhs
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs))
-
- | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
+ | isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty -- A strict let
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
simplLetBndr env bndr `thenSmpl` \ (env, bndr1) ->
bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
env2 = modifyInScope env1 bndr2 bndr2
in
- completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
+ if needsCaseBinding bndr_ty rhs1
+ then
+ thing_inside env2 `thenSmpl` \ (floats, body) ->
+ returnSmpl (emptyFloats env2, Case rhs1 bndr2 (exprType body)
+ [(DEFAULT, [], wrapFloats floats body)])
+ else
+ completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
+
+ where
+ bndr_ty = idType bndr
\end{code}
A specialised variant of simplNonRec used when the RHS is already simplified, notably
let body' = wrapFloats floats body in
returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
- | preInlineUnconditionally env NotTopLevel bndr
+ | preInlineUnconditionally env NotTopLevel bndr new_rhs
-- 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
-> SimplM (FloatsWith SimplEnv)
simplRecOrTopPair env top_lvl bndr bndr' rhs
- | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
- = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs))
| otherwise
if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
completeLazyBind env1 top_lvl bndr bndr2 rhs2
- else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+ else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then
-- WARNING: long dodgy argument coming up
-- WANTED: a better way to do this
--
- -- We can't use "exprIsCheap" instead of exprIsValue,
+ -- We can't use "exprIsCheap" instead of exprIsHNF,
-- because that causes a strictness bug.
-- x = let y* = E in case (scc y) of { T -> F; F -> T}
-- The case expression is 'cheap', but it's wrong to transform to
-- y* = E; x = case (scc y) of {...}
-- Either we must be careful not to float demanded non-values, or
- -- we must use exprIsValue for the test, which ensures that the
- -- thing is non-strict. So exprIsValue => bindings are non-strict
+ -- we must use exprIsHNF for the test, which ensures that the
+ -- thing is non-strict. So exprIsHNF => bindings are non-strict
-- I think. The WARN below tests for this.
--
-- We use exprIsTrivial here because we want to reveal lone variables.
-- E.g. let { x = letrec { y = E } in y } in ...
-- Here we definitely want to float the y=E defn.
- -- exprIsValue definitely isn't right for that.
+ -- exprIsHNF definitely isn't right for that.
--
-- Again, the floated binding can't be strict; if it's recursive it'll
-- be non-strict; if it's non-recursive it'd be inlined.
-- (as usual) use the in-scope-env from the floats
completeLazyBind env top_lvl old_bndr new_bndr new_rhs
- | postInlineUnconditionally env new_bndr occ_info new_rhs
+ | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
= -- Drop the binding
tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
-- After inling f at some of its call sites the original binding may
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
final_info | loop_breaker = new_bndr_info
| isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
returnSmpl (unitFloat env final_id new_rhs, env)
where
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
loop_breaker = isLoopBreaker occ_info
old_info = idInfo old_bndr
occ_info = occInfo old_info
\begin{code}
simplNote env (Coerce to from) body cont
= let
+ addCoerce s1 k1 cont -- Drop redundant coerces. This can happen if a polymoprhic
+ -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the
+ -- two are the same. This happens a lot in Happy-generated parsers
+ | s1 `coreEqType` k1 = cont
+
addCoerce s1 k1 (CoerceIt t1 cont)
-- coerce T1 S1 (coerce S1 K1 e)
-- ==>
-- 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 `coreEqType` k1 = cont -- The coerces cancel out
- | otherwise = CoerceIt t1 cont -- They don't cancel, but
- -- the inner one is redundant
+ | t1 `coreEqType` 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)
| not (isTypeArg arg), -- This whole case only works for value args
case maybe_inline of {
Just unfolding -- There is an inlining!
-> tick (UnfoldingDone var) `thenSmpl_`
+ (if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Inlining done" (vcat [
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
+ text "Inlined fn: " <+> ppr unfolding,
+ text "Cont: " <+> ppr call_cont])
+ else
+ id) $
makeThatCall env var unfolding args call_cont
;
= knownCon env (LitAlt lit) [] case_bndr alts cont
| otherwise
- = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
+ = -- Prepare the alternatives.
+ prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
- -- Deal with the case binder, and prepare the continuation;
+ -- Prepare the continuation;
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
res_ty' = contResultType dup_cont
in
- -- Deal with variable scrutinee
+ -- Deal with case binder
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
-- Deal with the case alternatives
projects / ghc-hetmet.git / blobdiff