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
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
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
; (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') }
------------------------------------
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.
-- 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') }
| 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)
-- 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
%************************************************************************
%* *
; 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'
; 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
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 -> ...
-- 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 [])
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]
#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
; 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
projects / ghc-hetmet.git / commitdiff