X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=1d172e9728428599b1ff6c9c1898e4abbcaede0d;hb=c8898df0380dad4705353de00a48ea105d00bcc5;hp=0428772ca17cb06d6993cca4b7d5dcbefb4735a4;hpb=e0d750bedbd33f7a133c8c82c35fd8db537ab649;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 0428772..1d172e9 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -9,9 +9,9 @@ module Specialise ( specProgram ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..) ) -import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId ) +import Id ( Id, idName, idType, mkUserLocal ) import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, - tyVarsOfTypes, tyVarsOfTheta, + tyVarsOfTypes, tyVarsOfTheta, isClassPred, mkForAllTys, tcCmpType ) import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet, @@ -25,8 +25,8 @@ import VarEnv import CoreSyn import CoreUtils ( applyTypeToArgs ) import CoreFVs ( exprFreeVars, exprsFreeVars ) +import CoreTidy ( pprTidyIdRules ) import CoreLint ( showPass, endPass ) -import PprCore ( pprCoreRules ) import Rules ( addIdSpecialisations, lookupRule ) import UniqSupply ( UniqSupply, @@ -40,9 +40,10 @@ import ErrUtils ( dumpIfSet_dyn ) import BasicTypes ( Activation( AlwaysActive ) ) import Bag import List ( partition ) -import Util ( zipEqual, zipWithEqual, cmpList ) +import Util ( zipEqual, zipWithEqual, cmpList, lengthIs, + equalLength, lengthAtLeast, notNull ) import Outputable - +import FastString infixr 9 `thenSM` \end{code} @@ -585,7 +586,7 @@ specProgram dflags us binds endPass dflags "Specialise" Opt_D_dump_spec binds' dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations" - (vcat (map dump_specs (concat (map bindersOf binds')))) + (vcat (map pprTidyIdRules (concat (map bindersOf binds')))) return binds' where @@ -600,8 +601,6 @@ specProgram dflags us binds go (bind:binds) = go binds `thenSM` \ (binds', uds) -> specBind top_subst bind uds `thenSM` \ (bind', uds') -> returnSM (bind' ++ binds', uds') - -dump_specs var = pprCoreRules var (idSpecialisation var) \end{code} %************************************************************************ @@ -785,11 +784,9 @@ 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 - && not (isDataConWrapId fn) -- And it's not a data con wrapper, which have - -- stupid overloading that simply discard the dictionary + | 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 @@ -827,10 +824,10 @@ specDefn subst calls (fn, rhs) 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 - (inline_me, rhs') = dropInline rhs - (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs' rhs_dicts = take n_dicts rhs_ids rhs_bndrs = rhs_tyvars ++ rhs_dicts @@ -848,7 +845,7 @@ specDefn subst calls (fn, rhs) UsageDetails, -- Usage details from specialised body CoreRule) -- Info for the Id's SpecEnv spec_call (CallKey call_ts, (call_ds, call_fvs)) - = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts ) + = 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 @@ -888,7 +885,7 @@ 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 = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn))) + spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn))) AlwaysActive (poly_tyvars ++ rhs_dicts') inst_args @@ -910,12 +907,12 @@ specDefn subst calls (fn, rhs) 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) +dropInline :: CoreExpr -> CoreExpr +dropInline (Note InlineMe rhs) = rhs +dropInline rhs = rhs \end{code} %************************************************************************ @@ -1004,8 +1001,12 @@ callDetailsToList calls = [ (id,tys,dicts) mkCallUDs subst f args | null theta - || length spec_tys /= n_tyvars - || length dicts /= n_dicts + || 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 @@ -1026,10 +1027,9 @@ mkCallUDs subst f 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 `elemVarSet` constrained_tyvars - = Just ty - | otherwise - = Nothing + mk_spec_ty tyvar ty + | tyvar `elemVarSet` constrained_tyvars = Just ty + | otherwise = Nothing ------------------------------------------------------------ plusUDs :: UsageDetails -> UsageDetails -> UsageDetails @@ -1105,7 +1105,7 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, 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 `unionVarSet` mkVarSet (bindersOf bind)) + extendVarSetList dump_idset (bindersOf bind)) | otherwise -- Don't dump it = (free_dbs `snocBag` db, dump_dbs, dump_idset)