X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=d9502008cb8a775b4cd978ab69230c1fc3bb9280;hb=e3defabc698eb976504f750eee1258fe400a8352;hp=fad010bda5c1053b7abebb58debf612cf11efbd9;hpb=db95d6e8d319b0c5cee1ccc23751e8190152ade3;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index fad010b..d950200 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -8,21 +8,18 @@ module Specialise ( specProgram ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import Id ( Id, idName, idType, mkUserLocal, - idSpecialisation, modifyIdInfo - ) -import IdInfo ( zapSpecPragInfo ) -import VarSet -import VarEnv - -import Type ( Type, mkTyVarTy, splitSigmaTy, +import CmdLineOpts ( DynFlags, DynFlag(..) ) +import Id ( Id, idName, idType, mkUserLocal, idSpecialisation ) +import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, - mkForAllTys + mkForAllTys, tcCmpType ) -import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet, - substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope +import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet, + simplBndr, simplBndrs, + substAndCloneId, substAndCloneIds, substAndCloneRecIds, + lookupIdSubst, substInScope ) +import Var ( zapSpecPragmaId ) import VarSet import VarEnv import CoreSyn @@ -34,8 +31,8 @@ import PprCore ( pprCoreRules ) import Rules ( addIdSpecialisations, lookupRule ) import UniqSupply ( UniqSupply, - UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, - getUs, setUs, mapUs + UniqSM, initUs_, thenUs, returnUs, getUniqueUs, + getUs, mapUs ) import Name ( nameOccName, mkSpecOcc, getSrcLoc ) import FiniteMap @@ -43,7 +40,7 @@ import Maybes ( catMaybes, maybeToBool ) import ErrUtils ( dumpIfSet_dyn ) import Bag import List ( partition ) -import Util ( zipEqual, zipWithEqual ) +import Util ( zipEqual, zipWithEqual, cmpList ) import Outputable @@ -585,9 +582,7 @@ specProgram dflags us binds let binds' = initSM us (go binds `thenSM` \ (binds', uds') -> returnSM (dumpAllDictBinds uds' binds')) - endPass dflags "Specialise" - (dopt Opt_D_dump_spec dflags - || dopt Opt_D_verbose_core2core dflags) 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')))) @@ -660,7 +655,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 @@ -669,7 +664,7 @@ 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) @@ -679,7 +674,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) @@ -802,9 +797,9 @@ specDefn subst calls (fn, rhs) -- 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, @@ -815,13 +810,13 @@ 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, _) = splitSigmaTy fn_type + (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta @@ -837,11 +832,11 @@ specDefn subst calls (fn, rhs) ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: ([Maybe Type], ([DictExpr], VarSet)) -- 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)) + 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( length call_ts == n_tyvars && length call_ds == n_dicts ) -- Calls are only recorded for properly-saturated applications @@ -882,9 +877,10 @@ 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 (_PK_ ("SPEC " ++ showSDoc (ppr fn))) + (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) @@ -926,12 +922,13 @@ type DictExpr = CoreExpr emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM } type ProtoUsageDetails = ([DictBind], - [(Id, [Maybe Type], ([DictExpr], VarSet))] + [(Id, CallKey, ([DictExpr], VarSet))] ) ------------------------------------------------------------ type CallDetails = FiniteMap Id CallInfo -type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument +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] @@ -939,12 +936,25 @@ type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type ar -- 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)) + = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)) where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs tys_fvs = tyVarsOfTypes (catMaybes tys) @@ -966,7 +976,7 @@ listToCallDetails calls callDetailsToList calls = [ (id,tys,dicts) | (id,fm) <- fmToList calls, - (tys,dicts) <- fmToList fm + (tys, dicts) <- fmToList fm ] mkCallUDs subst f args @@ -985,7 +995,7 @@ mkCallUDs subst f args calls = singleCall f spec_tys dicts } where - (tyvars, theta, _) = splitSigmaTy (idType f) + (tyvars, theta, _) = tcSplitSigmaTy (idType f) constrained_tyvars = tyVarsOfTheta theta n_tyvars = length tyvars n_dicts = length theta @@ -1086,12 +1096,6 @@ 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 @@ -1109,29 +1113,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 ->