X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=4d8efdd8c5c2c55dae5cf832fb3f16af9c5906cc;hp=b424e4a2e759f4c92ce2a7d16ca48cf35bfbadc3;hb=960a5edb6ac87c7d85e36f4b70be8da0175819f7;hpb=9bcaaaaa59acff95886ad3675677e58c43106bd2 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index b424e4a..4d8efdd 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -14,26 +14,27 @@ module Specialise ( specProgram ) where #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..) ) -import Id ( Id, idName, idType, mkUserLocal, - idInlinePragma, setInlinePragma ) +import Id ( Id, idName, idType, mkUserLocal, idCoreRules, + idInlinePragma, setInlinePragma, setIdUnfolding, + isLocalId ) import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, isClassPred, tcCmpType, isUnLiftedType ) import CoreSubst ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst, substBndr, substBndrs, substTy, substInScope, - cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs + cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + extendIdSubst ) +import CoreUnfold ( mkUnfolding ) +import SimplUtils ( interestingArg ) +import Var ( DictId ) import VarSet import VarEnv import CoreSyn -import CoreUtils ( applyTypeToArgs, mkPiTypes ) +import Rules +import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkPiTypes ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) -import CoreTidy ( tidyRules ) -import CoreLint ( showPass, endPass ) -import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds ) -import PprCore ( pprRules ) import UniqSupply ( UniqSupply, UniqSM, initUs_, MonadUnique(..) @@ -41,8 +42,7 @@ import UniqSupply ( UniqSupply, import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap -import Maybes ( catMaybes, maybeToBool ) -import ErrUtils ( dumpIfSet_dyn ) +import Maybes ( catMaybes, isJust ) import Bag import Util import Outputable @@ -488,8 +488,6 @@ of this is permanently ruled out. Still, this is no great hardship, because we intend to eliminate overloading altogether anyway! - - A note about non-tyvar dictionaries ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some Ids have types like @@ -514,7 +512,7 @@ Should we specialise wrt this compound-type dictionary? We used to say But it is simpler and more uniform to specialise wrt these dicts too; and in future GHC is likely to support full fledged type signatures like - f ;: Eq [(a,b)] => ... + f :: Eq [(a,b)] => ... %************************************************************************ @@ -577,21 +575,9 @@ Hence, the invariant is this: %************************************************************************ \begin{code} -specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind] -specProgram dflags us binds = do - - showPass dflags "Specialise" - - let binds' = initSM us (do (binds', uds') <- go binds - return (dumpAllDictBinds uds' binds')) - - endPass dflags "Specialise" Opt_D_dump_spec binds' - - dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations" - (withPprStyle defaultUserStyle $ - pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds'))) - - return binds' +specProgram :: UniqSupply -> [CoreBind] -> [CoreBind] +specProgram us binds = initSM us (do (binds', uds') <- go binds + return (dumpAllDictBinds uds' binds')) where -- We need to start with a Subst that knows all the things -- that are in scope, so that the substitution engine doesn't @@ -618,7 +604,7 @@ specVar subst v = lookupIdSubst subst v specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) -- We carry a substitution down: --- a) we must clone any binding that might flaot outwards, +-- a) we must clone any binding that might float outwards, -- to avoid name clashes -- b) we carry a type substitution to use when analysing -- the RHS of specialised bindings (no type-let!) @@ -644,7 +630,7 @@ specExpr subst expr@(App {}) return (App fun' arg', uds_arg `plusUDs` uds_app) go (Var f) args = case specVar subst f of - Var f' -> return (Var f', mkCallUDs subst f' args) + Var f' -> return (Var f', mkCallUDs f' args) e' -> return (e', emptyUDs) -- I don't expect this! go other _ = specExpr subst other @@ -751,39 +737,73 @@ finishSpecBind bind add (NonRec b r, b_fvs) (prs, fvs) = ((b,r) : prs, b_fvs `unionVarSet` fvs) add (Rec b_prs, b_fvs) (prs, fvs) = (b_prs ++ prs, b_fvs `unionVarSet` fvs) +--------------------------- specBindItself :: Subst -> CoreBind -> CallDetails -> SpecM (CoreBind, UsageDetails) -- specBindItself deals with the RHS, specialising it according -- to the calls found in the body (if any) -specBindItself rhs_subst (NonRec bndr rhs) call_info = do - ((bndr',rhs'), spec_defns, spec_uds) <- specDefn rhs_subst call_info (bndr,rhs) - let - new_bind | null spec_defns = NonRec bndr' rhs' - | otherwise = Rec ((bndr',rhs'):spec_defns) +specBindItself rhs_subst (NonRec fn rhs) call_info + = do { (rhs', rhs_uds) <- specExpr rhs_subst rhs -- Do RHS of original fn + ; (fn', spec_defns, spec_uds) <- specDefn rhs_subst call_info fn rhs + ; if null spec_defns then + return (NonRec fn rhs', rhs_uds) + else + return (Rec ((fn',rhs') : spec_defns), rhs_uds `plusUDs` spec_uds) } -- bndr' mentions the spec_defns in its SpecEnv -- Not sure why we couln't just put the spec_defns first - return (new_bind, spec_uds) - -specBindItself rhs_subst (Rec pairs) call_info = do - stuff <- mapM (specDefn rhs_subst call_info) pairs - let - (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff - spec_defns = concat spec_defns_s - spec_uds = plusUDList spec_uds_s - new_bind = Rec (spec_defns ++ pairs') - return (new_bind, spec_uds) - - -specDefn :: Subst -- Subst to use for RHS + +specBindItself rhs_subst (Rec pairs) call_info + -- Note [Specialising a recursive group] + = do { let (bndrs,rhss) = unzip pairs + ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_subst) rhss + ; let all_calls = call_info `unionCalls` calls rhs_uds + ; (bndrs1, spec_defns1, spec_uds1) <- specDefns rhs_subst all_calls pairs + + ; if null spec_defns1 then -- Common case: no specialisation + return (Rec (bndrs `zip` rhss'), rhs_uds) + else do -- Specialisation occurred; do it again + { (bndrs2, spec_defns2, spec_uds2) <- + -- pprTrace "specB" (ppr bndrs $$ ppr rhs_uds) $ + specDefns rhs_subst (calls spec_uds1) (bndrs1 `zip` rhss) + + ; let all_defns = spec_defns1 ++ spec_defns2 ++ zip bndrs2 rhss' + + ; return (Rec all_defns, rhs_uds `plusUDs` spec_uds1 `plusUDs` spec_uds2) } } + + +--------------------------- +specDefns :: Subst + -> CallDetails -- Info on how it is used in its scope + -> [(Id,CoreExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([Id], -- Original Ids with RULES added + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +-- Specialise a list of bindings (the contents of a Rec), but flowing usages +-- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } +-- Then if the input CallDetails has a specialised call for 'g', whose specialisation +-- in turn generates a specialised call for 'f', we catch that in this one sweep. +-- But not vice versa (it's a fixpoint problem). + +specDefns _subst _call_info [] + = return ([], [], emptyUDs) +specDefns subst call_info ((bndr,rhs):pairs) + = do { (bndrs', spec_defns, spec_uds) <- specDefns subst call_info pairs + ; let all_calls = call_info `unionCalls` calls spec_uds + ; (bndr', spec_defns1, spec_uds1) <- specDefn subst all_calls bndr rhs + ; return (bndr' : bndrs', + spec_defns1 ++ spec_defns, + spec_uds1 `plusUDs` spec_uds) } + +--------------------------- +specDefn :: Subst -> CallDetails -- Info on how it is used in its scope - -> (Id, CoreExpr) -- The thing being bound and its un-processed RHS - -> SpecM ((Id, CoreExpr), -- The thing and its processed RHS - -- the Id may now have specialisations attached + -> Id -> CoreExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails -- Stuff to fling upwards from the RHS and its - ) -- specialised versions + UsageDetails) -- Stuff to fling upwards from the specialised versions -specDefn subst calls (fn, rhs) +specDefn subst calls fn rhs -- The first case is the interesting one | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas && rhs_ids `lengthAtLeast` n_dicts -- and enough dict args @@ -791,27 +811,18 @@ specDefn subst calls (fn, rhs) -- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small -- See Note [Inline specialisation] for why we do not --- switch off specialisation for inline functions = do - = do - -- Specialise the body of the function - (rhs', rhs_uds) <- specExpr subst rhs - - -- Make a specialised version for each call in calls_for_me - stuff <- mapM spec_call calls_for_me - let - (spec_defns, spec_uds, spec_rules) = unzip3 stuff - - fn' = addIdSpecialisations fn spec_rules +-- switch off specialisation for inline functions - return ((fn',rhs'), - spec_defns, - rhs_uds `plusUDs` plusUDList spec_uds) + = do { -- Make a specialised version for each call in calls_for_me + stuff <- mapM spec_call calls_for_me + ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff) + fn' = addIdSpecialisations fn spec_rules + ; return (fn', 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") <+> ppr fn ) -- Note [Specialisation shape] - (do { (rhs', rhs_uds) <- specExpr subst rhs - ; return ((fn, rhs'), [], rhs_uds) }) + return (fn, [], emptyUDs) where fn_type = idType fn @@ -825,93 +836,182 @@ specDefn subst calls (fn, rhs) (inline_rhs, rhs_inside) = dropInline rhs (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside - rhs_dicts = take n_dicts rhs_ids - body = mkLams (drop n_dicts rhs_ids) rhs_body + rhs_dict_ids = take n_dicts rhs_ids + body = mkLams (drop n_dicts rhs_ids) rhs_body -- Glue back on the non-dict lambdas calls_for_me = case lookupFM calls fn of Nothing -> [] Just cs -> fmToList cs + already_covered :: [CoreExpr] -> Bool + already_covered args -- Note [Specialisations already covered] + = isJust (lookupRule (const True) (substInScope subst) + fn args (idCoreRules fn)) + + mk_ty_args :: [Maybe Type] -> [CoreExpr] + mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts + where + mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar) + mk_ty_arg _ (Just ty) = Type ty + ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: (CallKey, ([DictExpr], VarSet)) -- Call instance - -> SpecM ((Id,CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - CoreRule) -- Info for the Id's SpecEnv + spec_call :: (CallKey, ([DictExpr], VarSet)) -- Call instance + -> SpecM (Maybe ((Id,CoreExpr), -- Specialised definition + UsageDetails, -- Usage details from specialised body + CoreRule)) -- Info for the Id's SpecEnv spec_call (CallKey call_ts, (call_ds, _)) - = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) do - -- Calls are only recorded for properly-saturated applications + = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) - -- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs - -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [dx1, dx2] + -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs + -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2] -- Construct the new binding - -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs) + -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) -- PLUS the usage-details -- { d1' = dx1; d2' = dx2 } - -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied. + -- where d1', d2' are cloned versions of d1,d2, with the type substitution + -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 -- -- Note that the substitution is applied to the whole thing. -- This is convenient, but just slightly fragile. Notably: - -- * There had better be no name clashes in a/b/c/d - -- - let - -- poly_tyvars = [b,d] in the example above + -- * There had better be no name clashes in a/b/c + do { let + -- poly_tyvars = [b] in the example above -- spec_tyvars = [a,c] - -- ty_args = [t1,b,t3,d] - poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] - spec_tyvars = [tv | (tv, Just _) <- rhs_tyvars `zip` call_ts] - ty_args = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts - where - mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar) - mk_ty_arg _ (Just ty) = Type ty - rhs_subst = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts]) - - (rhs_subst', rhs_dicts') <- cloneBinders rhs_subst rhs_dicts - let - inst_args = ty_args ++ map Var rhs_dicts' - - -- Figure out the type of the specialised function - body_ty = applyTypeToArgs rhs fn_type inst_args - (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted - | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs - = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId]) - | otherwise = (poly_tyvars, poly_tyvars) - spec_id_ty = mkPiTypes lam_args body_ty - - spec_f <- newIdSM fn spec_id_ty - (spec_rhs, rhs_uds) <- specExpr rhs_subst' (mkLams lam_args body) - let + -- ty_args = [t1,b,t3] + poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] + spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] + spec_ty_args = map snd spec_tv_binds + ty_args = mk_ty_args call_ts + rhs_subst = extendTvSubstList subst spec_tv_binds + + ; (rhs_subst1, inst_dict_ids) <- cloneDictBndrs rhs_subst rhs_dict_ids + -- Clone rhs_dicts, including instantiating their types + + ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $ + (my_zipEqual rhs_dict_ids inst_dict_ids call_ds) + inst_args = ty_args ++ map Var inst_dict_ids + + ; if already_covered inst_args then + return Nothing + else do + { -- Figure out the type of the specialised function + let body_ty = applyTypeToArgs rhs fn_type inst_args + (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted + | isUnLiftedType body_ty -- C.f. WwLib.mkWorkerArgs + = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId]) + | otherwise = (poly_tyvars, poly_tyvars) + spec_id_ty = mkPiTypes lam_args body_ty + + ; spec_f <- newSpecIdSM fn spec_id_ty + ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body) + ; let -- The rule to put in the function's specialisation is: - -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d - spec_env_rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr fn))) - inline_prag -- Note [Auto-specialisation and RULES] - (idName fn) - (poly_tyvars ++ rhs_dicts') - inst_args - (mkVarApps (Var spec_f) app_args) + -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b + rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) + spec_env_rule = mkLocalRule + rule_name + inline_prag -- Note [Auto-specialisation and RULES] + (idName fn) + (poly_tyvars ++ inst_dict_ids) + inst_args + (mkVarApps (Var spec_f) app_args) -- Add the { d1' = dx1; d2' = dx2 } usage stuff - final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds) + final_uds = foldr addDictBind rhs_uds dx_binds - spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs) - | otherwise = (spec_f, spec_rhs) - - return (spec_pr, final_uds, spec_env_rule) + spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs) + | otherwise = (spec_f, spec_rhs) + ; return (Just (spec_pr, final_uds, spec_env_rule)) } } + where + my_zipEqual xs ys zs + | debugIsOn && not (equalLength xs ys && equalLength ys zs) + = pprPanic "my_zipEqual" (vcat [ ppr xs, ppr ys + , ppr fn <+> ppr call_ts + , ppr (idType fn), ppr theta + , ppr n_dicts, ppr rhs_dict_ids + , ppr rhs]) + | otherwise = zip3 xs ys zs + +bindAuxiliaryDicts + :: Subst + -> [(DictId,DictId,CoreExpr)] -- (orig_dict, inst_dict, dx) + -> (Subst, -- Substitute for all orig_dicts + [(DictId, CoreExpr)]) -- Auxiliary bindings +-- Bind any dictionary arguments to fresh names, to preserve sharing +-- Substitution already substitutes orig_dict -> inst_dict +bindAuxiliaryDicts subst triples = go subst [] triples + where + go subst binds [] = (subst, binds) + go subst binds ((d, dx_id, dx) : pairs) + | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs + -- No auxiliary binding necessary + | otherwise = go subst_w_unf ((dx_id,dx) : binds) pairs where - my_zipEqual doc xs ys - | debugIsOn && not (equalLength xs ys) - = pprPanic "my_zipEqual" (vcat - [ ppr xs, ppr ys - , ppr fn <+> ppr call_ts - , ppr (idType fn), ppr theta - , ppr n_dicts, ppr rhs_dicts - , ppr rhs]) - | otherwise = zipEqual doc xs ys + dx_id1 = dx_id `setIdUnfolding` mkUnfolding False dx + subst_w_unf = extendIdSubst subst d (Var dx_id1) + -- Important! We're going to substitute dx_id1 for d + -- and we want it to look "interesting", else we won't gather *any* + -- consequential calls. E.g. + -- f d = ...g d.... + -- If we specialise f for a call (f (dfun dNumInt)), we'll get + -- a consequent call (g d') with an auxiliary definition + -- d' = df dNumInt + -- We want that consequent call to look interesting \end{code} +Note [Specialising a recursive group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let rec { f x = ...g x'... + ; g y = ...f y'.... } + in f 'a' +Here we specialise 'f' at Char; but that is very likely to lead to +a specialisation of 'g' at Char. We must do the latter, else the +whole point of specialisation is lost. + +But we do not want to keep iterating to a fixpoint, because in the +presence of polymorphic recursion we might generate an infinite number +of specialisations. + +So we use the following heuristic: + * Arrange the rec block in dependency order, so far as possible + (the occurrence analyser already does this) + + * Specialise it much like a sequence of lets + + * Then go through the block a second time, feeding call-info from + the RHSs back in the bottom, as it were + +In effect, the ordering maxmimises the effectiveness of each sweep, +and we do just two sweeps. This should catch almost every case of +monomorphic recursion -- the exception could be a very knotted-up +recursion with multiple cycles tied up together. + +This plan is implemented in the Rec case of specBindItself. + +Note [Specialisations already covered] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously don't want to generate two specialisations for the same +argument pattern. There are two wrinkles + +1. We do the already-covered test in specDefn, not when we generate +the CallInfo in mkCallUDs. We used to test in the latter place, but +we now iterate the specialiser somewhat, and the Id at the call site +might therefore not have all the RULES that we can see in specDefn + +2. What about two specialisations where the second is an *instance* +of the first? If the more specific one shows up first, we'll generate +specialisations for both. If the *less* specific one shows up first, +we *don't* currently generate a specialisation for the more specific +one. (See the call to lookupRule in already_covered.) Reasons: + (a) lookupRule doesn't say which matches are exact (bad reason) + (b) if the earlier specialisation is user-provided, it's + far from clear that we should auto-specialise further + Note [Auto-specialisation and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: @@ -950,7 +1050,7 @@ then its body must look like Reason: when specialising the body for a call (f ty dexp), we want to substitute dexp for d, and pick up specialised calls in the body of f. -This doesn't always work. One example I came across was htis: +This doesn't always work. One example I came across was this: newtype Gen a = MkGen{ unGen :: Int -> a } choose :: Eq a => a -> Gen a @@ -1036,13 +1136,16 @@ emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM, ud_fvs = emptyVarSet } ------------------------------------------------------------ type CallDetails = FiniteMap Id CallInfo newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument -type CallInfo = FiniteMap CallKey - ([DictExpr], VarSet) -- Dict args and the vars of the whole - -- call (including tyvars) - -- [*not* include the main id itself, of course] - -- The finite maps eliminate duplicates - -- The list of types and dictionaries is guaranteed to - -- match the type of f + +-- CallInfo uses a FiniteMap, thereby ensuring that +-- we record only one call instance for any key +-- +-- The list of types and dictionaries is guaranteed to +-- match the type of f +type CallInfo = FiniteMap CallKey ([DictExpr], VarSet) + -- Range is dict args and the vars of the whole + -- call (including tyvars) + -- [*not* include the main id itself, of course] instance Outputable CallKey where ppr (CallKey ts) = ppr ts @@ -1081,24 +1184,24 @@ singleCall id tys dicts -- -- We don't include the 'id' itself. -mkCallUDs :: Subst -> Id -> [CoreExpr] -> UsageDetails -mkCallUDs subst f args - | null theta +mkCallUDs :: Id -> [CoreExpr] -> UsageDetails +mkCallUDs f args + | not (isLocalId f) -- Imported from elsewhere + || null theta -- Not overloaded || not (all isClassPred theta) -- Only specialise if all overloading is on class params. -- In ptic, with implicit params, the type args -- *don't* say what the value of the implicit param is! || not (spec_tys `lengthIs` n_tyvars) || not ( dicts `lengthIs` n_dicts) - || maybeToBool (lookupRule (\_act -> True) (substInScope subst) emptyRuleBase f args) - -- There's already a rule covering this call. A typical case - -- is where there's an explicit user-provided rule. Then - -- we don't want to create a specialised version - -- of the function that overlaps. - = emptyUDs -- Not overloaded, or no specialisation wanted + || not (any interestingArg dicts) -- Note [Interesting dictionary arguments] + -- See also Note [Specialisations already covered] + = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) + emptyUDs -- Not overloaded, or no specialisation wanted | otherwise - = singleCall f spec_tys dicts + = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) + singleCall f spec_tys dicts where (tyvars, theta, _) = tcSplitSigmaTy (idType f) constrained_tyvars = tyVarsOfTheta theta @@ -1111,8 +1214,21 @@ mkCallUDs subst f args mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars = Just ty | otherwise = Nothing +\end{code} ------------------------------------------------------------- +Note [Interesting dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + \a.\d:Eq a. let f = ... in ...(f d)... +There really is not much point in specialising f wrt the dictionary d, +because the code for the specialised f is not improved at all, because +d is lambda-bound. We simply get junk specialisations. + +We re-use the function SimplUtils.interestingArg function to determine +what sort of dictionary arguments have *some* information in them. + + +\begin{code} plusUDs :: UsageDetails -> UsageDetails -> UsageDetails plusUDs (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1}) (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2}) @@ -1234,19 +1350,20 @@ cloneBindSM subst (Rec pairs) = do let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs) return (subst', subst', Rec (bndrs' `zip` map snd pairs)) -cloneBinders :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr]) -cloneBinders subst bndrs = do - us <- getUniqueSupplyM - return (cloneIdBndrs subst us bndrs) - -newIdSM :: Id -> Type -> SpecM Id -newIdSM old_id new_ty = do - uniq <- getUniqueM - let - -- Give the new Id a similar occurrence name to the old one - name = idName old_id - new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcSpan name) - return new_id +cloneDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr]) +cloneDictBndrs subst bndrs + = do { us <- getUniqueSupplyM + ; return (cloneIdBndrs subst us bndrs) } + +newSpecIdSM :: Id -> Type -> SpecM Id + -- Give the new Id a similar occurrence name to the old one +newSpecIdSM old_id new_ty + = do { uniq <- getUniqueM + ; let + name = idName old_id + new_occ = mkSpecOcc (nameOccName name) + new_id = mkUserLocal new_occ uniq new_ty (getSrcSpan name) + ; return new_id } \end{code}