From 70ad6e6ad6e2b27ccafc5e8af3b22b22d746e614 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 31 Jan 2011 11:35:29 +0000 Subject: [PATCH] Improve Simplifier and SpecConstr behaviour Trac #4908 identified a case where SpecConstr wasn't "seeing" a specialisation it should easily get. The solution was simple: see Note [Add scrutinee to ValueEnv too] in SpecConstr. Then it turned out that there was an exactly analogous infelicity in the mighty Simplifer too; see Note [Add unfolding for scrutinee] in Simplify. This fix is good for Simplify even in the absence of the SpecConstr change. (It arose when I moved the binder- swap stuff to OccAnall, not realising that it *remains* valuable to record info about the scrutinee of a case expression. The Note says why. Together these two changes are unconditionally good. Better simplification, better specialisation. Thank you Max. --- compiler/simplCore/Simplify.lhs | 95 +++++++++++++++++++++--------------- compiler/specialise/SpecConstr.lhs | 57 +++++++++++++++------- 2 files changed, 96 insertions(+), 56 deletions(-) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 6fe24df..6794e19 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 @@ -1682,16 +1682,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 +1698,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 +1755,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 +1780,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 +1814,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 +1838,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 +1850,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' + keep_occ_info = isDeadBinder case_bndr' && isNothing scrut -addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv -addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) - -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 +1926,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' @@ -2040,7 +2059,7 @@ mkDupableCont env (Select _ case_bndr alts se cont) ; 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 diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 3c84d3a..3388bb4 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -736,7 +736,7 @@ extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _ Nothing = env extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv } -extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var]) +extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) -- When we encounter -- case scrut of b -- C x y -> ... @@ -744,21 +744,20 @@ extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var]) -- NB1: Extends only the sc_vals part of the envt -- NB2: Kill the dead-ness info on the pattern binders x,y, since -- they are potentially made alive by the [b -> C x y] binding -extendCaseBndrs env case_bndr con alt_bndrs - | isDeadBinder case_bndr - = (env, alt_bndrs) - | otherwise - = (env1, map zap alt_bndrs) - -- NB: We used to bind v too, if scrut = (Var v); but - -- the simplifer has already done this so it seems - -- redundant to do so here - -- case scrut of - -- Var v -> extendValEnv env1 v cval - -- _other -> env1 +extendCaseBndrs env scrut case_bndr con alt_bndrs + = (env2, alt_bndrs') where - zap v | isTyCoVar v = v -- See NB2 above - | otherwise = zapIdOccInfo v - env1 = extendValEnv env case_bndr cval + live_case_bndr = not (isDeadBinder case_bndr) + env1 | Var v <- scrut = extendValEnv env v cval + | otherwise = env -- See Note [Add scrutinee to ValueEnv too] + env2 | live_case_bndr = extendValEnv env case_bndr cval + | otherwise = env1 + + alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr } + = map zap alt_bndrs + | otherwise + = alt_bndrs + cval = case con of DEFAULT -> Nothing LitAlt {} -> Just (ConVal con []) @@ -767,6 +766,9 @@ extendCaseBndrs env case_bndr con alt_bndrs vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ varsToCoreExprs alt_bndrs + zap v | isTyCoVar v = v -- See NB2 above + | otherwise = zapIdOccInfo v + decreaseSpecCount :: ScEnv -> Int -> ScEnv -- See Note [Avoiding exponential blowup] @@ -821,6 +823,25 @@ forceSpecArgTy _ _ = False #endif /* GHCI */ \end{code} +Note [Add scrutinee to ValueEnv too] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +By the time we get to the call (f y), the ValueEnv +will have a binding for y, and for c + y -> (a,b) + c -> I# v +BUT that's not enough! Looking at the call (f y) we +see that y is pair (a,b), but we also need to know what 'b' is. +So in extendCaseBndrs we must *also* add the binding + b -> I# v +else we lose a useful specialisation for f. This is necessary even +though the simplifier has systematically replaced uses of 'x' with 'y' +and 'b' with 'c' in the code. The use of 'b' in the ValueEnv came +from outside the case. See Trac #4908 for the live example. + Note [Avoiding exponential blowup] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The sc_count field of the ScEnv says how many times we are prepared to @@ -1020,9 +1041,9 @@ scExpr' env (Case scrut b ty alts) ; return (alt_usg `combineUsage` scrut_usg', Case scrut' b' (scSubstTy env ty) alts') } - sc_alt env _scrut' b' (con,bs,rhs) - = do { let (env1, bs1) = extendBndrsWith RecArg env bs - (env2, bs2) = extendCaseBndrs env1 b' con bs1 + sc_alt env scrut' b' (con,bs,rhs) + = do { let (env1, bs1) = extendBndrsWith RecArg env bs + (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 ; (usg,rhs') <- scExpr env2 rhs ; let (usg', arg_occs) = lookupOccs usg bs2 scrut_occ = case con of -- 1.7.10.4