diff options
Diffstat (limited to 'compiler/specialise')
| -rw-r--r-- | compiler/specialise/Rules.lhs | 85 | ||||
| -rw-r--r-- | compiler/specialise/SpecConstr.lhs | 207 | ||||
| -rw-r--r-- | compiler/specialise/Specialise.lhs | 66 |
3 files changed, 269 insertions, 89 deletions
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 9c473e5a3a..b88888c96c 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -47,8 +47,8 @@ import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) import BasicTypes ( Activation, CompilerPhase, isActive ) -import DynFlags ( DynFlags ) import StaticFlags ( opt_PprStyle_Debug ) +import DynFlags ( DynFlags ) import Outputable import FastString import Maybes @@ -111,7 +111,7 @@ Note [Overall plumbing for rules] from HscEnv. [NB: we are inconsistent here. We should do the same for external - pacakges, but we don't. Same for type-class instances.] + packages, but we don't. Same for type-class instances.] * So in the outer simplifier loop, we combine (b-d) into a single RuleBase, reading @@ -351,16 +351,14 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. -lookupRule :: DynFlags - -> (Activation -> Bool) -- When rule is active - -> IdUnfoldingFun -- When Id can be unfolded - -> InScopeSet - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +lookupRule :: DynFlags -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -- See Note [Extra args in rule matching] -- See comments on matchRule -lookupRule dflags is_active id_unf in_scope fn args rules +lookupRule dflags in_scope is_active fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ case go [] rules of [] -> Nothing @@ -370,7 +368,7 @@ lookupRule dflags is_active id_unf in_scope fn args rules go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] go ms [] = ms - go ms (r:rs) = case (matchRule dflags fn is_active id_unf in_scope args rough_args r) of + go ms (r:rs) = case (matchRule dflags in_scope is_active fn args rough_args r) of Just e -> go ((r,e):ms) rs Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, unfoldingTemplate unf) @@ -418,7 +416,7 @@ isMoreSpecific (BuiltinRule {}) _ = False isMoreSpecific (Rule {}) (BuiltinRule {}) = True isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) (Rule { ru_bndrs = bndrs2, ru_args = args2 }) - = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1) + = isJust (matchN (in_scope, id_unfolding_fun) bndrs2 args2 args1) where id_unfolding_fun _ = NoUnfolding -- Don't expand in templates in_scope = mkInScopeSet (mkVarSet bndrs1) @@ -447,9 +445,8 @@ to lookupRule are the result of a lazy substitution \begin{code} ------------------------------------ -matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun - -> InScopeSet - -> [CoreExpr] -> [Maybe Name] +matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr -- If (matchRule rule args) returns Just (name,rhs) @@ -474,21 +471,21 @@ matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule dflags fn _is_active id_unf _in_scope args _rough_args +matchRule dflags rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems - = case match_fn dflags fn id_unf args of + = case match_fn dflags rule_env fn args of Just expr -> Just expr Nothing -> Nothing -matchRule _ _ is_active id_unf in_scope args rough_args - (Rule { ru_act = act, ru_rough = tpl_tops, - ru_bndrs = tpl_vars, ru_args = tpl_args, - ru_rhs = rhs }) +matchRule _ in_scope is_active _ args rough_args + (Rule { ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args + , ru_rhs = rhs }) | not (is_active act) = Nothing | ruleCantMatch tpl_tops rough_args = Nothing | otherwise - = case matchN id_unf in_scope tpl_vars tpl_args args of + = case matchN in_scope tpl_vars tpl_args args of Nothing -> Nothing Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ rule_fn `mkApps` tpl_vals) @@ -497,8 +494,7 @@ matchRule _ _ is_active id_unf in_scope args rough_args -- We could do this when putting things into the rulebase, I guess --------------------------------------- -matchN :: IdUnfoldingFun - -> InScopeSet -- ^ In-scope variables +matchN :: InScopeEnv -> [Var] -- ^ Match template type variables -> [CoreExpr] -- ^ Match template -> [CoreExpr] -- ^ Target; can have more elements than the template @@ -508,7 +504,7 @@ matchN :: IdUnfoldingFun -- the entire result and what should be substituted for each template variable. -- Fail if there are two few actual arguments from the target to match the template -matchN id_unf in_scope tmpl_vars tmpl_es target_es +matchN (in_scope, id_unf) tmpl_vars tmpl_es target_es = do { subst <- go init_menv emptyRuleSubst tmpl_es target_es ; return (rs_binds subst, map (lookup_tmpl subst) tmpl_vars') } @@ -572,14 +568,15 @@ necessary; the renamed ones are the tmpl_vars' -- * The BindWrapper in a RuleSubst are the bindings floated out -- from nested matches; see the Let case of match, below -- -data RuleEnv = RV { rv_tmpls :: VarSet -- Template variables - , rv_lcl :: RnEnv2 -- Renamings for *local bindings* - -- (lambda/case) - , rv_fltR :: Subst -- Renamings for floated let-bindings - -- domain disjoint from envR of rv_lcl - -- See Note [Matching lets] - , rv_unf :: IdUnfoldingFun - } +data RuleMatchEnv + = RV { rv_tmpls :: VarSet -- Template variables + , rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- domain disjoint from envR of rv_lcl + -- See Note [Matching lets] + , rv_unf :: IdUnfoldingFun + } data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the , rs_id_subst :: IdSubstEnv -- template variables @@ -604,7 +601,7 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv -- SLPJ July 99 -match :: RuleEnv +match :: RuleMatchEnv -> RuleSubst -> CoreExpr -- Template -> CoreExpr -- Target @@ -720,23 +717,24 @@ match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text Nothing ------------- -match_co :: RuleEnv +match_co :: RuleMatchEnv -> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst match_co renv subst (CoVarCo cv) co = match_var renv subst cv (Coercion co) -match_co renv subst (Refl ty1) co +match_co renv subst (Refl r1 ty1) co = case co of - Refl ty2 -> match_ty renv subst ty1 ty2 - _ -> Nothing + Refl r2 ty2 + | r1 == r2 -> match_ty renv subst ty1 ty2 + _ -> Nothing match_co _ _ co1 _ = pprTrace "match_co: needs more cases" (ppr co1) Nothing -- Currently just deals with CoVarCo and Refl ------------- -rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv +rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv rnMatchBndr2 renv subst x1 x2 = renv { rv_lcl = rnBndr2 rn_env x1 x2 , rv_fltR = delBndr (rv_fltR renv) x2 } @@ -746,7 +744,7 @@ rnMatchBndr2 renv subst x1 x2 -- there are some floated let-bindings ------------------------------------------ -match_alts :: RuleEnv +match_alts :: RuleMatchEnv -> RuleSubst -> [CoreAlt] -- Template -> [CoreAlt] -- Target @@ -772,7 +770,7 @@ okToFloat rn_env bind_fvs not_captured fv = not (inRnEnvR rn_env fv) ------------------------------------------ -match_var :: RuleEnv +match_var :: RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target @@ -801,7 +799,7 @@ match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) -- template x, so we must rename first! ------------------------------------------ -match_tmpl_var :: RuleEnv +match_tmpl_var :: RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target @@ -842,7 +840,7 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) -- because no free var of e2' is in the rnEnvR of the envt ------------------------------------------ -match_ty :: RuleEnv +match_ty :: RuleMatchEnv -> RuleSubst -> Type -- Template -> Type -- Target @@ -1096,7 +1094,8 @@ ruleAppCheck_help env fn args rules = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info dflags rule - | Just _ <- matchRule dflags fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule + | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule = text "matches (which is very peculiar!)" rule_info _ (BuiltinRule {}) = text "does not match" diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 16c368e5c5..a5df7d52bc 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -132,7 +132,7 @@ because now t is allocated by the caller, then r and s are passed to the recursive call, which allocates the (r,s) pair again. This happens if - (a) the argument p is used in other than a case-scrutinsation way. + (a) the argument p is used in other than a case-scrutinisation way. (b) the argument to the call is not a 'fresh' tuple; you have to look into its unfolding to see that it's a tuple @@ -394,6 +394,22 @@ use the calls in the un-specialised RHS as seeds. We call these "boring call patterns", and callsToPats reports if it finds any of these. +Note [Top-level recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If all the bindings in a top-level recursive group are not exported, +all the calls are in the rest of the top-level bindings. +This means we can specialise with those call patterns instead of with the RHSs +of the recursive group. + +To get the call usage information, we work backwards through the top-level bindings +so we see the usage before we get to the binding of the function. +Before we can collect the usage though, we go through all the bindings and add them +to the environment. This is necessary because usage is only tracked for functions +in the environment. + +The actual seeding of the specialisation is very similar to Note [Local recursive group]. + + Note [Do not specialise diverging functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Specialising a function that just diverges is a waste of code. @@ -402,7 +418,7 @@ Furthermore, it broke GHC (simpl014) thus: f = \x. case x of (a,b) -> f x If we specialise f we get f = \x. case x of (a,b) -> fspec a b -But fspec doesn't have decent strictnes info. As it happened, +But fspec doesn't have decent strictness info. As it happened, (f x) :: IO t, so the state hack applied and we eta expanded fspec, and hence f. But now f's strictness is less than its arity, which breaks an invariant. @@ -451,7 +467,7 @@ foldl_loop. Note that This is all quite ugly; we ought to come up with a better design. ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set -sc_force to True when calling specLoop. This flag does three things: +sc_force to True when calling specLoop. This flag does four things: * Ignore specConstrThreshold, to specialise functions of arbitrary size (see scTopBind) * Ignore specConstrCount, to make arbitrary numbers of specialisations @@ -459,7 +475,7 @@ sc_force to True when calling specLoop. This flag does three things: * Specialise even for arguments that are not scrutinised in the loop (see argToPat; Trac #4488) * Only specialise on recursive types a finite number of times - (see is_too_recursive; Trac #5550) + (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation]) This flag is inherited for nested non-recursive bindings (which are likely to be join points and hence should be fully specialised) but reset for nested @@ -507,6 +523,39 @@ Without the SPEC, if 'loop' were strict, the case would move out and we'd see loop applied to a pair. But if 'loop' isn't strict this doesn't look like a specialisable call. +Note [Limit recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible for ForceSpecConstr to cause an infinite loop of specialisation. +Because there is no limit on the number of specialisations, a recursive call with +a recursive constructor as an argument (for example, list cons) will generate +a specialisation for that constructor. If the resulting specialisation also +contains a recursive call with the constructor, this could proceed indefinitely. + +For example, if ForceSpecConstr is on: + loop :: [Int] -> [Int] -> [Int] + loop z [] = z + loop z (x:xs) = loop (x:z) xs +this example will create a specialisation for the pattern + loop (a:b) c = loop' a b c + + loop' a b [] = (a:b) + loop' a b (x:xs) = loop (x:(a:b)) xs +and a new pattern is found: + loop (a:(b:c)) d = loop'' a b c d +which can continue indefinitely. + +Roman's suggestion to fix this was to stop after a couple of times on recursive types, +but still specialising on non-recursive types as much as possible. + +To implement this, we count the number of recursive constructors in each +function argument. If the maximum is greater than the specConstrRecursive limit, +do not specialise on that pattern. + +This is only necessary when ForceSpecConstr is on: otherwise the specConstrCount +will force termination anyway. + +See Trac #5550. + Note [NoSpecConstr] ~~~~~~~~~~~~~~~~~~~ The ignoreDataCon stuff allows you to say @@ -605,13 +654,22 @@ specConstrProgram guts dflags <- getDynFlags us <- getUniqueSupplyM annos <- getFirstAnnotations deserializeWithData guts - let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts)) + let binds' = reverse $ fst $ initUs us $ do + -- Note [Top-level recursive groups] + (env, binds) <- goEnv (initScEnv dflags annos) (mg_binds guts) + go env nullUsage (reverse binds) + return (guts { mg_binds = binds' }) where - go _ [] = return [] - go env (bind:binds) = do (env', bind') <- scTopBind env bind - binds' <- go env' binds - return (bind' : binds') + goEnv env [] = return (env, []) + goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind + (env'', binds') <- goEnv env' binds + return (env'', bind' : binds') + + go _ _ [] = return [] + go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind + binds' <- go env usg' binds + return (bind' : binds') \end{code} @@ -621,6 +679,48 @@ specConstrProgram guts %* * %************************************************************************ +Note [Work-free values only in environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_vals field keeps track of in-scope value bindings, so +that if we come across (case x of Just y ->...) we can reduce the +case from knowing that x is bound to a pair. + +But only *work-free* values are ok here. For example if the envt had + x -> Just (expensive v) +then we do NOT want to expand to + let y = expensive v in ... +because the x-binding still exists and we've now duplicated (expensive v). + +This seldom happens because let-bound constructor applications are +ANF-ised, but it can happen as a result of on-the-fly transformations in +SpecConstr itself. Here is Trac #7865: + + let { + a'_shr = + case xs_af8 of _ { + [] -> acc_af6; + : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] -> + (expensive x_af7, x_af7 + } } in + let { + ds_sht = + case a'_shr of _ { (p'_afd, q'_afe) -> + TSpecConstr_DoubleInline.recursive + (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) + } } in + +When processed knowing that xs_af8 was bound to a cons, we simplify to + a'_shr = (expensive x_af7, x_af7) +and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. +(There are other occurrences of a'_shr.) No no no. + +It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned +into a work-free value again, thus + a1 = expensive x_af7 + a'_shr = (a1, x_af7) +but that's more work, so until its shown to be important I'm going to +leave it for now. + \begin{code} data ScEnv = SCE { sc_dflags :: DynFlags, sc_size :: Maybe Int, -- Size threshold @@ -643,6 +743,10 @@ data ScEnv = SCE { sc_dflags :: DynFlags, sc_vals :: ValueEnv, -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) + -- The range of the ValueEnv is *work-free* values + -- such as (\x. blah), or (Just v) + -- but NOT (Just (expensive v)) + -- See Note [Work-free values only in environment] sc_annotations :: UniqFM SpecConstrAnnotation } @@ -753,7 +857,10 @@ extendBndr env bndr = (env { sc_subst = subst' }, bndr') extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _ Nothing = env -extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv } +extendValEnv env id (Just cv) + | valueIsWorkFree cv -- Don't duplicate work!! Trac #7865 + = env { sc_vals = extendVarEnv (sc_vals env) id cv } +extendValEnv env _ _ = env extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) -- When we encounter @@ -863,7 +970,7 @@ Note [Avoiding exponential blowup] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The sc_count field of the ScEnv says how many times we are prepared to duplicate a single function. But we must take care with recursive -specialiations. Consider +specialisations. Consider let $j1 = let $j2 = let $j3 = ... in @@ -1176,38 +1283,62 @@ mkVarUsage env fn args | otherwise = evalScrutOcc ---------------------- -scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) -scTopBind env (Rec prs) +scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) +scTopBindEnv env (Rec prs) + = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs RecFun + + prs' = zip bndrs' rhss + ; return (rhs_env2, Rec prs') } + where + (bndrs,rhss) = unzip prs + +scTopBindEnv env (NonRec bndr rhs) + = do { let (env1, bndr') = extendBndr env bndr + env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) + ; return (env2, NonRec bndr' rhs) } + +---------------------- +scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) + +{- +scTopBind _ usage _ + | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False + = error "false" +-} + +scTopBind env usage (Rec prs) | Just threshold <- sc_size env , not force_spec , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) -- No specialisation - = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs - ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss - ; return (rhs_env, Rec (bndrs' `zip` rhss')) } + = do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss + ; return (usage `combineUsage` (combineUsages rhs_usgs), Rec (bndrs `zip` rhss')) } | otherwise -- Do specialisation - = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + = do { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) (bndrs `zip` rhss) + -- ; pprTrace "scTopBind" (ppr bndrs $$ ppr (map (lookupVarEnv (scu_calls usage)) bndrs)) (return ()) - ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; let rhs_usg = combineUsages rhs_usgs + -- Note [Top-level recursive groups] + ; let (usg,rest) = if all (not . isExportedId) bndrs + then -- pprTrace "scTopBind-T" (ppr bndrs $$ ppr (map (fmap (map snd) . lookupVarEnv (scu_calls usage)) bndrs)) + ( usage + , [SI [] 0 (Just us) | us <- rhs_usgs] ) + else ( combineUsages rhs_usgs + , [SI [] 0 Nothing | _ <- rhs_usgs] ) - ; (_, specs) <- specLoop (scForce rhs_env2 force_spec) - (scu_calls rhs_usg) rhs_infos nullUsage - [SI [] 0 Nothing | _ <- bndrs] + ; (usage', specs) <- specLoop (scForce env force_spec) + (scu_calls usg) rhs_infos nullUsage rest - ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business + ; return (usage `combineUsage` usage', Rec (concat (zipWith specInfoBinds rhs_infos specs))) } where (bndrs,rhss) = unzip prs force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation] -scTopBind env (NonRec bndr rhs) - = do { (_, rhs') <- scExpr env rhs - ; let (env1, bndr') = extendBndr env bndr - env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs') - ; return (env2, NonRec bndr' rhs') } +scTopBind env usage (NonRec bndr rhs) + = do { (rhs_usg', rhs') <- scExpr env rhs + ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } ---------------------- scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo) @@ -1233,6 +1364,7 @@ specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _) -- And now the original binding where rules = [r | OS _ r _ _ <- specs] + \end{code} @@ -1540,6 +1672,7 @@ is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool -- filter out if there are more than the maximum. -- This is only necessary if ForceSpecConstr is in effect: -- otherwise specConstrCount will cause specialisation to terminate. + -- See Note [Limit recursive specialisation] is_too_recursive env ((_,exprs), val_env) = sc_force env && maximum (map go exprs) > sc_recursive env where @@ -1568,7 +1701,7 @@ callToPats env bndr_occs (con_env, args) ; let pat_fvs = varSetElems (exprsFreeVars pats) in_scope_vars = getInScopeVars in_scope qvars = filterOut (`elemVarSet` in_scope_vars) pat_fvs - -- Quantify over variables that are not in sccpe + -- Quantify over variables that are not in scope -- at the call site -- See Note [Free type variables of the qvar types] -- See Note [Shadowing] at the top @@ -1647,7 +1780,7 @@ argToPat env in_scope val_env (Cast arg co) arg_occ { -- Make a wild-card pattern for the coercion uniq <- getUniqueUs ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType ty1 ty2) + co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } where Pair ty1 ty2 = coercionKind co @@ -1747,10 +1880,10 @@ isValue _env (Lit lit) | otherwise = Just (ConVal (LitAlt lit) []) isValue env (Var v) - | Just stuff <- lookupVarEnv env v - = Just stuff -- You might think we could look in the idUnfolding here - -- but that doesn't take account of which branch of a - -- case we are in, which is the whole point + | Just cval <- lookupVarEnv env v + = Just cval -- You might think we could look in the idUnfolding here + -- but that doesn't take account of which branch of a + -- case we are in, which is the whole point | not (isLocalId v) && isCheapUnfolding unf = isValue env (unfoldingTemplate unf) @@ -1782,6 +1915,10 @@ isValue _env expr -- Maybe it's a constructor application isValue _env _expr = Nothing +valueIsWorkFree :: Value -> Bool +valueIsWorkFree LambdaVal = True +valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args + samePat :: CallPat -> CallPat -> Bool samePat (vs1, as1) (vs2, as2) = all2 same as1 as2 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index e6e4c48092..bf73bec240 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -10,7 +10,7 @@ module Specialise ( specProgram ) where import Id import TcType hiding( substTy, extendTvSubstList ) -import Type( TyVar, isDictTy, mkPiTypes ) +import Type( TyVar, isDictTy, mkPiTypes, classifyPredType, PredTree(..), isIPClass ) import Coercion( Coercion ) import CoreMonad import qualified CoreSubst @@ -1044,7 +1044,8 @@ specCalls env rules_for_me calls_for_me fn rhs ; return (spec_rules, spec_defns, plusUDList spec_uds) } | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") + = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, + ptext (sLit "Missed specialisation opportunity for") <+> ppr fn $$ _trace_doc ) -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ @@ -1077,8 +1078,9 @@ specCalls env rules_for_me calls_for_me fn rhs already_covered :: DynFlags -> [CoreExpr] -> Bool already_covered dflags args -- Note [Specialisations already covered] - = isJust (lookupRule dflags (const True) realIdUnfolding - (CoreSubst.substInScope (se_subst env)) + = isJust (lookupRule dflags + (CoreSubst.substInScope (se_subst env), realIdUnfolding) + (const True) fn args rules_for_me) mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] @@ -1429,6 +1431,18 @@ It's a silly exapmle, but we get where choose doesn't have any dict arguments. Thus far I have not tried to fix this (wait till there's a real example). +Mind you, then 'choose' will be inlined (since RHS is trivial) so +it doesn't matter. This comes up with single-method classes + + class C a where { op :: a -> a } + instance C a => C [a] where .... +==> + $fCList :: C a => C [a] + $fCList = $copList |> (...coercion>...) + ....(uses of $fCList at particular types)... + +So we suppress the WARN if the rhs is trivial. + Note [Inline specialisations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is what we do with the InlinePragma of the original function @@ -1583,7 +1597,9 @@ mkCallUDs :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails mkCallUDs env f args | not (want_calls_for f) -- Imported from elsewhere || null theta -- Not overloaded - || not (all type_determines_value theta) + = emptyUDs + + | not (all type_determines_value theta) || not (spec_tys `lengthIs` n_tyvars) || not ( dicts `lengthIs` n_dicts) || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments] @@ -1611,14 +1627,36 @@ mkCallUDs env f args want_calls_for f = isLocalId f || isInlinablePragma (idInlinePragma f) - type_determines_value pred = isClassPred pred && not (isIPPred pred) - -- Only specialise if all overloading is on non-IP *class* params, - -- because these are the ones whose *type* determines their *value*. - -- In ptic, with implicit params, the type args - -- *don't* say what the value of the implicit param is! - -- See Trac #7101 + type_determines_value pred -- See Note [Type determines value] + = case classifyPredType pred of + ClassPred cls _ -> not (isIPClass cls) + TuplePred ps -> all type_determines_value ps + EqPred {} -> True + IrredPred {} -> True -- Things like (D []) where D is a + -- Constraint-ranged family; Trac #7785 \end{code} +Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise if all overloading is on non-IP *class* params, +because these are the ones whose *type* determines their *value*. In +parrticular, with implicit params, the type args *don't* say what the +value of the implicit param is! See Trac #7101 + +However, consider + type family D (v::*->*) :: Constraint + type instance D [] = () + f :: D v => v Char -> Int +If we see a call (f "foo"), we'll pass a "dictionary" + () |> (g :: () ~ D []) +and it's good to specialise f at this dictionary. + +So the question is: can an implicit parameter "hide inside" a +type-family constraint like (D a). Well, no. We don't allow + type instance D Maybe = ?x:Int +Hence the IrredPred case in type_determines_value. +See Trac #7785. + Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this @@ -1844,6 +1882,12 @@ instance MonadUnique SpecM where put $ st { spec_uniq_supply = us2 } return us1 + getUniqueM + = SpecM $ do st <- get + let (u,us') = takeUniqFromSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us' } + return u + instance HasDynFlags SpecM where getDynFlags = SpecM $ liftM spec_dflags get |