X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=72227034bb2ea08b4e3dd3ae796671b2b394f899;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hp=379fce155509bb9633067c023e9f82b7dafe7a0e;hpb=c76348fc03f302ffd8201b912eef4724b3fa60a4;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 379fce1..7222703 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -24,16 +24,16 @@ 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 CoreUtils import qualified CoreSubst -import CoreArity ( exprArity ) +import CoreArity import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) import CostCentre ( currentCCS, pushCCisNop ) @@ -237,7 +237,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 +272,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 +284,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} @@ -322,7 +321,8 @@ simplLazyBind :: SimplEnv -> SimplM SimplEnv simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = do { let rhs_env = rhs_se `setInScope` env + = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let rhs_env = rhs_se `setInScope` env (tvs, body) = case collectTyBinders rhs of (tvs, body) | not_lam body -> (tvs,body) | otherwise -> ([], rhs) @@ -387,7 +387,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs - ; (env2, rhs2) <- + ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet ; return (addFloats env env1, rhs1) } -- Add the floats to the main env @@ -547,7 +547,7 @@ makeTrivialWithInfo top_lvl env info expr = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "a") var = mkLocalIdWithInfo name expr_ty info - ; env' <- completeNonRecX top_lvl env False var var expr + ; env' <- completeNonRecX top_lvl env False var var expr ; expr' <- simplVar env' var ; return (env', expr') } -- The simplVar is needed becase we're constructing a new binding @@ -628,21 +628,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 occ_info 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 + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 + | otherwise = info2 - else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) } + 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 @@ -661,44 +681,17 @@ addPolyBind top_lvl env (NonRec poly_id rhs) = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo 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 @@ -709,7 +702,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag 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 _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity @@ -717,15 +710,30 @@ simplUnfolding env top_lvl id _ _ | isStableSource src = do { expr' <- simplExpr rule_env expr ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src - ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } + 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') + -- 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 gently inside InlineRules] in SimplUtils + -- See Note [Simplifying inside InlineRules] in SimplUtils simplUnfolding _ top_lvl id _occ_info new_rhs _ - = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) 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 @@ -866,22 +874,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 ) @@ -889,17 +901,16 @@ 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) | otherwise = -- If case-of-case is off, simply simplify the case expression -- in a vanilla Stop context, and rebuild the result around it - do { case_expr' <- simplExprC env scrut case_cont + do { case_expr' <- simplExprC env scrut + (Select NoDup bndr alts env mkBoringStop) ; rebuild env case_expr' cont } - where - case_cont = Select NoDup bndr alts env mkBoringStop simplExprF' env (Let (Rec pairs) body) cont = do { env' <- simplRecBndrs env (map fst pairs) @@ -942,16 +953,17 @@ 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 StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr ; simplLam env' bs body cont } - ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg + ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] + | isSimplified dup_flag -> rebuild env (App expr arg) cont + | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg ; rebuild env (App expr arg') cont } \end{code} @@ -1089,7 +1101,8 @@ simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont | preInlineUnconditionally env NotTopLevel bndr rhs = do { tick (PreInlineUnconditionally bndr) - ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } | isStrictId bndr = do { simplExprF (rhs_se `setFloats` env) rhs @@ -1237,7 +1250,10 @@ rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) - (ApplyTo _ arg arg_se cont) + (ApplyTo dup_flag arg arg_se cont) + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addArgTo info' arg) cont + | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg @@ -1266,7 +1282,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) ; mb_rule <- tryRules env rules fun args cont ; case mb_rule of { Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $ - pushArgs env' (drop n_args args) cont ; + pushSimplifiedArgs env' (drop n_args args) cont ; -- n_args says how many args the rule consumed ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules } } @@ -1277,7 +1293,7 @@ Note [RULES apply to simplified arguments] It's very desirable to try RULES once the arguments have been simplified, because doing so ensures that rule cascades work in one pass. Consider {-# RULES g (h x) = k x - f (k x) = x #-} + f (k x) = x #-} ...f (g (h x))... Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If we match f's rules against the un-simplified RHS, it won't match. This @@ -1285,6 +1301,15 @@ makes a particularly big difference when superclass selectors are involved: op ($p1 ($p2 (df d))) We want all this to unravel in one sweeep. +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + Note [Shadowing] ~~~~~~~~~~~~~~~~ This part of the simplifier may break the no-shadowing invariant @@ -1329,7 +1354,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) -> @@ -1338,14 +1363,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 @@ -1418,6 +1444,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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1482,7 +1519,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) @@ -1510,28 +1547,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,