X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=6bc7e0b97e88eb18f833e3d6abfa5581c20c7229;hb=9fc1b8f32d66e7abf2bed504fb59461f37a77169;hp=df80c4a66e6dd978e676436609d677e3adf60650;hpb=c177e43f99dcd525b78ee0ac8f16c3d42c618e1f;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index df80c4a..6bc7e0b 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -28,9 +28,7 @@ import CoreMonad ( Tick(..), SimplifierMode(..) ) import CoreSyn import Demand ( isStrictDmd ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, mkCoreUnfolding - , mkInlineUnfolding, mkSimpleUnfolding - , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUnfold import CoreUtils import qualified CoreSubst import CoreArity @@ -638,7 +636,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs -- Simplify the unfolding - ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info final_rhs old_unf + ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding -- Inline and discard the binding @@ -678,7 +676,7 @@ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv -- opportunity to inline 'y' too. addPolyBind top_lvl env (NonRec poly_id rhs) - = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding + = do { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding -- Assumes that poly_id did not have an INLINE prag -- which is perhaps wrong. ToDo: think about this ; let final_id = setIdInfo poly_id $ @@ -695,16 +693,16 @@ addPolyBind _ env bind@(Rec _) ------------------------------ simplUnfolding :: SimplEnv-> TopLevelFlag - -> Id - -> OccInfo -> OutExpr + -> InId + -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) +simplUnfolding env _ _ _ (DFunUnfolding ar con ops) = return (DFunUnfolding ar con ops') where - ops' = map (substExpr (text "simplUnfolding") env) ops + ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops -simplUnfolding env top_lvl id _ _ +simplUnfolding env top_lvl id _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) | isStableSource src @@ -712,36 +710,46 @@ simplUnfolding env top_lvl id _ _ ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src is_top_lvl = isTopLevel top_lvl ; case guide of - UnfIfGoodArgs{} -> - -- We need to force bottoming, or the new unfolding holds - -- on to the old unfolding (which is part of the id). - let bottoming = isBottomingId id - in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr') + UnfWhen sat_ok _ -- Happens for INLINE things + -> let guide' = UnfWhen sat_ok (inlineBoringOk expr') + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in TcInstDcls. + -- A test case is Trac #4138 + in return (mkCoreUnfolding src' is_top_lvl expr' arity guide') + -- See Note [Top-level flag on inline rules] in CoreUnfold + + _other -- Happens for INLINABLE things + -> let bottoming = isBottomingId id + in bottoming `seq` -- See Note [Force bottoming field] + return (mkUnfolding src' is_top_lvl bottoming expr') -- If the guidance is UnfIfGoodArgs, this is an INLINABLE -- unfolding, and we need to make sure the guidance is kept up -- to date with respect to any changes in the unfolding. - _other -> - return (mkCoreUnfolding src' is_top_lvl expr' arity guide) - -- See Note [Top-level flag on inline rules] in CoreUnfold } where act = idInlineActivation id rule_env = updMode (updModeForInlineRules act) env -- See Note [Simplifying inside InlineRules] in SimplUtils -simplUnfolding _ top_lvl id _occ_info new_rhs _ - = -- We need to force bottoming, or the new unfolding holds - -- on to the old unfolding (which is part of the id). - let bottoming = isBottomingId id - in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs) - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In TidyPgm we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. +simplUnfolding _ top_lvl id new_rhs _ + = let bottoming = isBottomingId id + in bottoming `seq` -- See Note [Force bottoming field] + return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. \end{code} +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + Note [Arity decrease] ~~~~~~~~~~~~~~~~~~~~~ Generally speaking the arity of a binding should not decrease. But it *can* @@ -1052,6 +1060,19 @@ simplCast env body co0 cont0 %* * %************************************************************************ +Note [Zap unfolding when beta-reducing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lambda-bound variables can have stable unfoldings, such as + $j = \x. \b{Unf=Just x}. e +See Note [Case binders and join points] below; the unfolding for lets +us optimise e better. However when we beta-reduce it we want to +revert to using the actual value, otherwise we can end up in the +stupid situation of + let x = blah in + let b{Unf=Just x} = y + in ...b... +Here it'd be far better to drop the unfolding and use the actual RHS. + \begin{code} simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) @@ -1061,7 +1082,12 @@ simplLam env [] body cont = simplExprF env body cont -- Beta reduction simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont) = do { tick (BetaReduction bndr) - ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } + ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont } + where + zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing] + | isId bndr, isStableUnfolding (realIdUnfolding bndr) + = setIdUnfolding bndr NoUnfolding + | otherwise = bndr -- Not enough args, so there are real lambdas left to put in the result simplLam env bndrs body cont @@ -1363,14 +1389,15 @@ tryRules env rules fn args call_cont return (Just (ruleArity rule, rule_rhs)) }}}} where trace_dump dflags rule rule_rhs stuff - | not (dopt Opt_D_dump_rule_firings dflags) = stuff - | not (dopt Opt_D_verbose_core2core dflags) + | not (dopt Opt_D_dump_rule_firings dflags) + , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff + | not (dopt Opt_D_dump_rule_rewrites dflags) = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff | otherwise = pprTrace "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), - text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), + text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) stuff @@ -1443,6 +1470,17 @@ Lastly, the code in SimplUtils.mkCase combines identical RHSs. So Now again the case may be elminated by the CaseElim transformation. +Note [CaseElimination: lifted case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not use exprOkForSpeculation in the lifted case. Consider + case (case a ># b of { True -> (p,q); False -> (q,p) }) of + r -> blah +The scrutinee is ok-for-speculation (it looks inside cases), but we do +not want to transform to + let r = case a ># b of { True -> (p,q); False -> (q,p) } + in blah +because that builds an unnecessary thunk. + Further notes about case elimination ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1535,28 +1573,23 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont | all isDeadBinder bndrs -- bndrs are [InId] -- Check that the scrutinee can be let-bound instead of case-bound - , exprOkForSpeculation scrut - -- OK not to evaluate it - -- This includes things like (==# a# b#)::Bool - -- so that we simplify - -- case ==# a# b# of { True -> x; False -> x } - -- to just - -- x - -- This particular example shows up in default methods for - -- comparision operations (e.g. in (>=) for Int.Int32) - || exprIsHNF scrut -- It's already evaluated - || var_demanded_later scrut -- It'll be demanded later - --- || not opt_SimplPedanticBottoms) -- Or we don't care! --- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on, --- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate --- its argument: case x of { y -> dataToTag# y } --- Here we must *not* discard the case, because dataToTag# just fetches the tag from --- the info pointer. So we'll be pedantic all the time, and see if that gives any --- other problems --- Also we don't want to discard 'seq's + , if isUnLiftedType (idType case_bndr) + then exprOkForSpeculation scrut + -- Satisfy the let-binding invariant + -- This includes things like (==# a# b#)::Bool + -- so that we simplify + -- case ==# a# b# of { True -> x; False -> x } + -- to just + -- x + -- This particular example shows up in default methods for + -- comparision operations (e.g. in (>=) for Int.Int32) + + else exprIsHNF scrut || var_demanded_later scrut + -- It's already evaluated, or will be demanded later + -- See Note [Case elimination: lifted case] = do { tick (CaseElim case_bndr) ; env' <- simplNonRecX env case_bndr scrut + -- If case_bndr is deads, simplNonRecX will discard ; simplExprF env' rhs cont } where -- The case binder is going to be evaluated later,