X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=6bc7e0b97e88eb18f833e3d6abfa5581c20c7229;hb=62af0377c41ffcc76ae308e07e328106846f050c;hp=179af4f3450565ea013f8c9468c121697c3638fc;hpb=1bdb9062b5b8143b131bc533e4b47c67be3d458c;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 179af4f..6bc7e0b 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -24,16 +24,14 @@ import Coercion import OptCoercion ( optCoercion ) import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) -import CoreMonad ( SimplifierSwitch(..), Tick(..) ) +import CoreMonad ( Tick(..), SimplifierMode(..) ) import CoreSyn -import Demand ( isStrictDmd, splitStrictSig ) +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 ( exprArity ) +import CoreArity import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) @@ -237,7 +235,7 @@ simplTopBinds env0 binds0 trace_bind False _ = \x -> x simpl_bind env (Rec pairs) = simplRecBind env TopLevel pairs - simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r + simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r where (env', b') = addBndrRules env b (lookupRecBndr env b) \end{code} @@ -272,7 +270,7 @@ simplRecBind env0 top_lvl pairs0 go env [] = return env go env ((old_bndr, new_bndr, rhs) : pairs) - = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs + = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs ; go env' pairs } \end{code} @@ -284,18 +282,17 @@ It assumes the binder has already been simplified, but not its IdInfo. \begin{code} simplRecOrTopPair :: SimplEnv - -> TopLevelFlag + -> TopLevelFlag -> RecFlag -> InId -> OutBndr -> InExpr -- Binder and rhs -> SimplM SimplEnv -- Returns an env that includes the binding -simplRecOrTopPair env top_lvl old_bndr new_bndr rhs +simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs | preInlineUnconditionally env top_lvl old_bndr rhs -- Check for unconditional inline = do { tick (PreInlineUnconditionally old_bndr) ; return (extendIdSubst env old_bndr (mkContEx env rhs)) } | otherwise - = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env - -- May not actually be recursive, but it doesn't matter + = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env \end{code} @@ -629,21 +626,41 @@ completeBind :: SimplEnv -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs - = do { let old_info = idInfo old_bndr - old_unf = unfoldingInfo old_info - occ_info = occInfo old_info + = ASSERT( isId new_bndr ) + do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info - ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in SimplUtils + ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs - ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding + -- Simplify the unfolding + ; 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 - then do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $ - return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + then do { tick (PostInlineUnconditionally old_bndr) + ; -- pprTrace "postInlineUnconditionally" + -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $ + return (extendIdSubst env old_bndr (DoneEx final_rhs)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding + else + do { let info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unfolding - else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) } + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 + | otherwise = info2 + + final_id = new_bndr `setIdInfo` info3 + + ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + return (addNonRec env final_id final_rhs) } } + -- The addNonRec adds it to the in-scope set too ------------------------------ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv @@ -659,60 +676,33 @@ 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 - ; return (addNonRecWithUnf env poly_id rhs unfolding) } + ; let final_id = setIdInfo poly_id $ + idInfo poly_id `setUnfoldingInfo` unfolding + `setArityInfo` exprArity rhs -addPolyBind _ env bind@(Rec _) = return (extendFloats env bind) - -- Hack: letrecs are more awkward, so we extend "by steam" - -- without adding unfoldings etc. At worst this leads to - -- more simplifier iterations + ; return (addNonRec env final_id rhs) } ------------------------------- -addNonRecWithUnf :: SimplEnv - -> OutId -> OutExpr -- New binder and RHS - -> Unfolding -- New unfolding - -> SimplEnv -addNonRecWithUnf env new_bndr new_rhs new_unfolding - = let new_arity = exprArity new_rhs - old_arity = idArity new_bndr - info1 = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info: Note [Setting the new unfolding] - info2 = info1 `setUnfoldingInfo` new_unfolding - - -- Demand info: Note [Setting the demand info] - info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 - | otherwise = info2 - - final_id = new_bndr `setIdInfo` info3 - dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr - in - ASSERT( isId new_bndr ) - WARN( new_arity < old_arity || new_arity < dmd_arity, - (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity - <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) ) - -- Note [Arity decrease] - - final_id `seq` -- This seq forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ - addNonRec env final_id new_rhs - -- The addNonRec adds it to the in-scope set too +addPolyBind _ env bind@(Rec _) + = return (extendFloats env bind) + -- Hack: letrecs are more awkward, so we extend "by steam" + -- without adding unfoldings etc. At worst this leads to + -- more simplifier iterations ------------------------------ 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 @@ -720,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* @@ -882,22 +882,26 @@ simplExprF' env (App fun arg) cont = simplExprF env fun $ ApplyTo NoDup arg env cont simplExprF' env expr@(Lam _ _) cont - = simplLam env (map zap bndrs) body cont + = simplLam env zapped_bndrs body cont -- The main issue here is under-saturated lambdas -- (\x1. \x2. e) arg1 -- Here x1 might have "occurs-once" occ-info, because occ-info -- is computed assuming that a group of lambdas is applied -- all at once. If there are too few args, we must zap the - -- occ-info. + -- occ-info, UNLESS the remaining binders are one-shot where - n_args = countArgs cont - n_params = length bndrs (bndrs, body) = collectBinders expr - zap | n_args >= n_params = \b -> b - | otherwise = \b -> if isTyCoVar b then b - else zapLamIdInfo b - -- NB: we count all the args incl type args - -- so we must count all the binders (incl type lambdas) + zapped_bndrs | need_to_zap = map zap bndrs + | otherwise = bndrs + + need_to_zap = any zappable_bndr (drop n_args bndrs) + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyCoVar b = b + | otherwise = zapLamIdInfo b simplExprF' env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) @@ -905,7 +909,7 @@ simplExprF' env (Type ty) cont ; rebuild env (Type ty') cont } simplExprF' env (Case scrut bndr _ alts) cont - | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) + | sm_case_case (getMode env) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -957,9 +961,8 @@ simplCoercion env co rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -- At this point the substitution in the SimplEnv should be irrelevant -- only the in-scope set and floats should matter -rebuild env expr cont0 - = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $ - case cont0 of +rebuild env expr cont + = case cont of Stop {} -> return (env, expr) CoerceIt co cont -> rebuild env (mkCoerce co expr) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont @@ -1057,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) @@ -1066,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 @@ -1359,7 +1380,7 @@ tryRules env rules fn args call_cont ; case activeRule dflags env of { Nothing -> return Nothing ; -- No rules apply Just act_fn -> - case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of { + case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> @@ -1368,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 @@ -1448,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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1512,7 +1545,7 @@ rebuildCase env scrut case_bndr alts cont Nothing -> missingAlt env case_bndr alts cont Just (_, bs, rhs) -> simple_rhs bs rhs } - | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut + | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut -- Works when the scrutinee is a variable with a known unfolding -- as well as when it's an explicit constructor application = do { tick (KnownBranch case_bndr) @@ -1540,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,