Commit a174d117 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Refactoring, plus record recursive-function *components* as RecArg too

parent 5338fea3
......@@ -437,16 +437,16 @@ refineConstrEnv subst env = mapVarEnv refine_con_value env
emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
data HowBound = RecFun -- These are the recursive functions for which
-- we seek interesting call patterns
data HowBound = RecFun -- These are the recursive functions for which
-- we seek interesting call patterns
| RecArg -- These are those functions' arguments; we are
-- interested to see if those arguments are scrutinised
| RecArg -- These are those functions' arguments, or their sub-components;
-- we gather occurrence information for these
| Other -- We track all others so we know what's in scope
-- This is used in spec_one to check what needs to be
-- passed as a parameter and what is in scope at the
-- function definition site
| Other -- We track all others so we know what's in scope
-- This is used in spec_one to check what needs to be
-- passed as a parameter and what is in scope at the
-- function definition site
instance Outputable HowBound where
ppr RecFun = text "RecFun"
......@@ -463,51 +463,56 @@ extendBndr env bndr = env { scope = extendVarEnv (scope env) bndr Other }
-- C x y -> ...
-- we want to bind b, and perhaps scrut too, to (C x y)
extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
= extendBndrs env (case_bndr : alt_bndrs)
extendCaseBndrs env case_bndr scrut con@(LitAlt lit) alt_bndrs
= ASSERT( null alt_bndrs ) extendAlt env case_bndr scrut (CV con []) []
extendCaseBndrs env case_bndr scrut con@(DataAlt data_con) alt_bndrs
| isVanillaDataCon data_con
= extendAlt env case_bndr scrut (CV con vanilla_args) alt_bndrs
| otherwise -- GADT
= extendAlt env1 case_bndr scrut (CV con gadt_args) alt_bndrs
extendCaseBndrs env case_bndr scrut con alt_bndrs
= case con of
DEFAULT -> env1
LitAlt lit -> extendCons env1 scrut case_bndr (CV con [])
DataAlt dc -> extend_data_con dc
where
vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
map varToCoreExpr alt_bndrs
gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
-- This call generates some bogus warnings from substExpr,
-- because it's inconvenient to put all the Ids in scope
-- Will be fixed when we move to FC
(alt_tvs, _) = span isTyVar alt_bndrs
Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
subst = mkSubst in_scope tv_subst emptyVarEnv -- No Id substitition
in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
env1 | is_local = env
| otherwise = env { cons = refineConstrEnv subst (cons env) }
cur_scope = scope env
env1 = env { scope = extendVarEnvList cur_scope
[(b,how_bound) | b <- case_bndr:alt_bndrs] }
-- Record RecArg for the components iff the scrutinee is RecArg
-- [This comment looks plain wrong to me, so I'm ignoring it
-- "Also forget if the scrutinee is a RecArg, because we're
-- now in the branch of a case, and we don't want to
-- record a non-scrutinee use of v if we have
-- case v of { (a,b) -> ...(f v)... }" ]
how_bound = case scrut of
Var v -> lookupVarEnv cur_scope v `orElse` Other
other -> Other
extend_data_con data_con
| isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args)
| otherwise = extendCons env2 scrut case_bndr (CV con gadt_args)
-- Note env2 for GADTs
where
vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
map varToCoreExpr alt_bndrs
gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
-- This call generates some bogus warnings from substExpr,
-- because it's inconvenient to put all the Ids in scope
-- Will be fixed when we move to FC
(alt_tvs, _) = span isTyVar alt_bndrs
Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
subst = mkSubst in_scope tv_subst emptyVarEnv -- No Id substitition
in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
env2 | is_local = env1
| otherwise = env1 { cons = refineConstrEnv subst (cons env) }
extendAlt :: ScEnv -> Id -> CoreExpr -> ConValue -> [Var] -> ScEnv
extendAlt env case_bndr scrut val alt_bndrs
= let
env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
cons = extendVarEnv (cons env) case_bndr val }
in
case scrut of
Var v -> -- Bind the scrutinee in the ConstrEnv if it's a variable
-- Also forget if the scrutinee is a RecArg, because we're
-- now in the branch of a case, and we don't want to
-- record a non-scrutinee use of v if we have
-- case v of { (a,b) -> ...(f v)... }
SCE { scope = extendVarEnv (scope env1) v Other,
cons = extendVarEnv (cons env1) v val }
other -> env1
extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
extendCons env scrut case_bndr val
= case scrut of
Var v -> env { cons = extendVarEnv cons1 v val }
other -> env { cons = cons1 }
where
cons1 = extendVarEnv (cons env) case_bndr val
-- When we encounter a recursive function binding
-- f = \x y -> ...
......
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