From 36d22a1cb608e8572776ab6d402fd0c1a9287dc5 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 7 Mar 2005 16:46:24 +0000 Subject: [PATCH] [project @ 2005-03-07 16:46:08 by simonpj] ----------------------------------------- Fix a long-standing indirection-zapping bug ----------------------------------------- Merge to STABLE Up to now we zap indirections as part of the occurence analyser. But this is bogus. The indirection zapper does the following: x_local = ...bindings... x_exported = x_local where x_exported is exported, and x_local is not, then we replace it with this: x_exported = x_local = x_exported ...bindings... But this is plain wrong if x_exported has a RULE that mentions something (f, say) in ...bindings.., because 'f' will then die. After hacking a few solutions, I've eventually simply made the indirection zapping into a separate pass (which is cleaner anyway), which wraps the entire program back into a single Rec if the bad thing can happen. On the way I've made indirection-zapping work in Recs too, which wasn't the case before. * Move the zapper from OccurAnal into SimplCore * Tidy up the printing of pragmas (PprCore and friends) * Add a new function Rules.addRules * Merge rules in the indirection zapper (previously one set was discarded) --- ghc/compiler/basicTypes/BasicTypes.lhs | 10 +- ghc/compiler/basicTypes/IdInfo.lhs | 70 +---------- ghc/compiler/basicTypes/MkId.lhs | 4 +- ghc/compiler/coreSyn/PprCore.lhs | 8 +- ghc/compiler/main/CodeOutput.lhs | 1 - ghc/compiler/simplCore/OccurAnal.lhs | 172 ++++--------------------- ghc/compiler/simplCore/SimplCore.lhs | 214 +++++++++++++++++++++++++++++++- ghc/compiler/specialise/Rules.lhs | 9 +- 8 files changed, 250 insertions(+), 238 deletions(-) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index bce1fa0..b0b3bc1 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -374,11 +374,11 @@ isFragileOcc other = False instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 ppr NoOccInfo = empty - ppr IAmALoopBreaker = ptext SLIT("_Kx") - ppr IAmDead = ptext SLIT("_Kd") - ppr (OneOcc inside_lam one_branch) | inside_lam = ptext SLIT("_Kl") - | one_branch = ptext SLIT("_Ks") - | otherwise = ptext SLIT("_Ks*") + ppr IAmALoopBreaker = ptext SLIT("LoopBreaker") + ppr IAmDead = ptext SLIT("Dead") + ppr (OneOcc inside_lam one_branch) | inside_lam = ptext SLIT("OnceInLam") + | one_branch = ptext SLIT("Once") + | otherwise = ptext SLIT("OnceEachBranch") instance Show OccInfo where showsPrec p occ = showsPrecSDoc p (ppr occ) diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 54578ae..88d0f3d 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -16,7 +16,6 @@ module IdInfo ( -- Zapping zapLamInfo, zapDemandInfo, - shortableIdInfo, copyIdInfo, -- Arity ArityInfo, @@ -481,7 +480,7 @@ seqWorker (HasWorker id a) = id `seq` a `seq` () seqWorker NoWorker = () ppWorkerInfo NoWorker = empty -ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("__P") <+> ppr wk_id +ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id workerExists :: WorkerInfo -> Bool workerExists NoWorker = False @@ -654,70 +653,3 @@ zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) | otherwise = Nothing \end{code} - -copyIdInfo is used when shorting out a top-level binding - f_local = BIG - f = f_local -where f is exported. We are going to swizzle it around to - f = BIG - f_local = f - -BUT (a) we must be careful about messing up rules - (b) we must ensure f's IdInfo ends up right - -(a) Messing up the rules -~~~~~~~~~~~~~~~~~~~~ -The example that went bad on me was this one: - - iterate :: (a -> a) -> a -> [a] - iterate = iterateList - - iterateFB c f x = x `c` iterateFB c f (f x) - iterateList f x = x : iterateList f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList - #-} - -This got shorted out to: - - iterateList :: (a -> a) -> a -> [a] - iterateList = iterate - - iterateFB c f x = x `c` iterateFB c f (f x) - iterate f x = x : iterate f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate - #-} - -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x - -Tiresome solution: don't do shorting out if f has rewrite rules. -Hence shortableIdInfo. - -(b) Keeping the IdInfo right -~~~~~~~~~~~~~~~~~~~~~~~~ -We want to move strictness/worker info from f_local to f, but keep the rest. -Hence copyIdInfo. - -\begin{code} -shortableIdInfo :: IdInfo -> Bool -shortableIdInfo info = isEmptyCoreRules (specInfo info) - -copyIdInfo :: IdInfo -- f_local - -> IdInfo -- f (the exported one) - -> IdInfo -- New info for f -copyIdInfo f_local f = f { newStrictnessInfo = newStrictnessInfo f_local, -#ifdef OLD_STRICTNESS - strictnessInfo = strictnessInfo f_local, - cprInfo = cprInfo f_local, -#endif - workerInfo = workerInfo f_local - } -\end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 50e981b..fa3f24a 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -42,7 +42,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, ) import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) -import Rules ( addRule ) +import Rules ( addRules ) import Type ( TyThing(..) ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred, @@ -669,7 +669,7 @@ mkPrimOpId prim_op `setArityInfo` arity `setAllStrictnessInfo` Just strict_sig - rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op) + rules = addRules id emptyCoreRules (primOpRules prim_op) -- For each ccall we manufacture a separate CCallOpId, giving it diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 04aeb5c..22ee21b 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -321,7 +321,8 @@ pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo b info - = hsep [ ppArityInfo a, + = brackets $ + vcat [ ppArityInfo a, ppWorkerInfo (workerInfo info), ppCafInfo (cafInfo info), #ifdef OLD_STRICTNESS @@ -329,7 +330,8 @@ ppIdInfo b info ppCprInfo m, #endif pprNewStrictness (newStrictnessInfo info), - vcat (map (pprCoreRule (ppr b)) (rulesRules p)) + if null rules then empty + else ptext SLIT("RULES:") <+> vcat (map (pprCoreRule (ppr b)) rules) -- Inline pragma, occ, demand, lbvar info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr @@ -340,7 +342,7 @@ ppIdInfo b info s = strictnessInfo info m = cprInfo info #endif - p = specInfo info + rules = rulesRules (specInfo info) \end{code} diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 5f7f395..b01b668 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -19,7 +19,6 @@ import IlxGen ( ilxGen ) #ifdef JAVA import JavaGen ( javaGen ) -import OccurAnal ( occurAnalyseBinds ) import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index bc45bef..8b6c5bb 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -12,7 +12,7 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule + occurAnalysePgm, occurAnalyseGlobalExpr, occurAnalyseRule, ) where #include "HsVersions.h" @@ -22,11 +22,9 @@ import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial ) import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda, idOccInfo, setIdOccInfo, - isExportedId, modifyIdInfo, idInfo, idArity, - idSpecialisation, isLocalId, + isExportedId, idArity, idSpecialisation, idType, idUnique, Id ) -import IdInfo ( copyIdInfo ) import BasicTypes ( OccInfo(..), isOneOcc ) import VarSet @@ -52,6 +50,20 @@ import Outputable Here's the externally-callable interface: \begin{code} +occurAnalysePgm :: [CoreBind] -> [CoreBind] +occurAnalysePgm binds + = snd (go (initOccEnv emptyVarSet) binds) + where + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) + go env [] + = (emptyDetails, []) + go env (bind:binds) + = (final_usage, bind' ++ binds') + where + new_env = env `addNewCands` (bindersOf bind) + (bs_usage, binds') = go new_env binds + (final_usage, bind') = occAnalBind env bind bs_usage + occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and @@ -71,149 +83,6 @@ occurAnalyseRule (Rule str act tpl_vars tpl_args rhs) %************************************************************************ %* * -\subsection{Top level stuff} -%* * -%************************************************************************ - -In @occAnalTop@ we do indirection-shorting. That is, if we have this: - - x_local = - ... - x_exported = loc - -where exp is exported, and loc is not, then we replace it with this: - - x_local = x_exported - x_exported = - ... - -Without this we never get rid of the x_exported = x_local thing. This -save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and -makes strictness information propagate better. This used to happen in -the final phase, but it's tidier to do it here. - -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} -Hence,there's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might elminate a binding that's mentioned in the -unfolding for something. - -\begin{code} -occurAnalyseBinds :: [CoreBind] -> [CoreBind] - -occurAnalyseBinds binds - = binds' - where - (_, _, binds') = go (initOccEnv emptyVarSet) binds - - go :: OccEnv -> [CoreBind] - -> (UsageDetails, -- Occurrence info - IdEnv Id, -- Indirection elimination info - -- Maps local-id -> exported-id, but it embodies - -- bindings of the form exported-id = local-id in - -- the argument to go - [CoreBind]) -- Occ-analysed bindings, less the exported-id=local-id ones - - go env [] = (emptyDetails, emptyVarEnv, []) - - go env (bind : binds) - = let - new_env = env `addNewCands` (bindersOf bind) - (scope_usage, ind_env, binds') = go new_env binds - (final_usage, new_binds) = occAnalBind env (zapBind ind_env bind) scope_usage - -- NB: I zap before occur-analysing, so - -- I don't need to worry about getting the - -- occ info on the new bindings right. - in - case bind of - NonRec exported_id (Var local_id) - | shortMeOut ind_env exported_id local_id - -- Special case for eliminating indirections - -- Note: it's a shortcoming that this only works for - -- non-recursive bindings. Elminating indirections - -- makes perfect sense for recursive bindings too, but - -- it's more complicated to implement, so I haven't done so - -> (scope_usage, ind_env', binds') - where - ind_env' = extendVarEnv ind_env local_id exported_id - - other -> -- Ho ho! The normal case - (final_usage, ind_env, new_binds ++ binds') - - --- Deal with any indirections -zapBind ind_env (NonRec bndr rhs) - | bndr `elemVarEnv` ind_env = Rec (zap ind_env (bndr,rhs)) - -- The Rec isn't strictly necessary, but it's convenient -zapBind ind_env (Rec pairs) - | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map (zap ind_env) pairs)) - -zapBind ind_env bind = bind - -zap ind_env pair@(local_id,rhs) - = case lookupVarEnv ind_env local_id of - Nothing -> [pair] - Just exported_id -> [(local_id, Var exported_id), - (exported_id', rhs)] - where - exported_id' = modifyIdInfo (copyIdInfo (idInfo local_id)) exported_id - -shortMeOut ind_env exported_id local_id --- The if-then-else stuff is just so I can get a pprTrace to see --- how often I don't get shorting out becuase of IdInfo stuff - = if isExportedId exported_id && -- Only if this is exported - - isLocalId local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for - then - True - -{- No longer needed - if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable' - -- (see the defn of IdInfo.shortableIdInfo) - then True - else -#ifdef DEBUG - pprTrace "shortMeOut:" (ppr exported_id) -#endif - False --} - else - False -\end{code} - - -%************************************************************************ -%* * \subsection[OccurAnal-main]{Counting occurrences: main function} %* * %************************************************************************ @@ -537,11 +406,16 @@ occAnalRhs env id rhs -- dies (because it isn't referenced any more), then the children will -- die too unless they are already referenced directly. - final_usage = foldVarSet add rhs_usage (idRuleVars id) + final_usage = addRuleUsage rhs_usage id + +addRuleUsage :: UsageDetails -> Id -> UsageDetails +-- Add the usage from RULES in Id to the usage +addRuleUsage usage id + = foldVarSet add usage (idRuleVars id) + where add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info -- (i.e manyOcc) because many copies -- of the specialised thing can appear - \end{code} Expressions diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 32c6978..8b2118a 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -15,14 +15,16 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), import CoreSyn import TcIface ( loadImportedRules ) import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..), - ModDetails(..), HomeModInfo(..), HomePackageTable, Dependencies( dep_mods ), + Dependencies( dep_mods ), hscEPS, hptRules ) import CSE ( cseProgram ) import Rules ( RuleBase, ruleBaseIds, emptyRuleBase, extendRuleBaseList, pprRuleBase, ruleCheckProgram ) -import Module ( elemModuleEnv, lookupModuleEnv ) import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) -import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr ) +import OccurAnal ( occurAnalysePgm, occurAnalyseGlobalExpr ) +import IdInfo ( setNewStrictnessInfo, newStrictnessInfo, + setWorkerInfo, workerInfo, + setSpecInfo, specInfo ) import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet ) @@ -32,8 +34,11 @@ import CoreLint ( endPass ) import VarEnv ( mkInScopeSet ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( idIsFrom, idSpecialisation, setIdSpecialisation ) +import Id ( Id, modifyIdInfo, idInfo, idIsFrom, isExportedId, isLocalId, + idSpecialisation, setIdSpecialisation ) +import Rules ( addRules ) import VarSet +import VarEnv import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) @@ -49,7 +54,7 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) import Outputable import List ( partition ) -import Maybes ( orElse, fromJust ) +import Maybes ( orElse ) \end{code} %************************************************************************ @@ -444,7 +449,11 @@ simplifyPgm mode switches hsc_env us rule_base guts | let sz = coreBindsSize (mg_binds guts) in sz == sz = do { -- Occurrence analysis - let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ; + let { short_inds = _scc_ "ZapInd" shortOutIndirections (mg_binds guts) ; + tagged_binds = _scc_ "OccAnal" occurAnalysePgm short_inds } ; + + dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Short indirections" + (pprCoreBindings short_inds); dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); @@ -504,3 +513,196 @@ simplifyPgm mode switches hsc_env us rule_base guts where (us1, us2) = splitUniqSupply us \end{code} + + +%************************************************************************ +%* * + Top-level occurrence analysis + [In here, not OccurAnal, because it uses + Rules.lhs, which depends on OccurAnal] +%* * +%************************************************************************ + +In @occAnalPgm@ we do indirection-shorting. That is, if we have this: + + x_local = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + x_local = x_exported + ...bindings... + +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. + +STRICTNESS: if we have done strictness analysis, we want the strictness info on +x_local to transfer to x_exported. Hence the copyIdInfo call. + +RULES: we want to *add* any RULES for x_local to x_exported. + +Note [Rules and indirection-zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Messing up the rules +~~~~~~~~~~~~~~~~~~~~ +The example that went bad on me at one stage was this one: + + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x + +Tiresome old solution: + don't do shorting out if f has rewrite rules (see shortableIdInfo) + +New solution (I think): + use rule switching-off pragmas to get rid + of iterateList in the first place + + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might elminate a binding that's mentioned in the +unfolding for something. + +\begin{code} +type IndEnv = IdEnv Id -- Maps local_id -> exported_id + +shortOutIndirections :: [CoreBind] -> [CoreBind] +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' + | otherwise = [Rec (flattenBinds binds')] -- See Note [Rules and indirect-zapping] + where + ind_env = makeIndEnv binds + exp_ids = varSetElems ind_env + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . rulesRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set = [] + | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs), + (bndr, Var exp_id)] + | otherwise = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldr add_bind emptyVarEnv binds + where + add_bind :: CoreBind -> IndEnv -> IndEnv + add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env + add_bind (Rec pairs) env = foldr add_pair env pairs + + add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv + add_pair (exported_id, Var local_id) env + | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id + add_pair (exported_id, rhs) env + = env + +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out becuase of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + True + +{- No longer needed + if isEmptyCoreRules (specInfo (idInfo exported_id)) -- Only if no rules + then True -- See note on "Messing up rules" + else +#ifdef DEBUG + pprTrace "shortMeOut:" (ppr exported_id) +#endif + False +-} + else + False + + +----------------- +transferIdInfo :: Id -> Id -> Id +transferIdInfo exported_id local_id + = modifyIdInfo transfer exported_id + where + local_info = idInfo local_id + transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info + `setWorkerInfo` workerInfo local_info + `setSpecInfo` addRules exported_id (specInfo exp_info) + (rulesRules (specInfo local_info)) +\end{code} diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 67e68a8..e66e048 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -9,7 +9,7 @@ module Rules ( extendRuleBaseList, ruleBaseIds, pprRuleBase, ruleCheckProgram, - lookupRule, addRule, addIdSpecialisations + lookupRule, addRule, addRules, addIdSpecialisations ) where #include "HsVersions.h" @@ -347,7 +347,8 @@ match_ty menv (tv_subst, id_subst) ty1 ty2 %************************************************************************ \begin{code} -addRule :: Id -> CoreRules -> CoreRule -> CoreRules +addRules :: Id -> CoreRules -> [CoreRule] -> CoreRules +addRule :: Id -> CoreRules -> CoreRule -> CoreRules -- Add a new rule to an existing bunch of rules. -- The rules are for the given Id; the Id argument is needed only @@ -361,6 +362,8 @@ addRule :: Id -> CoreRules -> CoreRule -> CoreRules -- We make no check for rules that unify without one dominating -- the other. Arguably this would be a bug. +addRules id rules rule_list = foldl (addRule id) rules rule_list + addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _) = Rules (rule:rules) rhs_fvs -- Put it at the start for lack of anything better @@ -393,7 +396,7 @@ addIdSpecialisations :: Id -> [CoreRule] -> Id addIdSpecialisations id rules = setIdSpecialisation id new_specs where - new_specs = foldl (addRule id) (idSpecialisation id) rules + new_specs = addRules id (idSpecialisation id) rules \end{code} -- 1.7.10.4