Commit 3f44fb82 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Zap dead-ness info appropriately in SpecConstr

SpecConstr can make pattern binders come alive, so we must remember
to zap their dead-variable annotation.  See extendCaseBndrs.

(This was triggering a Core Lint failure in DPH.)
parent a7eb3064
......@@ -27,8 +27,7 @@ import DataCon ( dataConRepArity, dataConUnivTyVars )
import Coercion
import Rules
import Type hiding( substTy )
import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
import Id
import Var
import VarEnv
import VarSet
......@@ -591,17 +590,28 @@ 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 -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
-- When we encounter
-- case scrut of b
-- C x y -> ...
-- we want to bind b, and perhaps scrut too, to (C x y)
-- NB: Extends only the sc_vals part of the envt
extendCaseBndrs env scrut case_bndr con alt_bndrs
= case scrut of
Var v -> extendValEnv env1 v cval
_other -> env1
-- we want to bind b, to (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
where
zap v | isTyVar v = v -- See NB2 above
| otherwise = zapIdOccInfo v
env1 = extendValEnv env case_bndr cval
cval = case con of
DEFAULT -> Nothing
......@@ -788,15 +798,15 @@ 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, bs') = extendBndrsWith RecArg env bs
env2 = extendCaseBndrs env1 scrut' b' con bs'
sc_alt env _scrut' b' (con,bs,rhs)
= do { let (env1, bs1) = extendBndrsWith RecArg env bs
(env2, bs2) = extendCaseBndrs env1 b' con bs1
; (usg,rhs') <- scExpr env2 rhs
; let (usg', arg_occs) = lookupOccs usg bs'
; let (usg', arg_occs) = lookupOccs usg bs2
scrut_occ = case con of
DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
_ -> ScrutOcc emptyUFM
; return (usg', scrut_occ, (con,bs',rhs')) }
; return (usg', scrut_occ, (con, bs2, rhs')) }
scExpr' env (Let (NonRec bndr rhs) body)
| isTyVar bndr -- Type-lets may be created by doBeta
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment