X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=4d8efdd8c5c2c55dae5cf832fb3f16af9c5906cc;hp=b3bd6a2851964f5c849204c418a06635811b5d2d;hb=960a5edb6ac87c7d85e36f4b70be8da0175819f7;hpb=ad94d40948668032189ad22a0ad741ac1f645f50 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index b3bd6a2..4d8efdd 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -4,55 +4,50 @@ \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 --- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details 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_, thenUs, returnUs, getUniqueUs, - getUs, mapUs + UniqSM, initUs_, + MonadUnique(..) ) 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 -infixr 9 `thenSM` \end{code} %************************************************************************ @@ -493,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 @@ -519,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)] => ... %************************************************************************ @@ -582,32 +575,21 @@ 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 (go binds `thenSM` \ (binds', uds') -> - returnSM (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 -- accidentally re-use a unique that's already in use -- Easiest thing is to do it all at once, as if all the top-level -- decls were mutually recursive - top_subst = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) + top_subst = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) - go [] = returnSM ([], emptyUDs) - go (bind:binds) = go binds `thenSM` \ (binds', uds) -> - specBind top_subst bind uds `thenSM` \ (bind', uds') -> - returnSM (bind' ++ binds', uds') + go [] = return ([], emptyUDs) + go (bind:binds) = do (binds', uds) <- go binds + (bind', uds') <- specBind top_subst bind uds + return (bind' ++ binds', uds') \end{code} %************************************************************************ @@ -622,82 +604,79 @@ 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!) ---------------- First the easy cases -------------------- -specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs) -specExpr subst (Var v) = returnSM (specVar subst v, emptyUDs) -specExpr subst (Lit lit) = returnSM (Lit lit, emptyUDs) -specExpr subst (Cast e co) = - specExpr subst e `thenSM` \ (e', uds) -> - returnSM ((Cast e' (substTy subst co)), uds) -specExpr subst (Note note body) - = specExpr subst body `thenSM` \ (body', uds) -> - returnSM (Note (specNote subst note) body', uds) +specExpr subst (Type ty) = return (Type (substTy subst ty), emptyUDs) +specExpr subst (Var v) = return (specVar subst v, 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) +specExpr subst (Note note body) = do + (body', uds) <- specExpr subst body + return (Note (specNote subst note) body', uds) ---------------- Applications might generate a call instance -------------------- -specExpr subst expr@(App fun arg) +specExpr subst expr@(App {}) = go expr [] where - go (App fun arg) args = specExpr subst arg `thenSM` \ (arg', uds_arg) -> - go fun (arg':args) `thenSM` \ (fun', uds_app) -> - returnSM (App fun' arg', uds_arg `plusUDs` uds_app) + go (App fun arg) args = do (arg', uds_arg) <- specExpr subst arg + (fun', uds_app) <- go fun (arg':args) + return (App fun' arg', uds_arg `plusUDs` uds_app) go (Var f) args = case specVar subst f of - Var f' -> returnSM (Var f', mkCallUDs subst f' args) - e' -> returnSM (e', emptyUDs) -- I don't expect this! - go other args = specExpr subst other + Var f' -> return (Var f', mkCallUDs f' args) + e' -> return (e', emptyUDs) -- I don't expect this! + go other _ = specExpr subst other ---------------- Lambda/case require dumping of usage details -------------------- -specExpr subst e@(Lam _ _) - = specExpr subst' body `thenSM` \ (body', uds) -> - let - (filtered_uds, body'') = dumpUDs bndrs' uds body' - in - returnSM (mkLams bndrs' body'', filtered_uds) +specExpr subst e@(Lam _ _) = do + (body', uds) <- specExpr subst' body + let (filtered_uds, body'') = dumpUDs bndrs' uds body' + return (mkLams bndrs' body'', filtered_uds) where (bndrs, body) = collectBinders e (subst', bndrs') = substBndrs subst bndrs -- More efficient to collect a group of binders together all at once -- and we don't want to split a lambda group with dumped bindings -specExpr subst (Case scrut case_bndr ty alts) - = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) -> - mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) -> - returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts) +specExpr subst (Case scrut case_bndr ty alts) = do + (scrut', uds_scrut) <- specExpr subst scrut + (alts', uds_alts) <- mapAndCombineSM spec_alt alts + return (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts) where (subst_alt, case_bndr') = substBndr subst case_bndr -- No need to clone case binder; it can't float like a let(rec) - spec_alt (con, args, rhs) - = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) -> - let - (uds', rhs'') = dumpUDs args uds rhs' - in - returnSM ((con, args', rhs''), uds') - where - (subst_rhs, args') = substBndrs subst_alt args + spec_alt (con, args, rhs) = do + (rhs', uds) <- specExpr subst_rhs rhs + let (uds', rhs'') = dumpUDs args uds rhs' + return ((con, args', rhs''), uds') + where + (subst_rhs, args') = substBndrs subst_alt args ---------------- Finally, let is the interesting case -------------------- -specExpr subst (Let bind body) - = -- Clone binders - cloneBindSM subst bind `thenSM` \ (rhs_subst, body_subst, bind') -> - - -- Deal with the body - specExpr body_subst body `thenSM` \ (body', body_uds) -> +specExpr subst (Let bind body) = do + -- Clone binders + (rhs_subst, body_subst, bind') <- cloneBindSM subst bind + + -- Deal with the body + (body', body_uds) <- specExpr body_subst body - -- Deal with the bindings - specBind rhs_subst bind' body_uds `thenSM` \ (binds', uds) -> + -- Deal with the bindings + (binds', uds) <- specBind rhs_subst bind' body_uds - -- All done - returnSM (foldr Let body' binds', uds) + -- All done + 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} %************************************************************************ @@ -714,81 +693,117 @@ specBind :: Subst -- Use this for RHSs UsageDetails) -- And info to pass upstream specBind rhs_subst bind body_uds - = specBindItself rhs_subst bind (calls body_uds) `thenSM` \ (bind', bind_uds) -> - let - bndrs = bindersOf bind - all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds) - -- It's important that the `plusUDs` is this way round, + = 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. - in - 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 - -> returnSM ([bind'], all_uds) - - (float_uds, (dict_binds, calls)) -- This binding is needed in the UDs, so float it out - -> returnSM ([], 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) + + bndrs = bindersOf bind + b_fvs = bind_fvs bind - dbsToPairs [] = [] - dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs + (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 - = specDefn rhs_subst call_info (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) -> - 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 - in - returnSM (new_bind, spec_uds) - + specBindItself rhs_subst (Rec pairs) call_info - = mapSM (specDefn rhs_subst call_info) pairs `thenSM` \ stuff -> - 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') - in - returnSM (new_bind, spec_uds) - - -specDefn :: Subst -- Subst to use for RHS + -- 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 @@ -798,25 +813,16 @@ specDefn subst calls (fn, rhs) -- See Note [Inline specialisation] for why we do not -- switch off specialisation for inline functions - = -- Specialise the body of the function - specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> - - -- Make a specialised version for each call in calls_for_me - mapSM spec_call calls_for_me `thenSM` \ stuff -> - let - (spec_defns, spec_uds, spec_rules) = unzip3 stuff - - fn' = addIdSpecialisations fn spec_rules - in - returnSM ((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] - specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> - returnSM ((fn, rhs'), [], rhs_uds) + return (fn, [], emptyUDs) where fn_type = idType fn @@ -830,94 +836,209 @@ 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)) + 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 ) - -- Calls are only recorded for properly-saturated applications - -- 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]) - in - cloneBinders rhs_subst rhs_dicts `thenSM` \ (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 - in - newIdSM fn spec_id_ty `thenSM` \ spec_f -> - specExpr rhs_subst' (mkLams lam_args body) `thenSM` \ (spec_rhs, rhs_uds) -> - 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))) - AlwaysActive (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) - in - returnSM (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: + g :: Num a => a -> a + g = ... + + f :: (Int -> Int) -> Int + f w = ... + {-# RULE f g = 0 #-} + +Suppose that auto-specialisation makes a specialised version of +g::Int->Int That version won't appear in the LHS of the RULE for f. +So if the specialisation rule fires too early, the rule for f may +never fire. + +It might be possible to add new rules, to "complete" the rewrite system. +Thus when adding + RULE forall d. g Int d = g_spec +also add + RULE f g_spec = 0 + +But that's a bit complicated. For now we ask the programmer's help, +by *copying the INLINE activation pragma* to the auto-specialised rule. +So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also +not be active until phase 2. + + Note [Specialisation shape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We only specialise a function if it has visible top-level lambdas @@ -929,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 @@ -990,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) @@ -1048,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 @@ -1090,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 @@ -1120,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 @@ -1130,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 @@ -1176,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} @@ -1188,46 +1328,42 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, \begin{code} type SpecM a = UniqSM a -thenSM = thenUs -returnSM = returnUs -getUniqSM = getUniqueUs -mapSM = mapUs +initSM :: UniqSupply -> SpecM a -> a initSM = initUs_ -mapAndCombineSM f [] = returnSM ([], emptyUDs) -mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) -> - mapAndCombineSM f xs `thenSM` \ (ys, uds2) -> - returnSM (y:ys, uds1 `plusUDs` uds2) +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) cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind) -- Clone the binders of the bind; return new bind with the cloned binders -- Return the substitution to use for RHSs, and the one to use for the body -cloneBindSM subst (NonRec bndr rhs) - = getUs `thenUs` \ us -> - let - (subst', bndr') = cloneIdBndr subst us bndr - in - returnUs (subst, subst', NonRec bndr' rhs) - -cloneBindSM subst (Rec pairs) - = getUs `thenUs` \ us -> - let - (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs) - in - returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs)) - -cloneBinders subst bndrs - = getUs `thenUs` \ us -> - returnUs (cloneIdBndrs subst us bndrs) - -newIdSM old_id new_ty - = getUniqSM `thenSM` \ uniq -> - 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) - in - returnSM new_id +cloneBindSM subst (NonRec bndr rhs) = do + us <- getUniqueSupplyM + let (subst', bndr') = cloneIdBndr subst us bndr + return (subst, subst', NonRec bndr' rhs) + +cloneBindSM subst (Rec pairs) = do + us <- getUniqueSupplyM + let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs) + return (subst', subst', Rec (bndrs' `zip` map snd pairs)) + +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}