X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=0e66b0bc7820d7cd4dfa1d7ac42e6f7f83727416;hb=df85c4b4a403c1e17d3f79fe91109ffbe6ba60b7;hp=5e7ca37c5b42297ccdd155d82b355d48614aa76f;hpb=72a9e0e26358e02dec63453d55fbc24a6f13f789;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 5e7ca37..0e66b0b 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -1,56 +1,48 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -module Specialise ( - specProgram, - idSpecVars - ) where +module Specialise ( specProgram ) where #include "HsVersions.h" -import MkId ( mkUserLocal ) -import Id ( Id, DictVar, idType, mkTemplateLocals, - - getIdSpecialisation, setIdSpecialisation, isSpecPragmaId, - - IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet, - emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet, - - IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv, delOneFromIdEnv - ) - -import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy, - tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys - ) -import TyCon ( TyCon ) -import TyVar ( TyVar, mkTyVar, - TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets, - elementOfTyVarSet, unionTyVarSets, emptyTyVarSet, - minusTyVarSet, - TyVarEnv, mkTyVarEnv, delFromTyVarEnv +import DynFlags ( DynFlags, DynFlag(..) ) +import Id ( Id, idName, idType, mkUserLocal ) +import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, + tyVarsOfTypes, tyVarsOfTheta, isClassPred, + tcCmpType, isUnLiftedType ) -import Kind ( mkBoxedTypeKind ) +import CoreSubst ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst, + substBndr, substBndrs, substTy, substInScope, + cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs + ) +import VarSet +import VarEnv import CoreSyn -import FreeVars ( exprFreeVars ) -import PprCore () -- Instances -import Name ( NamedThing(..), getSrcLoc, mkSysLocalName, isLocallyDefined ) -import SrcLoc ( noSrcLoc ) -import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues ) - +import CoreUtils ( applyTypeToArgs, mkPiTypes ) +import CoreFVs ( exprFreeVars, exprsFreeVars, idRuleVars ) +import CoreTidy ( tidyRules ) +import CoreLint ( showPass, endPass ) +import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds ) +import PprCore ( pprRules ) import UniqSupply ( UniqSupply, - UniqSM, initUs, thenUs, returnUs, getUnique, mapUs + UniqSM, initUs_, thenUs, returnUs, getUniqueUs, + getUs, mapUs ) -import Unique ( mkAlphaTyVarUnique ) +import Name ( nameOccName, mkSpecOcc, getSrcLoc ) +import MkId ( voidArgId, realWorldPrimId ) import FiniteMap -import Maybes ( MaybeErr(..), maybeToBool ) +import Maybes ( catMaybes, maybeToBool ) +import ErrUtils ( dumpIfSet_dyn ) +import BasicTypes ( Activation( AlwaysActive ) ) import Bag import List ( partition ) -import Util ( zipEqual ) +import Util ( zipEqual, zipWithEqual, cmpList, lengthIs, + equalLength, lengthAtLeast, notNull ) import Outputable - +import FastString infixr 9 `thenSM` \end{code} @@ -102,12 +94,6 @@ applications could only arise as a result of transformation, and even then I think it's unlikely. In any case, we simply don't accumulate such partial applications.) -There's a choice of whether to collect details of all *polymorphic* functions -or simply all *overloaded* ones. How to sort this out? - Pass in a predicate on the function to say if it is "interesting"? - This is dependent on the user flags: SpecialiseOverloaded - SpecialiseUnboxed - SpecialiseAll STEP 2: EQUIVALENCES @@ -588,15 +574,31 @@ Hence, the invariant is this: %************************************************************************ \begin{code} -specProgram :: UniqSupply -> [CoreBinding] -> [CoreBinding] -specProgram us binds - = initSM us (go binds `thenSM` \ (binds', uds') -> - returnSM (dumpAllDictBinds uds' binds') - ) +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' 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))) + go [] = returnSM ([], emptyUDs) - go (bind:binds) = go binds `thenSM` \ (binds', uds) -> - specBind bind uds `thenSM` \ (bind', uds') -> + go (bind:binds) = go binds `thenSM` \ (binds', uds) -> + specBind top_subst bind uds `thenSM` \ (bind', uds') -> returnSM (bind' ++ binds', uds') \end{code} @@ -607,87 +609,86 @@ specProgram us binds %************************************************************************ \begin{code} -specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails) +specVar :: Subst -> Id -> CoreExpr +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, +-- 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 e@(Var _) = returnSM (e, emptyUDs) -specExpr e@(Lit _) = returnSM (e, emptyUDs) -specExpr e@(Con _ _) = returnSM (e, emptyUDs) -specExpr e@(Prim _ _) = returnSM (e, emptyUDs) +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 (Note note body) - = specExpr body `thenSM` \ (body', uds) -> - returnSM (Note note body', uds) +specExpr subst (Note note body) + = specExpr subst body `thenSM` \ (body', uds) -> + returnSM (Note (specNote subst note) body', uds) ---------------- Applications might generate a call instance -------------------- -specExpr e@(App fun arg) - = go fun [arg] +specExpr subst expr@(App fun arg) + = go expr [] where - go (App fun arg) args = go fun (arg:args) - go (Var f) args = returnSM (e, mkCallUDs f args) - go other args = specExpr other `thenSM` \ (e', uds) -> - returnSM (foldl App e' args, uds) + 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 (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 ---------------- Lambda/case require dumping of usage details -------------------- -specExpr e@(Lam _ _) - = specExpr body `thenSM` \ (body', uds) -> +specExpr subst e@(Lam _ _) + = specExpr subst' body `thenSM` \ (body', uds) -> let - (filtered_uds, body'') = dumpUDs bndrs uds body' + (filtered_uds, body'') = dumpUDs bndrs' uds body' in - returnSM (foldr Lam body'' bndrs, filtered_uds) + returnSM (mkLams bndrs' body'', filtered_uds) where - (bndrs, body) = go [] e - + (bndrs, body) = collectBinders e + (subst', bndrs') = substBndrs subst bndrs -- More efficient to collect a group of binders together all at once - go bndrs (Lam bndr e) = go (bndr:bndrs) e - go bndrs e = (reverse bndrs, e) - + -- and we don't want to split a lambda group with dumped bindings -specExpr (Case scrut alts) - = specExpr scrut `thenSM` \ (scrut', uds_scrut) -> - spec_alts alts `thenSM` \ (alts', uds_alts) -> - returnSM (Case scrut' alts', uds_scrut `plusUDs` uds_alts) +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) where - spec_alts (AlgAlts alts deflt) - = mapAndCombineSM spec_alg_alt alts `thenSM` \ (alts', uds1) -> - spec_deflt deflt `thenSM` \ (deflt', uds2) -> - returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2) - - spec_alts (PrimAlts alts deflt) - = mapAndCombineSM spec_prim_alt alts `thenSM` \ (alts', uds1) -> - spec_deflt deflt `thenSM` \ (deflt', uds2) -> - returnSM (PrimAlts alts' deflt', uds1 `plusUDs` uds2) - - spec_alg_alt (con, args, rhs) - = specExpr rhs `thenSM` \ (rhs', uds) -> - let - (uds', rhs'') = dumpUDs (map ValBinder args) uds rhs' - in - returnSM ((con, args, rhs''), uds') - - spec_prim_alt (lit, rhs) - = specExpr rhs `thenSM` \ (rhs', uds) -> - returnSM ((lit, rhs'), uds) + (subst_alt, case_bndr') = substBndr subst case_bndr + -- No need to clone case binder; it can't float like a let(rec) - spec_deflt NoDefault = returnSM (NoDefault, emptyUDs) - spec_deflt (BindDefault arg rhs) - = specExpr rhs `thenSM` \ (rhs', uds) -> + spec_alt (con, args, rhs) + = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) -> let - (uds', rhs'') = dumpUDs [ValBinder arg] uds rhs' + (uds', rhs'') = dumpUDs args uds rhs' in - returnSM (BindDefault arg rhs'', uds') + returnSM ((con, args', rhs''), uds') + where + (subst_rhs, args') = substBndrs subst_alt args ---------------- Finally, let is the interesting case -------------------- -specExpr (Let bind body) - = -- Deal with the body - specExpr body `thenSM` \ (body', body_uds) -> +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) -> -- Deal with the bindings - specBind bind body_uds `thenSM` \ (binds', uds) -> + specBind rhs_subst bind' body_uds `thenSM` \ (binds', uds) -> -- All done returnSM (foldr Let body' binds', uds) + +-- Must apply the type substitution to coerceions +specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2) +specNote subst note = note \end{code} %************************************************************************ @@ -697,63 +698,80 @@ specExpr (Let bind body) %************************************************************************ \begin{code} -specBind :: CoreBinding +specBind :: Subst -- Use this for RHSs + -> CoreBind -> UsageDetails -- Info on how the scope of the binding - -> SpecM ([CoreBinding], -- New bindings + -> SpecM ([CoreBind], -- New bindings UsageDetails) -- And info to pass upstream -specBind (NonRec bndr rhs) body_uds - | isDictTy (idType bndr) - = -- It's a dictionary binding - -- Pick it up and float it outwards. - specExpr rhs `thenSM` \ (rhs', rhs_uds) -> +specBind rhs_subst bind body_uds + = specBindItself rhs_subst bind (calls body_uds) `thenSM` \ (bind', bind_uds) -> let - all_uds = rhs_uds `plusUDs` addDictBind body_uds bndr rhs' - in - returnSM ([], all_uds) - - | isSpecPragmaId bndr - = specExpr rhs `thenSM` \ (rhs', rhs_uds) -> - returnSM ([], rhs_uds `plusUDs` body_uds) - - | otherwise - = -- Deal with the RHS, specialising it according - -- to the calls found in the body - specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) -> - let - (all_uds, (dict_binds, dump_calls)) - = splitUDs [ValBinder bndr] - (body_uds `plusUDs` spec_uds) + bndrs = bindersOf bind + all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds) -- It's important that the `plusUDs` is this way round, -- because body_uds may bind dictionaries that are -- used in the calls passed to specDefn. So the - -- dictionary bindings in spec_uds may mention + -- dictionary bindings in bind_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 } + where + bind_prs (NonRec b r) = [(b,r)] + bind_prs (Rec prs) = prs + + dbsToPairs [] = [] + dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs - -- If we make specialisations then we Rec the whole lot together - -- If not, leave it as a NonRec +-- 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) + -- bndr' mentions the spec_defns in its SpecEnv + -- Not sure why we couln't just put the spec_defns first in - returnSM ( new_bind : mkDictBinds dict_binds, all_uds ) + returnSM (new_bind, spec_uds) -specBind (Rec pairs) body_uds - = mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff -> +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 - - (all_uds, (dict_binds, dump_calls)) - = splitUDs (map (ValBinder . fst) pairs) - (body_uds `plusUDs` spec_uds) - -- See notes for non-rec case - - new_bind = Rec (spec_defns ++ pairs') + new_bind = Rec (spec_defns ++ pairs') in - returnSM ( new_bind : mkDictBinds dict_binds, all_uds ) + returnSM (new_bind, spec_uds) -specDefn :: CallDetails -- Info on how it is used in its scope + +specDefn :: Subst -- Subst to use for RHS + -> 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 @@ -761,47 +779,51 @@ specDefn :: CallDetails -- Info on how it is used in its scope UsageDetails -- Stuff to fling upwards from the RHS and its ) -- specialised versions -specDefn calls (fn, rhs) +specDefn subst calls (fn, rhs) -- The first case is the interesting one - | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas - && n_dicts <= length rhs_bndrs -- and enough dict args - && not (null calls_for_me) -- And there are some calls to specialise + | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas + && rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args + && notNull calls_for_me -- And there are some calls to specialise + +-- At one time I tried not specialising small functions +-- but sometimes there are big functions marked INLINE +-- that we'd like to specialise. In particular, dictionary +-- functions, which Marcin is keen to inline +-- && not (certainlyWillInline fn) -- And it's not small + -- If it's small, it's better just to inline + -- it than to construct lots of specialisations = -- Specialise the body of the function - specExpr body `thenSM` \ (body', body_uds) -> - let - (float_uds, bound_uds@(dict_binds,_)) = splitUDs rhs_bndrs body_uds - in + specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> -- Make a specialised version for each call in calls_for_me - mapSM (spec_call bound_uds) calls_for_me `thenSM` \ stuff -> + mapSM spec_call calls_for_me `thenSM` \ stuff -> let - (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff + (spec_defns, spec_uds, spec_rules) = unzip3 stuff - fn' = addIdSpecialisations fn spec_env_stuff - rhs' = foldr Lam (mkDictLets dict_binds body') rhs_bndrs + fn' = addIdSpecialisations fn spec_rules in returnSM ((fn',rhs'), spec_defns, - float_uds `plusUDs` plusUDList spec_uds) + rhs_uds `plusUDs` plusUDList spec_uds) | otherwise -- No calls or RHS doesn't fit our preconceptions - = specExpr rhs `thenSM` \ (rhs', rhs_uds) -> + = specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> returnSM ((fn, rhs'), [], rhs_uds) where - fn_type = idType fn - (tyvars, theta, tau) = splitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta - mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyVarTemplates - where - mk_spec_ty (Just ty) _ = ty - mk_spec_ty Nothing tyvar = mkTyVarTy tyvar - - (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs + fn_type = idType fn + (tyvars, theta, _) = tcSplitSigmaTy fn_type + n_tyvars = length tyvars + n_dicts = length theta + + (rhs_tyvars, rhs_ids, rhs_body) + = collectTyAndValBinders (dropInline rhs) + -- It's important that we "see past" any INLINE pragma + -- else we'll fail to specialise an INLINE thing + rhs_dicts = take n_dicts rhs_ids - rhs_bndrs = map TyBinder rhs_tyvars ++ map ValBinder rhs_dicts - body = mkValLam (drop n_dicts rhs_ids) rhs_body + rhs_bndrs = rhs_tyvars ++ rhs_dicts + body = mkLams (drop n_dicts rhs_ids) rhs_body -- Glue back on the non-dict lambdas calls_for_me = case lookupFM calls fn of @@ -810,64 +832,84 @@ specDefn calls (fn, rhs) ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: ProtoUsageDetails -- From the original body, captured by - -- the dictionary lambdas - -> ([Maybe Type], [DictVar]) -- Call instance - -> SpecM ((Id,CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - ([TyVar], [Type], CoreExpr)) -- Info for the Id's SpecEnv - spec_call bound_uds (call_ts, call_ds) - = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts ) + 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 ) -- Calls are only recorded for properly-saturated applications - -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [d1, d2] - - -- Construct the new binding - -- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2 - -- and the type of this binder + -- 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] + + -- Construct the new binding + -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs) + -- PLUS the usage-details + -- { d1' = dx1; d2' = dx2 } + -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied. + -- + -- 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 - spec_tyvars = [tyvar | (tyvar, Nothing) <- tyVarTemplates `zip` call_ts] - spec_tys = mk_spec_tys call_ts - spec_rhs = mkTyLam spec_tyvars $ - mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds) - spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau) - ty_env = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys) + -- poly_tyvars = [b,d] 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 - - newIdSM fn spec_id_ty `thenSM` \ spec_f -> - - - -- Construct the stuff for f's spec env - -- [b,d] [t1,b,t3,d] |-> \d1 d2 -> f1 b d - -- The only awkward bit is that d1,d2 might well be global - -- dictionaries, so it's tidier to make new local variables - -- for the lambdas in the RHS, rather than lambda-bind the - -- dictionaries themselves. - -- - -- In fact we use the standard template locals, so that the - -- they don't need to be "tidied" before putting in interface files + cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') -> let - arg_ds = mkTemplateLocals (map idType call_ds) - spec_env_rhs = mkValLam arg_ds $ - mkTyApp (Var spec_f) $ - map mkTyVarTy spec_tyvars - spec_env_info = (spec_tyvars, spec_tys, spec_env_rhs) - in - - -- Specialise the UDs from f's RHS - let - -- Only the overloaded tyvars should be free in the uds - ty_env = [ (rhs_tyvar,ty) - | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts - ] - dict_env = zipEqual "specUDs2" rhs_dicts call_ds + 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 - specUDs ty_env dict_env bound_uds `thenSM` \ spec_uds -> + newIdSM fn spec_id_ty `thenSM` \ spec_f -> + specExpr rhs_subst' (mkLams lam_args body) `thenSM` \ (spec_rhs, rhs_uds) -> + 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) + + -- Add the { d1' = dx1; d2' = dx2 } usage stuff + final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds) + + -- NOTE: we don't add back in any INLINE pragma on the RHS, so even if + -- the original function said INLINE, the specialised copies won't. + -- The idea is that the point of inlining was precisely to specialise + -- the function at its call site, and that's not so important for the + -- specialised copies. But it still smells like an ad hoc decision. - returnSM ((spec_f, spec_rhs), - spec_uds, - spec_env_info - ) + in + returnSM ((spec_f, spec_rhs), + final_uds, + spec_env_rule) + + where + my_zipEqual doc xs ys + | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs) + | otherwise = zipEqual doc xs ys + +dropInline :: CoreExpr -> CoreExpr +dropInline (Note InlineMe rhs) = rhs +dropInline rhs = rhs \end{code} %************************************************************************ @@ -877,8 +919,6 @@ specDefn calls (fn, rhs) %************************************************************************ \begin{code} -type FreeDicts = IdSet - data UsageDetails = MkUD { dict_binds :: !(Bag DictBind), @@ -886,106 +926,152 @@ data UsageDetails -- The order is important; -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 -- (Remember, Bags preserve order in GHC.) - -- The FreeDicts is the free vars of the RHS calls :: !CallDetails } -type DictBind = (DictVar, CoreExpr, TyVarSet, FreeDicts) - -- The FreeDicts are the free dictionaries (only) - -- of the RHS of the dictionary bindings - -- Similarly the TyVarSet +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, [Maybe Type], [DictVar])] + [(Id, CallKey, ([DictExpr], VarSet))] ) ------------------------------------------------------------ type CallDetails = FiniteMap Id CallInfo -type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument - [DictVar] -- Dict args +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 -callDetailsToList calls = [ (id,tys,dicts) - | (id,fm) <- fmToList calls, - (tys,dicts) <- fmToList fm - ] +-- 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 } -listToCallDetails calls = foldr (unionCalls . singleCall) emptyFM calls +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 (Just t1) (Just t2) = tcCmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusFM_C plusFM c1 c2 -singleCall (id, tys, dicts) = unitFM id (unitFM tys dicts) +singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails +singleCall id tys dicts + = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)) + where + call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs + tys_fvs = tyVarsOfTypes (catMaybes tys) + -- The type args (tys) are guaranteed to be part of the dictionary + -- types, because they are just the constrained types, + -- and the dictionary is therefore sure to be bound + -- inside the binding for any type variables free in the type; + -- hence it's safe to neglect tyvars free in tys when making + -- the free-var set for this call + -- BUT I don't trust this reasoning; play safe and include tys_fvs + -- + -- 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 f args +mkCallUDs subst f args | null theta - || length spec_tys /= n_tyvars - || length dicts /= n_dicts - = emptyUDs -- 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 | otherwise = MkUD {dict_binds = emptyBag, - calls = singleCall (f, spec_tys, dicts) + calls = singleCall f spec_tys dicts } where - (tyvars, theta, tau) = splitSigmaTy (idType f) - constrained_tyvars = foldr (unionTyVarSets . tyVarsOfTypes . snd) emptyTyVarSet theta - n_tyvars = length tyvars - n_dicts = length theta + (tyvars, theta, _) = tcSplitSigmaTy (idType f) + constrained_tyvars = tyVarsOfTheta theta + n_tyvars = length tyvars + n_dicts = length theta - spec_tys = [mk_spec_ty tv ty | (tv, TyArg ty) <- tyvars `zip` args] - dicts = [d | (_, VarArg d) <- theta `zip` (drop n_tyvars args)] + spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args] + dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] - mk_spec_ty tyvar ty | tyvar `elementOfTyVarSet` constrained_tyvars - = Just ty - | otherwise - = Nothing + mk_spec_ty tyvar ty + | tyvar `elemVarSet` constrained_tyvars = Just ty + | otherwise = Nothing ------------------------------------------------------------ plusUDs :: UsageDetails -> UsageDetails -> UsageDetails plusUDs (MkUD {dict_binds = db1, calls = calls1}) (MkUD {dict_binds = db2, calls = calls2}) - = MkUD {dict_binds, calls} + = MkUD {dict_binds = d, calls = c} where - dict_binds = db1 `unionBags` db2 - calls = calls1 `unionCalls` calls2 + d = db1 `unionBags` db2 + c = calls1 `unionCalls` calls2 plusUDList = foldr plusUDs emptyUDs -mkDB dict rhs = (dict, rhs, db_ftvs, db_fvs) - where - db_ftvs = tyVarsOfType (idType dict) -- Superset of RHS fvs - db_fvs = dictRhsFVs rhs +-- zapCalls deletes calls to ids from uds +zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids} + +mkDB bind = (bind, bind_fvs bind) + +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) -addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds } +pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr + -- Don't forget variables mentioned in the + -- rules of the bndr. C.f. OccAnal.addRuleUsage + + +addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds } dumpAllDictBinds (MkUD {dict_binds = dbs}) binds = foldrBag add binds dbs where - add (dict,rhs,_,_) binds = NonRec dict rhs : binds - -mkDictBinds :: [DictBind] -> [CoreBinding] -mkDictBinds = map (\(d,r,_,_) -> NonRec d r) + add (bind,_) binds = bind : binds -mkDictLets :: [DictBind] -> CoreExpr -> CoreExpr -mkDictLets dbs body = foldr mk body dbs - where - mk (d,r,_,_) e = Let (NonRec d r) e - -dumpUDs :: [CoreBinder] +dumpUDs :: [CoreBndr] -> UsageDetails -> CoreExpr -> (UsageDetails, CoreExpr) dumpUDs bndrs uds body - = (free_uds, mkDictLets dict_binds body) + = (free_uds, foldr add_let body dict_binds) where (free_uds, (dict_binds, _)) = splitUDs bndrs uds + add_let (bind,_) body = Let bind body -splitUDs :: [CoreBinder] +splitUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, -- These don't mention the binders ProtoUsageDetails) -- These do @@ -1005,75 +1091,29 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, ) where - tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs] - id_set = mkIdSet [id | ValBinder id <- bndrs] + bndr_set = mkVarSet bndrs (free_dbs, dump_dbs, dump_idset) - = foldlBag dump_db (emptyBag, emptyBag, id_set) orig_dbs + = 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 - -- Don't need to worry about the tyvars because the dicts will - -- spot the captured ones; any fully polymorphic arguments will - -- be Nothings in the call details - orig_call_list = callDetailsToList orig_calls - (dump_calls, free_calls) = partition captured orig_call_list - captured (id,tys,dicts) = any (`elementOfIdSet` dump_idset) (id:dicts) - - dump_db (free_dbs, dump_dbs, dump_idset) db@(dict, rhs, ftvs, fvs) - | isEmptyIdSet (dump_idset `intersectIdSets` fvs) - && isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs) - = (free_dbs `snocBag` db, dump_dbs, dump_idset) + 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 - | otherwise -- Dump it + dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs) + | dump_idset `intersectsVarSet` fvs -- Dump it = (free_dbs, dump_dbs `snocBag` db, - dump_idset `addOneToIdSet` dict) -\end{code} - -Given a type and value substitution, specUDs creates a specialised copy of -the given UDs - -\begin{code} -specUDs :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails -specUDs tv_env_list dict_env_list (dbs, calls) - = specDBs dict_env_list dbs `thenSM` \ (dict_env_list', dbs') -> - let - dict_env = mkIdEnv dict_env_list' - in - returnSM (MkUD { dict_binds = dbs', - calls = listToCallDetails (map (inst_call dict_env) calls) - }) - where - bound_tyvars = mkTyVarSet (map fst tv_env_list) - tv_env = mkTyVarEnv tv_env_list -- Doesn't change + extendVarSetList dump_idset (bindersOf bind)) - inst_call dict_env (id, tys, dicts) = (id, map inst_maybe_ty tys, - map (lookupId dict_env) dicts) - - inst_maybe_ty Nothing = Nothing - inst_maybe_ty (Just ty) = Just (instantiateTy tv_env ty) - - specDBs dict_env [] - = returnSM (dict_env, emptyBag) - specDBs dict_env ((dict, rhs, ftvs, fvs) : dbs) - = newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' -> - let - rhs' = foldl App (foldr Lam rhs (t_bndrs ++ d_bndrs)) (t_args ++ d_args) - (t_bndrs, t_args) = unzip [(TyBinder tv, TyArg ty) | (tv,ty) <- tv_env_list, - tv `elementOfTyVarSet` ftvs] - (d_bndrs, d_args) = unzip [(ValBinder d, VarArg d') | (d,d') <- dict_env, - d `elementOfIdSet` fvs] - dict_env' = (dict,dict') : dict_env - ftvs' = tyVarsOfTypes [ty | TyArg ty <- t_args] `unionTyVarSets` - (ftvs `minusTyVarSet` bound_tyvars) - fvs' = mkIdSet [d | VarArg d <- d_args] `unionIdSets` - (fvs `minusIdSet` mkIdSet [d | ValBinder d <- d_bndrs]) - in - specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') -> - returnSM ( dict_env'', (dict', rhs', ftvs', fvs') `consBag` dbs' ) + | otherwise -- Don't dump it + = (free_dbs `snocBag` db, dump_dbs, dump_idset) \end{code} + %************************************************************************ %* * \subsubsection{Boring helper functions} @@ -1081,75 +1121,48 @@ specUDs tv_env_list dict_env_list (dbs, calls) %************************************************************************ \begin{code} -tyVarTemplates :: [TyVar] -tyVarTemplates = map mk [1..] - where - mk i = mkTyVar (mkSysLocalName uniq occ noSrcLoc) mkBoxedTypeKind - where - uniq = mkAlphaTyVarUnique i - occ = _PK_ ("$t" ++ show i) -\end{code} - -\begin{code} -lookupId:: IdEnv Id -> Id -> Id -lookupId env id = case lookupIdEnv env id of - Nothing -> id - Just id' -> id' - -dictRhsFVs :: CoreExpr -> IdSet -dictRhsFVs e = exprFreeVars isLocallyDefined e - -addIdSpecialisations id spec_stuff - = (if not (null errs) then - pprTrace "Duplicate specialisations" (vcat (map ppr errs)) - else \x -> x - ) - setIdSpecialisation id new_spec_env - where - (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff - - add (tyvars, tys, template) (spec_env, errs) - = case addToSpecEnv True spec_env tyvars tys template of - Succeeded spec_env' -> (spec_env', errs) - Failed err -> (spec_env, err:errs) - --- Given an Id, isSpecVars returns all its specialisations. --- We extract these from its SpecEnv. --- This is used by the occurrence analyser and free-var finder; --- we regard an Id's specialisations as free in the Id's definition. - -idSpecVars :: Id -> [Id] -idSpecVars id - = map get_spec (specEnvValues (getIdSpecialisation id)) - where - -- get_spec is another cheapo function like dictRhsFVs - -- It knows what these specialisation temlates look like, - -- and just goes for the jugular - get_spec (App f _) = get_spec f - get_spec (Lam _ b) = get_spec b - get_spec (Var v) = v - ----------------------------------------- type SpecM a = UniqSM a thenSM = thenUs returnSM = returnUs -getUniqSM = getUnique +getUniqSM = getUniqueUs mapSM = mapUs -initSM = initUs +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) +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 - = getUnique `thenSM` \ uniq -> - returnSM (mkUserLocal (getOccName old_id) - uniq - new_ty - (getSrcLoc old_id) - ) + = 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 (getSrcLoc name) + in + returnSM new_id \end{code}