X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=4d8efdd8c5c2c55dae5cf832fb3f16af9c5906cc;hp=67dc39cb23bdd8f63627a3b1f120814131e34578;hb=960a5edb6ac87c7d85e36f4b70be8da0175819f7;hpb=fb236fbbea7f12293b030892c6dc866a96566200 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 67dc39c..4d8efdd 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -4,7 +4,6 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -{-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -15,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(..) @@ -42,13 +42,9 @@ import UniqSupply ( UniqSupply, import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap -import Maybes ( catMaybes, maybeToBool ) -import ErrUtils ( dumpIfSet_dyn ) -import BasicTypes ( Activation( AlwaysActive ) ) +import Maybes ( catMaybes, isJust ) import Bag -import List ( partition ) -import Util ( zipEqual, zipWithEqual, cmpList, lengthIs, - equalLength, lengthAtLeast, notNull ) +import Util import Outputable import FastString @@ -492,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 @@ -518,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)] => ... %************************************************************************ @@ -581,20 +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" - (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 @@ -621,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!) @@ -629,7 +612,7 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) ---------------- First the easy cases -------------------- specExpr subst (Type ty) = return (Type (substTy subst ty), emptyUDs) specExpr subst (Var v) = return (specVar subst v, emptyUDs) -specExpr subst (Lit lit) = return (Lit lit, emptyUDs) +specExpr _ (Lit lit) = return (Lit lit, emptyUDs) specExpr subst (Cast e co) = do (e', uds) <- specExpr subst e return ((Cast e' (substTy subst co)), uds) @@ -639,7 +622,7 @@ specExpr subst (Note note body) = do ---------------- Applications might generate a call instance -------------------- -specExpr subst expr@(App fun arg) +specExpr subst expr@(App {}) = go expr [] where go (App fun arg) args = do (arg', uds_arg) <- specExpr subst arg @@ -647,9 +630,9 @@ specExpr subst expr@(App fun arg) 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 args = specExpr subst other + go other _ = specExpr subst other ---------------- Lambda/case require dumping of usage details -------------------- specExpr subst e@(Lam _ _) = do @@ -672,7 +655,7 @@ specExpr subst (Case scrut case_bndr ty alts) = do spec_alt (con, args, rhs) = do (rhs', uds) <- specExpr subst_rhs rhs - let (uds', rhs'') = do dumpUDs args uds rhs' + let (uds', rhs'') = dumpUDs args uds rhs' return ((con, args', rhs''), uds') where (subst_rhs, args') = substBndrs subst_alt args @@ -692,7 +675,8 @@ specExpr subst (Let bind body) = do return (foldr Let body' binds', uds) -- Must apply the type substitution to coerceions -specNote subst note = note +specNote :: Subst -> Note -> Note +specNote _ note = note \end{code} %************************************************************************ @@ -708,79 +692,118 @@ specBind :: Subst -- Use this for RHSs -> SpecM ([CoreBind], -- New bindings UsageDetails) -- And info to pass upstream -specBind rhs_subst bind body_uds = do - (bind', bind_uds) <- specBindItself rhs_subst bind (calls body_uds) - let - bndrs = bindersOf bind - all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds) - -- It's important that the `plusUDs` is this way round, +specBind rhs_subst bind body_uds + = do { (bind', bind_uds) <- specBindItself rhs_subst bind (calls body_uds) + ; return (finishSpecBind bind' bind_uds body_uds) } + +finishSpecBind :: CoreBind -> UsageDetails -> UsageDetails -> ([CoreBind], UsageDetails) +finishSpecBind bind + (MkUD { dict_binds = rhs_dbs, calls = rhs_calls, ud_fvs = rhs_fvs }) + (MkUD { dict_binds = body_dbs, calls = body_calls, ud_fvs = body_fvs }) + | not (mkVarSet bndrs `intersectsVarSet` all_fvs) + -- Common case 1: the bound variables are not + -- mentioned in the dictionary bindings + = ([bind], MkUD { dict_binds = body_dbs `unionBags` rhs_dbs + -- It's important that the `unionBags` is this way round, -- because body_uds may bind dictionaries that are -- used in the calls passed to specDefn. So the - -- dictionary bindings in bind_uds may mention + -- dictionary bindings in rhs_uds may mention -- dictionaries bound in body_uds. - case splitUDs bndrs all_uds of - - (_, ([],[])) -- This binding doesn't bind anything needed - -- in the UDs, so put the binding here - -- This is the case for most non-dict bindings, except - -- for the few that are mentioned in a dict binding - -- that is floating upwards in body_uds - -> return ([bind'], all_uds) - - (float_uds, (dict_binds, calls)) -- This binding is needed in the UDs, so float it out - -> return ([], float_uds `plusUDs` mkBigUD bind' dict_binds calls) - - --- A truly gruesome function -mkBigUD bind@(NonRec _ _) dbs calls - = -- Common case: non-recursive and no specialisations - -- (if there were any specialistions it would have been made recursive) - MkUD { dict_binds = listToBag (mkDB bind : dbs), - calls = listToCallDetails calls } - -mkBigUD bind dbs calls - = -- General case - MkUD { dict_binds = unitBag (mkDB (Rec (bind_prs bind ++ dbsToPairs dbs))), - -- Make a huge Rec - calls = listToCallDetails calls } + , calls = all_calls + , ud_fvs = all_fvs }) + + | case bind of { NonRec {} -> True; Rec {} -> False } + -- Common case 2: no specialisation happened, and binding + -- is non-recursive. But the binding may be + -- mentioned in body_dbs, so we should put it first + = ([], MkUD { dict_binds = rhs_dbs `unionBags` ((bind, b_fvs) `consBag` body_dbs) + , calls = all_calls + , ud_fvs = all_fvs `unionVarSet` b_fvs }) + + | otherwise -- General case: make a huge Rec (sigh) + = ([], MkUD { dict_binds = unitBag (Rec all_db_prs, all_db_fvs) + , calls = all_calls + , ud_fvs = all_fvs `unionVarSet` b_fvs }) where - bind_prs (NonRec b r) = [(b,r)] - bind_prs (Rec prs) = prs + all_fvs = rhs_fvs `unionVarSet` body_fvs + all_calls = zapCalls bndrs (rhs_calls `unionCalls` body_calls) - dbsToPairs [] = [] - dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs + bndrs = bindersOf bind + b_fvs = bind_fvs bind + + (all_db_prs, all_db_fvs) = add (bind, b_fvs) $ + foldrBag add ([], emptyVarSet) $ + rhs_dbs `unionBags` body_dbs + 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 @@ -788,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 +-- switch off specialisation for inline functions - -- 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 - - 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 ) + = 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 @@ -822,95 +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 - rhs_bndrs = rhs_tyvars ++ rhs_dicts - 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 call_ts, (call_ds, call_fvs)) - = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) do - -- Calls are only recorded for properly-saturated applications + 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 ) - -- 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 rhs_tyvar (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 -#ifdef DEBUG - | 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]) -#endif - | 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: @@ -949,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 @@ -1010,51 +1111,66 @@ data UsageDetails -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 -- (Remember, Bags preserve order in GHC.) - calls :: !CallDetails + calls :: !CallDetails, + + ud_fvs :: !VarSet -- A superset of the variables mentioned in + -- either dict_binds or calls } +instance Outputable UsageDetails where + ppr (MkUD { dict_binds = dbs, calls = calls, ud_fvs = fvs }) + = ptext (sLit "MkUD") <+> braces (sep (punctuate comma + [ptext (sLit "binds") <+> equals <+> ppr dbs, + ptext (sLit "calls") <+> equals <+> ppr calls, + ptext (sLit "fvs") <+> equals <+> ppr fvs])) + type DictBind = (CoreBind, VarSet) -- The set is the free vars of the binding -- both tyvars and dicts type DictExpr = CoreExpr -emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM } - -type ProtoUsageDetails = ([DictBind], - [(Id, CallKey, ([DictExpr], VarSet))] - ) +emptyUDs :: UsageDetails +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 -- Type isn't an instance of Ord, so that we can control which -- instance we use. That's tiresome here. Oh well instance Eq CallKey where - k1 == k2 = case k1 `compare` k2 of { EQ -> True; other -> False } + k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False } instance Ord CallKey where compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2 where - cmp Nothing Nothing = EQ - cmp Nothing (Just t2) = LT - cmp (Just t1) Nothing = GT + cmp Nothing Nothing = EQ + cmp Nothing (Just _) = LT + cmp (Just _) Nothing = GT cmp (Just t1) (Just t2) = tcCmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusFM_C plusFM c1 c2 -singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails +singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails singleCall id tys dicts - = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)) + = MkUD {dict_binds = emptyBag, + calls = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)), + ud_fvs = call_fvs } where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs tys_fvs = tyVarsOfTypes (catMaybes tys) @@ -1068,36 +1184,24 @@ singleCall id tys dicts -- -- We don't include the 'id' itself. -listToCallDetails calls - = foldr (unionCalls . mk_call) emptyFM calls - where - mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs) - -- NB: the free vars of the call are provided - -callDetailsToList calls = [ (id,tys,dicts) - | (id,fm) <- fmToList calls, - (tys, dicts) <- fmToList fm - ] - -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 - = MkUD {dict_binds = emptyBag, - calls = 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 @@ -1110,29 +1214,47 @@ 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}) - (MkUD {dict_binds = db2, calls = calls2}) - = MkUD {dict_binds = d, calls = c} +plusUDs (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1}) + (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2}) + = MkUD {dict_binds = d, calls = c, ud_fvs = fvs1 `unionVarSet` fvs2} where d = db1 `unionBags` db2 c = calls1 `unionCalls` calls2 +plusUDList :: [UsageDetails] -> UsageDetails plusUDList = foldr plusUDs emptyUDs -- zapCalls deletes calls to ids from uds -zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids} +zapCalls :: [Id] -> CallDetails -> CallDetails +zapCalls ids calls = delListFromFM calls ids +mkDB :: CoreBind -> DictBind mkDB bind = (bind, bind_fvs bind) +bind_fvs :: CoreBind -> VarSet bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs where bndrs = map fst prs rhs_fvs = unionVarSets (map pair_fvs prs) +pair_fvs :: (Id, CoreExpr) -> VarSet pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr -- Don't forget variables mentioned in the -- rules of the bndr. C.f. OccAnal.addRuleUsage @@ -1140,8 +1262,14 @@ pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr -- type T a = Int -- x :: T a = 3 -addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds } +addDictBind :: (Id,CoreExpr) -> UsageDetails -> UsageDetails +addDictBind (dict,rhs) uds + = uds { dict_binds = db `consBag` dict_binds uds + , ud_fvs = ud_fvs uds `unionVarSet` fvs } + where + db@(_, fvs) = mkDB (NonRec dict rhs) +dumpAllDictBinds :: UsageDetails -> [CoreBind] -> [CoreBind] dumpAllDictBinds (MkUD {dict_binds = dbs}) binds = foldrBag add binds dbs where @@ -1150,44 +1278,27 @@ dumpAllDictBinds (MkUD {dict_binds = dbs}) binds dumpUDs :: [CoreBndr] -> UsageDetails -> CoreExpr -> (UsageDetails, CoreExpr) -dumpUDs bndrs uds body - = (free_uds, foldr add_let body dict_binds) +dumpUDs bndrs (MkUD { dict_binds = orig_dbs + , calls = orig_calls + , ud_fvs = fvs}) body + = (new_uds, foldrBag add_let body dump_dbs) + -- This may delete fewer variables + -- than in priciple possible where - (free_uds, (dict_binds, _)) = splitUDs bndrs uds - add_let (bind,_) body = Let bind body - -splitUDs :: [CoreBndr] - -> UsageDetails - -> (UsageDetails, -- These don't mention the binders - ProtoUsageDetails) -- These do - -splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, - calls = orig_calls}) - - = if isEmptyBag dump_dbs && null dump_calls then - -- Common case: binder doesn't affect floats - (uds, ([],[])) - - else - -- Binders bind some of the fvs of the floats - (MkUD {dict_binds = free_dbs, - calls = listToCallDetails free_calls}, - (bagToList dump_dbs, dump_calls) - ) + new_uds = + MkUD { dict_binds = free_dbs + , calls = free_calls + , ud_fvs = fvs `minusVarSet` bndr_set} - where bndr_set = mkVarSet bndrs + add_let (bind,_) body = Let bind body - (free_dbs, dump_dbs, dump_idset) - = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs + (free_dbs, dump_dbs, dump_set) + = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs -- Important that it's foldl not foldr; -- we're accumulating the set of dumped ids in dump_set - -- Filter out any calls that mention things that are being dumped - orig_call_list = callDetailsToList orig_calls - (dump_calls, free_calls) = partition captured orig_call_list - captured (id,tys,(dicts, fvs)) = fvs `intersectsVarSet` dump_idset - || id `elemVarSet` dump_idset + free_calls = filterCalls dump_set orig_calls dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) | dump_idset `intersectsVarSet` fvs -- Dump it @@ -1196,6 +1307,15 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, | otherwise -- Don't dump it = (free_dbs `snocBag` db, dump_dbs, dump_idset) + +filterCalls :: VarSet -> CallDetails -> CallDetails +-- Remove any calls that mention the variables +filterCalls bs calls + = mapFM (\_ cs -> filter_calls cs) $ + filterFM (\k _ -> not (k `elemVarSet` bs)) calls + where + filter_calls :: CallInfo -> CallInfo + filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs)) \end{code} @@ -1208,9 +1328,11 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, \begin{code} type SpecM a = UniqSM a +initSM :: UniqSupply -> SpecM a -> a initSM = initUs_ -mapAndCombineSM f [] = return ([], emptyUDs) +mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) +mapAndCombineSM _ [] = return ([], emptyUDs) mapAndCombineSM f (x:xs) = do (y, uds1) <- f x (ys, uds2) <- mapAndCombineSM f xs return (y:ys, uds1 `plusUDs` uds2) @@ -1220,7 +1342,7 @@ cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind) -- Return the substitution to use for RHSs, and the one to use for the body cloneBindSM subst (NonRec bndr rhs) = do us <- getUniqueSupplyM - let (subst', bndr') = do cloneIdBndr subst us bndr + let (subst', bndr') = cloneIdBndr subst us bndr return (subst, subst', NonRec bndr' rhs) cloneBindSM subst (Rec pairs) = do @@ -1228,17 +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 bndrs = do - us <- getUniqueSupplyM - return (cloneIdBndrs subst us bndrs) - -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}