X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=1ee5935fa024c57f119b0de7d699aeb6f8c49954;hb=27ca67931713c36f5ed248de88298416892e5649;hp=cc020961f2911045c6ce44bc09a45de552702fbc;hpb=a174d117a539dc1e4bbb6f9bef63851f6985611f;p=ghc-hetmet.git diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index cc02096..1ee5935 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -18,10 +18,10 @@ import CoreSubst ( Subst, mkSubst, substExpr ) import CoreTidy ( tidyRules ) import PprCore ( pprRules ) import WwLib ( mkWorkerArgs ) -import DataCon ( dataConRepArity, isVanillaDataCon, dataConTyVars ) -import Type ( tyConAppArgs, tyVarsOfTypes ) +import DataCon ( dataConRepArity, isVanillaDataCon, + dataConUnivTyVars ) +import Type ( Type, tyConAppArgs, tyVarsOfTypes ) import Rules ( matchN ) -import Unify ( coreRefineTys ) import Id ( Id, idName, idType, isDataConWorkId_maybe, mkUserLocal, mkSysLocal, idUnfolding, isLocalId ) import Var ( Var ) @@ -483,28 +483,11 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs 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 + extend_data_con data_con = + extendCons env1 scrut case_bndr (CV con vanilla_args) 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) } - + varsToCoreExprs alt_bndrs extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv extendCons env scrut case_bndr val @@ -588,7 +571,7 @@ 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 + ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> parens (ppr xs) ppr UnkOcc = ptext SLIT("unk-occ") ppr BothOcc = ptext SLIT("both-occ") ppr NoOcc = ptext SLIT("no-occ") @@ -610,7 +593,7 @@ 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] + tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConUnivTyVars dc] | otherwise = [] conArgOccs other con = repeat UnkOcc @@ -636,6 +619,8 @@ scExpr env e@(Lit l) = returnUs (nullUsage, e) scExpr env e@(Var v) = returnUs (varUsage env v UnkOcc, e) scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') -> returnUs (usg, Note n e') +scExpr env (Cast e co)= scExpr env e `thenUs` \ (usg,e') -> + returnUs (usg, Cast e' co) scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') -> returnUs (usg, Lam b e') @@ -864,23 +849,6 @@ specConstrActivation = ActiveAfter 0 -- Baked in; see comments above This code deals with analysing call-site arguments to see whether they are constructor applications. ---------------------- -good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool --- See Note [Good arguments] above -good_arg con_env arg_occs (bndr, arg) - = case is_con_app_maybe con_env arg of - Just _ -> bndr_usg_ok arg_occs bndr arg - other -> False - -bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool -bndr_usg_ok arg_occs bndr arg - = case lookupVarEnv arg_occs bndr of - Just ScrutOcc -> True -- Used only by case scrutiny - Just Both -> case arg of -- Used by case and elsewhere - App _ _ -> True -- so the arg should be an explicit con app - other -> False - other -> False -- Not used, or used wonkily - \begin{code} -- argToPat takes an actual argument, and returns an abstracted @@ -907,10 +875,17 @@ argToPat :: InScopeEnv -- What's in scope at the fn defn site argToPat in_scope con_env arg@(Type ty) arg_occ = return (False, arg) -argToPat in_scope con_env (Var v) arg_occ -- Don't uniqify existing vars, - = return (interesting, Var v) -- so that we can spot when we pass them twice - where - interesting = not (isLocalId v) || v `elemVarEnv` in_scope +argToPat in_scope con_env (Var v) arg_occ + | not (isLocalId v) || v `elemVarEnv` in_scope + = -- The recursive call passes a variable that + -- is in scope at the function definition site + -- It's worth specialising on this if + -- (a) it's used in an interesting way in the body + -- (b) we know what its value is + if (case arg_occ of { UnkOcc -> False; other -> True }) -- (a) + && isValueUnfolding (idUnfolding v) -- (b) + then return (True, Var v) + else wildCardPat (idType v) argToPat in_scope con_env arg arg_occ | is_value_lam arg @@ -932,10 +907,20 @@ argToPat in_scope con_env arg arg_occ = 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 - = do { uniq <- getUniqueUs - ; let id = mkSysLocal FSLIT("sc") uniq (exprType arg) - ; return (False, Var id) } +argToPat in_scope con_env (Var v) arg_occ + = -- A variable bound inside the function. + -- Don't make a wild-card, because we may usefully share + -- e.g. f a = let x = ... in f (x,x) + -- NB: this case follows the lambda and con-app cases!! + return (False, Var v) + +-- The default case: make a wild-card +argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg) + +wildCardPat :: Type -> UniqSM (Bool, CoreArg) +wildCardPat ty = do { uniq <- getUniqueUs + ; let id = mkSysLocal FSLIT("sc") uniq ty + ; return (False, Var id) } argsToPats :: InScopeEnv -> ConstrEnv -> [(CoreArg, ArgOcc)]