X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=db84c90fc217c7a1fe0ed665a4d2ca5ddcee9083;hp=6fe24df49ea88943fefc65a5c07c5fc3cb03f4f7;hb=b187c221cc97679e28118ae8ac2997d6a686ba14;hpb=d056dfedcf9c7e5e58031ad5948c480f9cdca16f diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 6fe24df..db84c90 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -38,7 +38,7 @@ import CostCentre ( currentCCS, pushCCisNop ) import TysPrim ( realWorldStatePrimTy ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM ) -import Maybes ( orElse ) +import Maybes ( orElse, isNothing ) import Data.List ( mapAccumL ) import Outputable import FastString @@ -1237,10 +1237,10 @@ completeCall env var cont | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then - pprTrace "Inlining done:" (ppr var) stuff + pprDefiniteTrace "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff @@ -1391,11 +1391,12 @@ tryRules env rules fn args call_cont trace_dump dflags rule rule_rhs stuff | 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) + = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff - = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff | otherwise - = pprTrace "Rule fired" + = pprDefiniteTrace "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), text "After: " <+> pprCoreExpr rule_rhs, @@ -1682,16 +1683,6 @@ the case binder is guaranteed dead. In practice, the scrutinee is almost always a variable, so we pretty much always zap the OccInfo of the binders. It doesn't matter much though. - -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (v `cast` co) of x { I# y -> - ... (case (v `cast` co) of {...}) ... -We'd like to eliminate the inner case. We can get this neatly by -arranging that inside the outer case we add the unfolding - v |-> x `cast` (sym co) -to v. Then we should inline v at the inner case, cancel the casts, and away we go - Note [Improving seq] ~~~~~~~~~~~~~~~~~~~ Consider @@ -1708,7 +1699,7 @@ where x::F Int. Then we'd like to rewrite (F Int) to Int, getting so that 'rhs' can take advantage of the form of x'. -Notice that Note [Case of cast] may then apply to the result. +Notice that Note [Case of cast] (in OccurAnal) may then apply to the result. Nota Bene: We only do the [Improving seq] transformation if the case binder 'x' is actually used in the rhs; that is, if the case @@ -1765,7 +1756,9 @@ simplAlts env scrut case_bndr alts cont' ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts - ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts + ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing } + ; alts' <- mapM (simplAlt alt_env' mb_var_scrut + imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } @@ -1788,27 +1781,30 @@ improveSeq _ env scrut _ case_bndr1 _ ------------------------------------ simplAlt :: SimplEnv - -> [AltCon] -- These constructors can't be present when - -- matching the DEFAULT alternative - -> OutId -- The case binder + -> Maybe OutId -- Scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder -> SimplCont -> InAlt -> SimplM OutAlt -simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) +simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) = ASSERT( null bndrs ) - do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons + do { let env' = addBinderUnfolding env scrut case_bndr' + (mkOtherCon imposs_deflt_cons) -- Record the constructors that the case-binder *can't* be. ; rhs' <- simplExprC env' rhs cont' ; return (DEFAULT, [], rhs') } -simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs) +simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs) = ASSERT( null bndrs ) - do { let env' = addBinderUnfolding env case_bndr' (Lit lit) + do { let env' = addBinderUnfolding env scrut case_bndr' + (mkSimpleUnfolding (Lit lit)) ; rhs' <- simplExprC env' rhs cont' ; return (LitAlt lit, [], rhs') } -simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) +simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs) = do { -- Deal with the pattern-bound variables -- Mark the ones that are in ! positions in the -- data constructor as certainly-evaluated. @@ -1819,8 +1815,8 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) -- Bind the case-binder to (con args) ; let inst_tys' = tyConAppArgs (idType case_bndr') con_args = map Type inst_tys' ++ varsToCoreExprs vs' - env'' = addBinderUnfolding env' case_bndr' - (mkConApp con con_args) + unf = mkSimpleUnfolding (mkConApp con con_args) + env'' = addBinderUnfolding env' scrut case_bndr' unf ; rhs' <- simplExprC env'' rhs cont' ; return (DataAlt con, vs', rhs') } @@ -1843,7 +1839,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) | isMarkedStrict str = evald_v : go vs' strs | otherwise = zapped_v : go vs' strs where - zapped_v = zap_occ_info v + zapped_v = zapBndrOccInfo keep_occ_info v evald_v = zapped_v `setIdUnfolding` evaldUnfolding go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs) @@ -1855,25 +1851,49 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... } -- ==> case e of t { (a,b) -> ...(a)... } -- Look, Ma, a is alive now. - zap_occ_info = zapCasePatIdOcc case_bndr' - -addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv -addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) + keep_occ_info = isDeadBinder case_bndr' && isNothing scrut -addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv -addBinderOtherCon env bndr cons - = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons) +addBinderUnfolding :: SimplEnv -> Maybe OutId -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env scrut bndr unf + = case scrut of + Just v -> modifyInScope env1 (v `setIdUnfolding` unf) + _ -> env1 + where + env1 = modifyInScope env bndr_w_unf + bndr_w_unf = bndr `setIdUnfolding` unf -zapCasePatIdOcc :: Id -> Id -> Id +zapBndrOccInfo :: Bool -> Id -> Id -- Consider case e of b { (a,b) -> ... } -- Then if we bind b to (a,b) in "...", and b is not dead, -- then we must zap the deadness info on a,b -zapCasePatIdOcc case_bndr - | isDeadBinder case_bndr = \ pat_id -> pat_id - | otherwise = \ pat_id -> zapIdOccInfo pat_id +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id \end{code} +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccAnal has got rid of all such occcurrences +See Note [Binder swap] in OccAnal. + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimintation -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +Exactly the same issue arises in SpecConstr; +see Note [Add scrutinee to ValueEnv too] in SpecConstr %************************************************************************ %* * @@ -1907,7 +1927,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont ; env'' <- bind_case_bndr env' ; simplExprF env'' rhs cont } where - zap_occ = zapCasePatIdOcc bndr -- bndr is an InId + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId -- Ugh! bind_args env' [] _ = return env' @@ -1973,16 +1993,44 @@ missingAlt env case_bndr alts cont \begin{code} prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (SimplEnv, SimplCont,SimplCont) - -- Return a duplicatable continuation, a non-duplicable part - -- plus some extra bindings (that scope over the entire - -- continunation) - - -- No need to make it duplicatable if there's only one alternative -prepareCaseCont env [_] cont = return (env, cont, mkBoringStop) -prepareCaseCont env _ cont = mkDupableCont env cont + -> SimplM (SimplEnv, SimplCont, SimplCont) +-- We are considering +-- K[case _ of { p1 -> r1; ...; pn -> rn }] +-- where K is some enclosing continuation for the case +-- Goal: split K into two pieces Kdup,Knodup so that +-- a) Kdup can be duplicated +-- b) Knodup[Kdup[e]] = K[e] +-- The idea is that we'll transform thus: +-- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] } +-- +-- We also return some extra bindings in SimplEnv (that scope over +-- the entire continuation) + +prepareCaseCont env alts cont + | many_alts alts = mkDupableCont env cont + | otherwise = return (env, cont, mkBoringStop) + where + many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative + many_alts [] = False -- See Note [Bottom alternatives] + many_alts [_] = False + many_alts (alt:alts) + | is_bot_alt alt = many_alts alts + | otherwise = not (all is_bot_alt alts) + + is_bot_alt (_,_,rhs) = exprIsBottom rhs \end{code} +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away; and in some cases we would +not even create the join points (see Note [Single-alternative case]) +and we would keep the case-of-case which is silly. See Trac #4930. + \begin{code} mkDupableCont :: SimplEnv -> SimplCont -> SimplM (SimplEnv, SimplCont, SimplCont) @@ -2033,14 +2081,17 @@ mkDupableCont env (Select _ case_bndr alts se cont) -- let ji = \xij -> ei -- in case [...hole...] of { pi -> ji xij } do { tick (CaseOfCase case_bndr) - ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont - -- NB: call mkDupableCont here, *not* prepareCaseCont - -- We must make a duplicable continuation, whereas prepareCaseCont - -- doesn't when there is a single case branch + ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont + -- NB: We call prepareCaseCont here. If there is only one + -- alternative, then dup_cont may be big, but that's ok + -- becuase we push it into the single alternative, and then + -- use mkDupableAlt to turn that simplified alternative into + -- a join point if it's too big to duplicate. + -- And this is important: see Note [Fusing case continuations] ; let alt_env = se `setInScope` env' ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr - ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts -- Safe to say that there are no handled-cons for the DEFAULT case -- NB: simplBinder does not zap deadness occ-info, so -- a dead case_bndr' will still advertise its deadness @@ -2128,6 +2179,37 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') -- See Note [Duplicated env] \end{code} +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StricgtBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See Trac #4957 a fuller example. + Note [Case binders and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this @@ -2309,9 +2391,6 @@ Note [Duplicating StrictBind] Unlike StrictArg, there doesn't seem anything to gain from duplicating a StrictBind continuation, so we don't. -The desire not to duplicate is the entire reason that -mkDupableCont returns a pair of continuations. - Note [Single-alternative cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2381,8 +2460,7 @@ Note [Single-alternative-unlifted] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here's another single-alternative where we really want to do case-of-case: -data Mk1 = Mk1 Int# -data Mk1 = Mk2 Int# +data Mk1 = Mk1 Int# | Mk2 Int# M1.f = \r [x_s74 y_s6X] @@ -2407,7 +2485,15 @@ M1.f = So the outer case is doing *nothing at all*, other than serving as a join-point. In this case we really want to do case-of-case and decide -whether to use a real join point or just duplicate the continuation. +whether to use a real join point or just duplicate the continuation: + + let $j s7c = case x of + Mk1 ipv77 -> (==) s7c ipv77 + Mk1 ipv79 -> (==) s7c ipv79 + in + case y of + Mk1 ipv70 -> $j ipv70 + Mk2 ipv72 -> $j ipv72 Hence: check whether the case binder's type is unlifted, because then the outer case is *not* a seq.