X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=006e06d15e99605149e8463bec211c4137f20b67;hb=687fa3b2ed2db125575dc7065d4b7044924e66a1;hp=d6f59f1773b6b5690af58a87767d076d8b528e55;hpb=30b5ebe424ebae69b162ac3fc547eb14d898535f;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index d6f59f1..006e06d 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -8,45 +8,42 @@ module Specialise ( specProgram ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec, opt_D_dump_rules ) -import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal, - getIdSpecialisation, setIdNoDiscard, isExportedId, - modifyIdInfo +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import Id ( Id, idName, idType, mkUserLocal ) +import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, + tyVarsOfTypes, tyVarsOfTheta, isClassPred, + mkForAllTys, tcCmpType ) -import IdInfo ( zapSpecPragInfo ) -import VarSet -import VarEnv - -import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN, - tyVarsOfType, tyVarsOfTypes, applyTys, - mkForAllTys, boxedTypeKind - ) -import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList, - substId, substAndCloneId, substAndCloneIds, lookupIdSubst +import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet, + simplBndr, simplBndrs, + substAndCloneId, substAndCloneIds, substAndCloneRecIds, + lookupIdSubst, substInScope ) -import Var ( TyVar, mkSysTyVar, setVarUnique ) +import Var ( zapSpecPragmaId ) import VarSet import VarEnv import CoreSyn -import CoreUtils ( coreExprType, applyTypeToArgs ) +import CoreUtils ( applyTypeToArgs ) import CoreFVs ( exprFreeVars, exprsFreeVars ) -import CoreLint ( beginPass, endPass ) -import PprCore ( pprCoreRules ) -import Rules ( addIdSpecialisations ) +import CoreTidy ( pprTidyIdRules ) +import CoreLint ( showPass, endPass ) +import Rules ( addIdSpecialisations, lookupRule ) import UniqSupply ( UniqSupply, - UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, - getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs + UniqSM, initUs_, thenUs, returnUs, getUniqueUs, + getUs, mapUs ) import Name ( nameOccName, mkSpecOcc, getSrcLoc ) import FiniteMap -import Maybes ( MaybeErr(..), catMaybes ) -import ErrUtils ( dumpIfSet ) +import Maybes ( catMaybes, maybeToBool ) +import ErrUtils ( dumpIfSet_dyn ) +import BasicTypes ( Activation( AlwaysActive ) ) import Bag import List ( partition ) -import Util ( zipEqual, zipWithEqual, mapAccumL ) +import Util ( zipEqual, zipWithEqual, cmpList, lengthIs, + equalLength, lengthAtLeast, notNull ) import Outputable - +import FastString infixr 9 `thenSM` \end{code} @@ -578,27 +575,32 @@ Hence, the invariant is this: %************************************************************************ \begin{code} -specProgram :: UniqSupply -> [CoreBind] -> IO [CoreBind] -specProgram us binds +specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind] +specProgram dflags us binds = do - beginPass "Specialise" + showPass dflags "Specialise" let binds' = initSM us (go binds `thenSM` \ (binds', uds') -> returnSM (dumpAllDictBinds uds' binds')) - endPass "Specialise" (opt_D_dump_spec || opt_D_verbose_core2core) binds' + endPass dflags "Specialise" Opt_D_dump_spec binds' - dumpIfSet opt_D_dump_rules "Top-level specialisations" - (vcat (map dump_specs (concat (map bindersOf binds')))) + dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations" + (vcat (map pprTidyIdRules (concat (map bindersOf 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 = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv + go [] = returnSM ([], emptyUDs) go (bind:binds) = go binds `thenSM` \ (binds', uds) -> - specBind emptySubst bind uds `thenSM` \ (bind', uds') -> + specBind top_subst bind uds `thenSM` \ (bind', uds') -> returnSM (bind' ++ binds', uds') - -dump_specs var = pprCoreRules var (getIdSpecialisation var) \end{code} %************************************************************************ @@ -623,10 +625,7 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) ---------------- 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 e@(Con con args) - = mapAndCombineSM (specExpr subst) args `thenSM` \ (args', uds) -> - returnSM (Con con args', uds) +specExpr subst (Lit lit) = returnSM (Lit lit, emptyUDs) specExpr subst (Note note body) = specExpr subst body `thenSM` \ (body', uds) -> @@ -642,7 +641,7 @@ specExpr subst expr@(App fun arg) returnSM (App fun' arg', uds_arg `plusUDs` uds_app) go (Var f) args = case specVar subst f of - Var f' -> returnSM (Var f', mkCallUDs f' args) + Var f' -> returnSM (Var f', mkCallUDs subst f' args) e' -> returnSM (e', emptyUDs) -- I don't expect this! go other args = specExpr subst other @@ -655,7 +654,7 @@ specExpr subst e@(Lam _ _) returnSM (mkLams bndrs' body'', filtered_uds) where (bndrs, body) = collectBinders e - (subst', bndrs') = substBndrs subst bndrs + (subst', bndrs') = simplBndrs 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 @@ -664,7 +663,8 @@ specExpr subst (Case scrut case_bndr alts) mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) -> returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts) where - (subst_alt, case_bndr') = substId subst case_bndr + (subst_alt, case_bndr') = simplBndr 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) -> @@ -673,7 +673,7 @@ specExpr subst (Case scrut case_bndr alts) in returnSM ((con, args', rhs''), uds') where - (subst_rhs, args') = substBndrs subst_alt args + (subst_rhs, args') = simplBndrs subst_alt args ---------------- Finally, let is the interesting case -------------------- specExpr subst (Let bind body) @@ -784,18 +784,26 @@ specDefn :: Subst -- Subst to use for 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 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_env_stuff) = unzip3 stuff + (spec_defns, spec_uds, spec_rules) = unzip3 stuff - fn' = addIdSpecialisations zapped_fn spec_env_stuff + fn' = addIdSpecialisations zapped_fn spec_rules in returnSM ((fn',rhs'), spec_defns, @@ -806,17 +814,21 @@ specDefn subst calls (fn, rhs) returnSM ((zapped_fn, rhs'), [], rhs_uds) where - zapped_fn = modifyIdInfo zapSpecPragInfo fn + zapped_fn = zapSpecPragmaId fn -- If the fn is a SpecPragmaId, make it discardable -- It's role as a holder for a call instance is o'er -- But it might be alive for some other reason by now. - fn_type = idType fn - (tyvars, theta, tau) = splitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta + fn_type = idType fn + (tyvars, theta, _) = tcSplitSigmaTy fn_type + n_tyvars = length tyvars + n_dicts = length theta + + -- It's important that we "see past" any INLINE pragma + -- else we'll fail to specialise an INLINE thing + (inline_me, rhs') = dropInline rhs + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs' - (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs rhs_dicts = take n_dicts rhs_ids rhs_bndrs = rhs_tyvars ++ rhs_dicts body = mkLams (drop n_dicts rhs_ids) rhs_body @@ -828,12 +840,12 @@ specDefn subst calls (fn, rhs) ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: ([Maybe Type], ([DictExpr], IdOrTyVarSet)) -- Call instance - -> SpecM ((Id,CoreExpr), -- Specialised definition - UsageDetails, -- Usage details from specialised body - ([CoreBndr], [CoreExpr], CoreExpr)) -- Info for the Id's SpecEnv - spec_call (call_ts, (call_ds, call_fvs)) - = 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 -- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs @@ -873,21 +885,34 @@ specDefn subst calls (fn, rhs) 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 = (poly_tyvars ++ rhs_dicts', - inst_args, - mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars)) + spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn))) + AlwaysActive + (poly_tyvars ++ rhs_dicts') + inst_args + (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars)) -- 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. + in - returnSM ((spec_f, spec_rhs), + returnSM ((spec_f, spec_rhs), final_uds, spec_env_rule) where my_zipEqual doc xs ys - | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs) - | otherwise = 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 -> (Bool, CoreExpr) +dropInline (Note InlineMe rhs) = (True, rhs) +dropInline rhs = (False, rhs) \end{code} %************************************************************************ @@ -908,7 +933,7 @@ data UsageDetails calls :: !CallDetails } -type DictBind = (CoreBind, IdOrTyVarSet) +type DictBind = (CoreBind, VarSet) -- The set is the free vars of the binding -- both tyvars and dicts @@ -917,25 +942,39 @@ type DictExpr = CoreExpr emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM } type ProtoUsageDetails = ([DictBind], - [(Id, [Maybe Type], ([DictExpr], IdOrTyVarSet))] + [(Id, CallKey, ([DictExpr], VarSet))] ) ------------------------------------------------------------ type CallDetails = FiniteMap Id CallInfo -type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument - ([DictExpr], IdOrTyVarSet) -- Dict args and the vars of the whole +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 +-- 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 } + +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, [Maybe Type], [DictExpr]) -> CallDetails -singleCall (id, tys, dicts) - = unitFM id (unitFM tys (dicts, call_fvs)) +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) @@ -957,32 +996,40 @@ listToCallDetails calls callDetailsToList calls = [ (id,tys,dicts) | (id,fm) <- fmToList calls, - (tys,dicts) <- fmToList fm + (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) 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 (unionVarSet . tyVarsOfTypes . snd) emptyVarSet 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, Type ty) <- tyvars `zip` args] dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] - mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars - = Just ty - | otherwise - = Nothing + mk_spec_ty tyvar ty + | tyvar `elemVarSet` constrained_tyvars = Just ty + | otherwise = Nothing ------------------------------------------------------------ plusUDs :: UsageDetails -> UsageDetails -> UsageDetails @@ -1072,20 +1119,11 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, %************************************************************************ \begin{code} -lookupId:: IdEnv Id -> Id -> Id -lookupId env id = case lookupVarEnv env id of - Nothing -> id - Just id' -> id' - ----------------------------------------- type SpecM a = UniqSM a thenSM = thenUs -thenSM_ = thenUs_ returnSM = returnUs getUniqSM = getUniqueUs -getUniqSupplySM = getUs -setUniqSupplySM = setUs mapSM = mapUs initSM = initUs_ @@ -1098,29 +1136,22 @@ 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 -> + = getUs `thenUs` \ us -> let - (subst', us', bndr') = substAndCloneId subst us bndr + (subst', bndr') = substAndCloneId subst us bndr in - setUs us' `thenUs_` returnUs (subst, subst', NonRec bndr' rhs) cloneBindSM subst (Rec pairs) - = getUs `thenUs` \ us -> + = getUs `thenUs` \ us -> let - (subst', us', bndrs') = substAndCloneIds subst us (map fst pairs) + (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs) in - setUs us' `thenUs_` returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs)) cloneBinders subst bndrs - = getUs `thenUs` \ us -> - let - (subst', us', bndrs') = substAndCloneIds subst us bndrs - in - setUs us' `thenUs_` - returnUs (subst', bndrs') - + = getUs `thenUs` \ us -> + returnUs (substAndCloneIds subst us bndrs) newIdSM old_id new_ty = getUniqSM `thenSM` \ uniq -> @@ -1128,17 +1159,8 @@ newIdSM old_id new_ty -- 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) - - -- If the old Id was exported, make the new one non-discardable, - -- else we will discard it since it doesn't seem to be called. - new_id' | isExportedId old_id = setIdNoDiscard new_id - | otherwise = new_id in - returnSM new_id' - -newTyVarSM - = getUniqSM `thenSM` \ uniq -> - returnSM (mkSysTyVar uniq boxedTypeKind) + returnSM new_id \end{code}