Commit 36d22a1c authored by simonpj's avatar simonpj
Browse files

[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 = <expression>
	...bindings...
	x_exported = x_local

where x_exported is exported, and x_local is not, then we
replace it with this:

	x_exported = <expression>
	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)
parent 30d8d383
......@@ -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)
......
......@@ -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}
......@@ -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
......
......@@ -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}
......
......@@ -19,7 +19,6 @@ import IlxGen ( ilxGen )
#ifdef JAVA
import JavaGen ( javaGen )
import OccurAnal ( occurAnalyseBinds )
import qualified PrintJava
import OccurAnal ( occurAnalyseBinds )
#endif
......
......@@ -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
......@@ -69,149 +81,6 @@ occurAnalyseRule (Rule str act tpl_vars tpl_args rhs)
\end{code}
%************************************************************************
%* *
\subsection{Top level stuff}
%* *
%************************************************************************
In @occAnalTop@ we do indirection-shorting. That is, if we have this:
x_local = <expression>
...
x_exported = loc
where exp is exported, and loc is not, then we replace it with this:
x_local = x_exported
x_exported = <expression>
...
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
......
......@@ -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 = <expression>
...bindings...
x_exported = x_local
where x_exported is exported, and x_local is not, then we replace it with this:
x_exported = <expression>
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}
......@@ -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.