X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=34fc015f4595dd42bcf7f21ab64e09410ed15dbb;hb=0a277a7671265265e819136280a8aec58727b364;hp=4683370bcf8ceb5138af8c9317a1b57b20db0e1f;hpb=11b6ad6c7fa563c0413b74d08b30f165b177d92c;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 4683370..34fc015 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -10,59 +10,59 @@ module Simplify ( simplTopBinds, simplExpr ) where import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction, opt_SimplNoPreInlining, + dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion, findAlt, - simplBinder, simplBinders, simplIds, findDefault, +import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion, + simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinder, 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, + idNewDemandInfo, setIdInfo, + idOccInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, setArityInfo, - setUnfoldingInfo, atLeastArity, + setUnfoldingInfo, occInfo ) -import Demand ( isStrict ) +import NewDemand ( isStrictDmd ) import DataCon ( dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys ) import CoreSyn -import CoreFVs ( mustHaveLocalBinding, exprFreeVars ) +import PprCore ( pprParendExpr, pprCoreExpr ) 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, + exprOkForSpeculation, exprArity, mkCoerce, mkSCC, mkInlineMe, mkAltExpr ) import Rules ( lookupRule ) 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} @@ -95,7 +95,7 @@ simplTopBinds binds -- 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') @@ -187,19 +187,20 @@ simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) -> 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 -> @@ -214,103 +215,45 @@ simplExprF (Case scrut bndr alts) cont (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 - -simplExprF (Note InlineCall e) cont - = simplExprF e (InlinePlease 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 --- 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 @@ -330,7 +273,7 @@ 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 @@ -350,7 +293,7 @@ simplLam fun cont -- to avoid allocating this thing altogether completeLam rev_bndrs (Lam bndr body) cont - = simplBinder bndr $ \ bndr' -> + = simplLamBinder bndr $ \ bndr' -> completeLam (bndr':rev_bndrs) body cont completeLam rev_bndrs body cont @@ -362,8 +305,12 @@ completeLam rev_bndrs body cont 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 @@ -371,8 +318,9 @@ completeLam rev_bndrs body cont 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 @@ -391,16 +339,108 @@ mkLamBndrZapper fun cont \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} @@ -410,42 +450,53 @@ simplType ty %* * %************************************************************************ -@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' + is_strict = isStrictDmd (idNewDemandInfo 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} @@ -578,13 +629,11 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside 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 -- Add the unfolding *only* for non-loop-breakers -- Making loop breakers not have an unfolding at all @@ -608,7 +657,7 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside loop_breaker = isLoopBreaker occ_info trivial_rhs = exprIsTrivial new_rhs must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr - arity_info = atLeastArity (exprArity new_rhs) + arity = exprArity new_rhs \end{code} @@ -651,13 +700,21 @@ simplLazyBind top_lvl bndr bndr' rhs thing_inside 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} @@ -676,14 +733,6 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside let (floats2, rhs2) = splitFloats float_ubx floats1 rhs1 in - -- There's a subtlety here. There may be a binding (x* = e) in the - -- floats, where the '*' means 'will be demanded'. So is it safe - -- to float it out? Answer no, but it won't matter because - -- we only float if arg' is a WHNF, - -- and so there can't be any 'will be demanded' bindings in the floats. - -- Hence the assert - WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) ) - -- Transform the RHS -- It's important that we do eta expansion on function *arguments* (which are -- simplified with simplRhs), as well as let-bound right-hand sides. @@ -696,7 +745,25 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside -- Float lets if (a) we're at the top level -- or (b) the resulting RHS is one we'd like to expose - if (top_lvl || exprIsCheap rhs4) then + -- + -- NB: the test used to say "exprIsCheap", but that caused 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. I think. The WARN below tests for this + if (top_lvl || exprIsValue rhs4) then + + -- There's a subtlety here. There may be a binding (x* = e) in the + -- floats, where the '*' means 'will be demanded'. So is it safe + -- to float it out? Answer no, but it won't matter because + -- we only float if arg' is a WHNF, + -- and so there can't be any 'will be demanded' bindings in the floats. + -- Hence the assert + WARN( any demanded_float (fromOL floats2), + ppr (filter demanded_float (fromOL floats2)) ) + (if (isNilOL floats2 && null floats3 && null floats4) then returnSmpl () else @@ -710,7 +777,7 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside -- Don't do the float thing_inside (wrapFloats floats1 rhs1) -demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b)) +demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them demanded_float (Rec _) = False @@ -810,19 +877,35 @@ completeCall var occ_info cont -- won't occur for things that have specialisations till a later phase, so -- it's ok to try for inlining first. -- - -- Don't apply rules for a loop breaker: doing so might give rise - -- to an infinite loop, for the same reasons that inlining the ordinary - -- RHS of a loop breaker might. + -- You might think that we shouldn't apply rules for a loop breaker: + -- doing so might give rise to an infinite loop, because a RULE is + -- rather like an extra equation for the function: + -- RULE: f (g x) y = x+y + -- Eqn: f a y = a-y + -- + -- But it's too drastic to disable rules for loop breakers. + -- Even the foldr/build rule would be disabled, because foldr + -- is recursive, and hence a loop breaker: + -- foldr k z (build g) = g k z + -- So it's up to the programmer: rules can cause divergence getSwitchChecker `thenSmpl` \ chkr -> let - maybe_rule | switchIsOn chkr DontApplyRules - || isLoopBreaker occ_info = Nothing + maybe_rule | switchIsOn chkr DontApplyRules = Nothing | otherwise = lookupRule in_scope var args' in case maybe_rule of { Just (rule_name, rule_rhs) -> tick (RuleFired rule_name) `thenSmpl_` +#ifdef DEBUG + (if dopt Opt_D_dump_inlinings dflags then + pprTrace "Rule fired" (vcat [ + text "Rule:" <+> ptext rule_name, + text "Before:" <+> ppr var <+> sep (map pprParendExpr args'), + text "After: " <+> pprCoreExpr rule_rhs]) + else + id) $ +#endif simplExprF rule_rhs call_cont ; Nothing -> -- No rules @@ -875,7 +958,8 @@ simplifyArgs is_data_con args cont_ty thing_inside -- 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' @@ -1153,7 +1237,7 @@ canEliminateCase scrut bndr alts (rhs1:other_rhss) = rhssOfAlts alts binders_unused (_, bndrs, _) = all isDeadBinder bndrs - var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later + var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo bndr) -- It's going to be evaluated later var_demanded_later other = False @@ -1201,7 +1285,11 @@ knownCon :: OutExpr -> AltCon -> [OutExpr] -> SimplM OutExprStuff knownCon expr con args bndr alts se cont - = tick (KnownBranch bndr) `thenSmpl_` + = -- Arguments should be atomic; + -- yell if not + WARN( not (all exprIsTrivial args), + text "knownCon" <+> ppr expr ) + tick (KnownBranch bndr) `thenSmpl_` setSubstEnv se ( simplBinder bndr $ \ bndr' -> completeBinding bndr bndr' False False expr $ @@ -1313,9 +1401,9 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts 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') @@ -1348,7 +1436,8 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' -- 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 @@ -1390,9 +1479,9 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' cat_evals [] [] = [] cat_evals (v:vs) (str:strs) - | isTyVar v = v : cat_evals vs (str:strs) - | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs - | otherwise = v' : cat_evals vs strs + | isTyVar v = v : cat_evals vs (str:strs) + | isStrictDmd str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs + | otherwise = v' : cat_evals vs strs where v' = zap_occ_info v \end{code} @@ -1549,13 +1638,20 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside -- 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])