import CoreTidy ( tidyRules )
import PprCore ( pprRules )
import WwLib ( mkWorkerArgs )
-import DataCon ( dataConRepArity, isVanillaDataCon )
+import DataCon ( dataConRepArity, isVanillaDataCon, dataConTyVars )
import Type ( tyConAppArgs, tyVarsOfTypes )
import Rules ( matchN )
import Unify ( coreRefineTys )
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"
-- 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 -> ...
data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
| UnkOcc -- Used in some unknown way
- | ScrutOcc (UniqFM [ArgOcc]) -- Only taken apart or applied
- -- ScrutOcc emptyUFM for functions, literals
- -- ScrutOcc subs for data constructors;
- -- the [ArgOcc] gives usage of the *value* components,
- -- The domain of the UniqFM is the Unique of the data constructor
+ | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
| BothOcc -- Definitely taken apart, *and* perhaps used in some other way
+{- Note [ScrutOcc]
+
+An occurrence of ScrutOcc indicates that the thing is *only* taken apart or applied.
+
+ Functions, litersl: ScrutOcc emptyUFM
+ Data constructors: ScrutOcc subs,
+
+where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
+The domain of the UniqFM is the Unique of the data constructor
+
+The [ArgOcc] is the occurrences of the *pattern-bound* components
+of the data structure. E.g.
+ data T a = forall b. MkT a b (b->a)
+A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
+
+-}
instance Outputable ArgOcc where
ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <+> ppr xs
combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
-subOccs :: ArgOcc -> AltCon -> [ArgOcc]
+conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
-- Find usage of components of data con; returns [UnkOcc...] if unknown
-subOccs (ScrutOcc fm) (DataAlt dc) = lookupUFM fm dc `orElse` repeat UnkOcc
-subOccs other dc = repeat UnkOcc
+-- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
+
+conArgOccs (ScrutOcc fm) (DataAlt dc)
+ | Just pat_arg_occs <- lookupUFM fm dc
+ = tyvar_unks ++ pat_arg_occs
+ where
+ tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConTyVars dc]
+ | otherwise = []
+
+conArgOccs other con = repeat UnkOcc
\end{code}
App {} -> True -- ...and elsewhere...
other -> False
other -> False -- No point; the arg is not decomposed
- = do { args' <- argsToPats in_scope con_env (args `zip` subOccs arg_occ dc)
+ = do { args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
; return (True, mk_con_app dc (map snd args')) }
argToPat in_scope con_env arg arg_occ
projects / ghc-hetmet.git / blobdiff