Commit e79c9ce0 authored by Simon Marlow's avatar Simon Marlow

Rollback INLINE patches

rolling back:

Fri Dec  5 16:54:00 GMT 2008  simonpj@microsoft.com
  * Completely new treatment of INLINE pragmas (big patch)
  
  This is a major patch, which changes the way INLINE pragmas work.
  Although lots of files are touched, the net is only +21 lines of
  code -- and I bet that most of those are comments!
  
  HEADS UP: interface file format has changed, so you'll need to
  recompile everything.
  
  There is not much effect on overall performance for nofib, 
  probably because those programs don't make heavy use of INLINE pragmas.
  
          Program           Size    Allocs   Runtime   Elapsed
              Min         -11.3%     -6.9%     -9.2%     -8.2%
              Max          -0.1%     +4.6%     +7.5%     +8.9%
   Geometric Mean          -2.2%     -0.2%     -1.0%     -0.8%
  
  (The +4.6% for on allocs is cichelli; see other patch relating to
  -fpass-case-bndr-to-join-points.)
  
  The old INLINE system
  ~~~~~~~~~~~~~~~~~~~~~
  The old system worked like this. A function with an INLINE pragam
  got a right-hand side which looked like
       f = __inline_me__ (\xy. e)
  The __inline_me__ part was an InlineNote, and was treated specially
  in various ways.  Notably, the simplifier didn't inline inside an
  __inline_me__ note.  
  
  As a result, the code for f itself was pretty crappy. That matters
  if you say (map f xs), because then you execute the code for f,
  rather than inlining a copy at the call site.
  
  The new story: InlineRules
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
  The new system removes the InlineMe Note altogether.  Instead there
  is a new constructor InlineRule in CoreSyn.Unfolding.  This is a 
  bit like a RULE, in that it remembers the template to be inlined inside
  the InlineRule.  No simplification or inlining is done on an InlineRule,
  just like RULEs.  
  
  An Id can have an InlineRule *or* a CoreUnfolding (since these are two
  constructors from Unfolding). The simplifier treats them differently:
  
    - An InlineRule is has the substitution applied (like RULES) but 
      is otherwise left undisturbed.
  
    - A CoreUnfolding is updated with the new RHS of the definition,
      on each iteration of the simplifier.
  
  An InlineRule fires regardless of size, but *only* when the function
  is applied to enough arguments.  The "arity" of the rule is specified
  (by the programmer) as the number of args on the LHS of the "=".  So
  it makes a difference whether you say
    	{-# INLINE f #-}
  	f x = \y -> e     or     f x y = e
  This is one of the big new features that InlineRule gives us, and it
  is one that Roman really wanted.
  
  In contrast, a CoreUnfolding can fire when it is applied to fewer
  args than than the function has lambdas, provided the result is small
  enough.
  
  
  Consequential stuff
  ~~~~~~~~~~~~~~~~~~~
  * A 'wrapper' no longer has a WrapperInfo in the IdInfo.  Instead,
    the InlineRule has a field identifying wrappers.
  
  * Of course, IfaceSyn and interface serialisation changes appropriately.
  
  * Making implication constraints inline nicely was a bit fiddly. In
    the end I added a var_inline field to HsBInd.VarBind, which is why
    this patch affects the type checker slightly
  
  * I made some changes to the way in which eta expansion happens in
    CorePrep, mainly to ensure that *arguments* that become let-bound
    are also eta-expanded.  I'm still not too happy with the clarity
    and robustness fo the result.
  
  * We now complain if the programmer gives an INLINE pragma for
    a recursive function (prevsiously we just ignored it).  Reason for
    change: we don't want an InlineRule on a LoopBreaker, because then
    we'd have to check for loop-breaker-hood at occurrence sites (which
    isn't currenlty done).  Some tests need changing as a result.
  
  This patch has been in my tree for quite a while, so there are
  probably some other minor changes.
  

    M ./compiler/basicTypes/Id.lhs -11
    M ./compiler/basicTypes/IdInfo.lhs -82
    M ./compiler/basicTypes/MkId.lhs -2 +2
    M ./compiler/coreSyn/CoreFVs.lhs -2 +25
    M ./compiler/coreSyn/CoreLint.lhs -5 +1
    M ./compiler/coreSyn/CorePrep.lhs -59 +53
    M ./compiler/coreSyn/CoreSubst.lhs -22 +31
    M ./compiler/coreSyn/CoreSyn.lhs -66 +92
    M ./compiler/coreSyn/CoreUnfold.lhs -112 +112
    M ./compiler/coreSyn/CoreUtils.lhs -185 +184
    M ./compiler/coreSyn/MkExternalCore.lhs -1
    M ./compiler/coreSyn/PprCore.lhs -4 +40
    M ./compiler/deSugar/DsBinds.lhs -70 +118
    M ./compiler/deSugar/DsForeign.lhs -2 +4
    M ./compiler/deSugar/DsMeta.hs -4 +3
    M ./compiler/hsSyn/HsBinds.lhs -3 +3
    M ./compiler/hsSyn/HsUtils.lhs -2 +7
    M ./compiler/iface/BinIface.hs -11 +25
    M ./compiler/iface/IfaceSyn.lhs -13 +21
    M ./compiler/iface/MkIface.lhs -24 +19
    M ./compiler/iface/TcIface.lhs -29 +23
    M ./compiler/main/TidyPgm.lhs -55 +49
    M ./compiler/parser/ParserCore.y -5 +6
    M ./compiler/simplCore/CSE.lhs -2 +1
    M ./compiler/simplCore/FloatIn.lhs -6 +1
    M ./compiler/simplCore/FloatOut.lhs -23
    M ./compiler/simplCore/OccurAnal.lhs -36 +5
    M ./compiler/simplCore/SetLevels.lhs -59 +54
    M ./compiler/simplCore/SimplCore.lhs -48 +52
    M ./compiler/simplCore/SimplEnv.lhs -26 +22
    M ./compiler/simplCore/SimplUtils.lhs -28 +4
    M ./compiler/simplCore/Simplify.lhs -91 +109
    M ./compiler/specialise/Specialise.lhs -15 +18
    M ./compiler/stranal/WorkWrap.lhs -14 +11
    M ./compiler/stranal/WwLib.lhs -2 +2
    M ./compiler/typecheck/Inst.lhs -1 +3
    M ./compiler/typecheck/TcBinds.lhs -17 +27
    M ./compiler/typecheck/TcClassDcl.lhs -1 +2
    M ./compiler/typecheck/TcExpr.lhs -4 +6
    M ./compiler/typecheck/TcForeign.lhs -1 +1
    M ./compiler/typecheck/TcGenDeriv.lhs -14 +13
    M ./compiler/typecheck/TcHsSyn.lhs -3 +2
    M ./compiler/typecheck/TcInstDcls.lhs -5 +4
    M ./compiler/typecheck/TcRnDriver.lhs -2 +11
    M ./compiler/typecheck/TcSimplify.lhs -10 +17
    M ./compiler/vectorise/VectType.hs +7

Mon Dec  8 12:43:10 GMT 2008  simonpj@microsoft.com
  * White space only

    M ./compiler/simplCore/Simplify.lhs -2

Mon Dec  8 12:48:40 GMT 2008  simonpj@microsoft.com
  * Move simpleOptExpr from CoreUnfold to CoreSubst

    M ./compiler/coreSyn/CoreSubst.lhs -1 +87
    M ./compiler/coreSyn/CoreUnfold.lhs -72 +1

Mon Dec  8 17:30:18 GMT 2008  simonpj@microsoft.com
  * Use CoreSubst.simpleOptExpr in place of the ad-hoc simpleSubst (reduces code too)

    M ./compiler/deSugar/DsBinds.lhs -50 +16

Tue Dec  9 17:03:02 GMT 2008  simonpj@microsoft.com
  * Fix Trac #2861: bogus eta expansion
  
  Urghlhl!  I "tided up" the treatment of the "state hack" in CoreUtils, but
  missed an unexpected interaction with the way that a bottoming function
  simply swallows excess arguments.  There's a long
       Note [State hack and bottoming functions]
  to explain (which accounts for most of the new lines of code).
  

    M ./compiler/coreSyn/CoreUtils.lhs -16 +53

Mon Dec 15 10:02:21 GMT 2008  Simon Marlow <marlowsd@gmail.com>
  * Revert CorePrep part of "Completely new treatment of INLINE pragmas..."
  
  The original patch said:
  
  * I made some changes to the way in which eta expansion happens in
    CorePrep, mainly to ensure that *arguments* that become let-bound
    are also eta-expanded.  I'm still not too happy with the clarity
    and robustness fo the result.
    
  Unfortunately this change apparently broke some invariants that were
  relied on elsewhere, and in particular lead to panics when compiling
  with profiling on.
  
  Will re-investigate in the new year.

    M ./compiler/coreSyn/CorePrep.lhs -53 +58
    M ./configure.ac -1 +1

Mon Dec 15 12:28:51 GMT 2008  Simon Marlow <marlowsd@gmail.com>
  * revert accidental change to configure.ac

    M ./configure.ac -1 +1
parent 6ccd648b
......@@ -68,6 +68,7 @@ module Id (
idArity,
idNewDemandInfo, idNewDemandInfo_maybe,
idNewStrictness, idNewStrictness_maybe,
idWorkerInfo,
idUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
......@@ -85,6 +86,7 @@ module Id (
setIdArity,
setIdNewDemandInfo,
setIdNewStrictness, zapIdNewStrictness,
setIdWorkerInfo,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
......@@ -132,6 +134,7 @@ infixl 1 `setIdUnfolding`,
`setIdArity`,
`setIdNewDemandInfo`,
`setIdNewStrictness`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
`idCafInfo`
......@@ -530,6 +533,14 @@ isStrictId id
(isStrictDmd (idNewDemandInfo id)) ||
(isStrictType (idType id))
---------------------------------
-- WORKER ID
idWorkerInfo :: Id -> WorkerInfo
idWorkerInfo id = workerInfo (idInfo id)
setIdWorkerInfo :: Id -> WorkerInfo -> Id
setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id
---------------------------------
-- UNFOLDING
idUnfolding :: Id -> Unfolding
......
......@@ -49,6 +49,11 @@ module IdInfo (
cprInfoFromNewStrictness,
#endif
-- ** The WorkerInfo type
WorkerInfo(..),
workerExists, wrapperArity, workerId,
workerInfo, setWorkerInfo, ppWorkerInfo,
-- ** Unfolding Info
unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
......@@ -89,6 +94,7 @@ import CoreSyn ( CoreRule, setRuleIdName, seqRules, Unfolding, noUnfolding )
import Class
import PrimOp
import Name
import Var
import VarSet
import BasicTypes
import DataCon
......@@ -113,6 +119,7 @@ infixl 1 `setSpecInfo`,
`setArityInfo`,
`setInlinePragInfo`,
`setUnfoldingInfo`,
`setWorkerInfo`,
`setLBVarInfo`,
`setOccInfo`,
`setCafInfo`,
......@@ -314,6 +321,15 @@ data IdInfo
demandInfo :: Demand.Demand, -- ^ Whether or not the 'Id' is definitely demanded
strictnessInfo :: StrictnessInfo, -- ^ 'Id' strictness properties
#endif
workerInfo :: WorkerInfo, -- ^ Pointer to worker function.
-- Within one module this is irrelevant; the
-- inlining of a worker is handled via the 'Unfolding'.
-- However, when the module is imported by others, the
-- 'WorkerInfo' is used /only/ to indicate the form of
-- the RHS, so that interface files don't actually
-- need to contain the RHS; it can be derived from
-- the strictness info
unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding
cafInfo :: CafInfo, -- ^ 'Id' CAF info
lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one
......@@ -339,6 +355,7 @@ seqIdInfo (IdInfo {}) = ()
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
= seqSpecInfo (specInfo info) `seq`
seqWorker (workerInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
......@@ -361,6 +378,8 @@ megaSeqIdInfo info
Setters
\begin{code}
setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo
setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
setSpecInfo info sp = sp `seq` info { specInfo = sp }
setInlinePragInfo :: IdInfo -> InlinePragInfo -> IdInfo
......@@ -416,6 +435,7 @@ vanillaIdInfo
strictnessInfo = NoStrictnessInfo,
#endif
specInfo = emptySpecInfo,
workerInfo = NoWorker,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = AlwaysActive,
......@@ -522,6 +542,67 @@ seqSpecInfo :: SpecInfo -> ()
seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
\end{code}
%************************************************************************
%* *
\subsection[worker-IdInfo]{Worker info about an @Id@}
%* *
%************************************************************************
There might not be a worker, even for a strict function, because:
(a) the function might be small enough to inline, so no need
for w/w split
(b) the strictness info might be "SSS" or something, so no w/w split.
Sometimes the arity of a wrapper changes from the original arity from
which it was generated, so we always emit the "original" arity into
the interface file, as part of the worker info.
How can this happen? Sometimes we get
f = coerce t (\x y -> $wf x y)
at the moment of w/w split; but the eta reducer turns it into
f = coerce t $wf
which is perfectly fine except that the exposed arity so far as
the code generator is concerned (zero) differs from the arity
when we did the split (2).
All this arises because we use 'arity' to mean "exactly how many
top level lambdas are there" in interface files; but during the
compilation of this module it means "how many things can I apply
this to".
\begin{code}
-- | If this Id has a worker then we store a reference to it. Worker
-- functions are generated by the worker\/wrapper pass, using information
-- information from strictness analysis.
data WorkerInfo = NoWorker -- ^ No known worker function
| HasWorker Id Arity -- ^ The 'Arity' is the arity of the /wrapper/ at the moment of the
-- worker\/wrapper split, which may be different from the current 'Id' 'Aritiy'
seqWorker :: WorkerInfo -> ()
seqWorker (HasWorker id a) = id `seq` a `seq` ()
seqWorker NoWorker = ()
ppWorkerInfo :: WorkerInfo -> SDoc
ppWorkerInfo NoWorker = empty
ppWorkerInfo (HasWorker wk_id _) = ptext (sLit "Worker") <+> ppr wk_id
workerExists :: WorkerInfo -> Bool
workerExists NoWorker = False
workerExists (HasWorker _ _) = True
-- | The 'Id' of the worker function if it exists, or a panic otherwise
workerId :: WorkerInfo -> Id
workerId (HasWorker id _) = id
workerId NoWorker = panic "workerId: NoWorker"
-- | The 'Arity' of the worker function at the time of the split if it exists, or a panic otherwise
wrapperArity :: WorkerInfo -> Arity
wrapperArity (HasWorker _ a) = a
wrapperArity NoWorker = panic "wrapperArity: NoWorker"
\end{code}
%************************************************************************
%* *
\subsection[CG-IdInfo]{Code generator-related information}
......@@ -698,6 +779,7 @@ zapFragileInfo :: IdInfo -> Maybe IdInfo
-- ^ Zap info that depends on free variables
zapFragileInfo info
= Just (info `setSpecInfo` emptySpecInfo
`setWorkerInfo` NoWorker
`setUnfoldingInfo` noUnfolding
`setOccInfo` if isFragileOcc occ then NoOccInfo else occ)
where
......
......@@ -335,8 +335,8 @@ mkDataConIds wrap_name wkr_name data_con
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
wrap_unf = mkInlineRule wrap_rhs (length dict_args + length id_args)
wrap_rhs = mkLams wrap_tvs $
wrap_unf = mkImplicitUnfolding $ Note InlineMe $
mkLams wrap_tvs $
mkLams eq_args $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
......
......@@ -16,7 +16,6 @@ Taken quite directly from the Peyton Jones/Lester paper.
module CoreFVs (
-- * Free variables of expressions and binding groups
exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
exprsFreeVars, -- [CoreExpr] -> VarSet
bindFreeVars, -- CoreBind -> VarSet
......@@ -26,8 +25,7 @@ module CoreFVs (
exprFreeNames, exprsFreeNames,
-- * Free variables of Rules, Vars and Ids
idRuleVars, idRuleRhsVars, idFreeVars, idInlineFreeVars,
varTypeTyVars,
idRuleVars, idFreeVars, varTypeTyVars,
ruleRhsFreeVars, rulesFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
......@@ -73,10 +71,6 @@ but not those that are free in the type of variable occurrence.
exprFreeVars :: CoreExpr -> VarSet
exprFreeVars = exprSomeFreeVars isLocalVar
-- | Find all locally-defined free Ids in an expression
exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids
exprFreeIds = exprSomeFreeVars isLocalId
-- | Find all locally-defined free Ids or type variables in several expressions
exprsFreeVars :: [CoreExpr] -> VarSet
exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet
......@@ -384,24 +378,7 @@ bndrRuleVars v | isTyVar v = emptyVarSet
| otherwise = idRuleVars v
idRuleVars ::Id -> VarSet
idRuleVars id = ASSERT( isId id)
specInfoFreeVars (idSpecialisation id) `unionVarSet`
idInlineFreeVars id -- And the variables in an INLINE rule
idRuleRhsVars :: Id -> VarSet
-- Just the variables free on the *rhs* of a rule
-- See Note [Choosing loop breakers] in Simplify.lhs
idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars)
(idInlineFreeVars id)
(idCoreRules id)
idInlineFreeVars :: Id -> VarSet
-- Produce free vars for an InlineRule, BUT NOT for an ordinary unfolding
-- An InlineRule behaves *very like* a RULE, and that is what we are after here
idInlineFreeVars id
= case idUnfolding id of
InlineRule { uf_tmpl = tmpl } -> exprFreeVars tmpl
_ -> emptyVarSet
idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
\end{code}
......
......@@ -28,6 +28,7 @@ import VarEnv
import VarSet
import Name
import Id
import IdInfo
import PprCore
import ErrUtils
import SrcLoc
......@@ -227,7 +228,10 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
where
binder_ty = idType binder
maybeDmdTy = idNewStrictness_maybe binder
bndr_vars = varSetElems (idFreeVars binder)
bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
| otherwise = emptyVarSet
wkr_info = idWorkerInfo binder
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
\end{code}
......
......@@ -519,6 +519,7 @@ corePrepExprFloat env expr@(App _ _) = do
ty = exprType fun
ignore_note (CoreNote _) = True
ignore_note InlineMe = True
ignore_note _other = False
-- We don't ignore SCCs, since they require some code generation
......
......@@ -12,7 +12,7 @@ module CoreSubst (
-- ** Substituting into expressions and related types
deShadowBinds,
substTy, substExpr, substSpec, substUnfolding,
substTy, substExpr, substSpec, substWorker,
lookupIdSubst, lookupTvSubst,
-- ** Operations on substitutions
......@@ -24,10 +24,7 @@ module CoreSubst (
-- ** Substituting and cloning binders
substBndr, substBndrs, substRecBndrs,
cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
-- ** Simple expression optimiser
simpleOptExpr
cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
) where
#include "HsVersions.h"
......@@ -35,7 +32,6 @@ module CoreSubst (
import CoreSyn
import CoreFVs
import CoreUtils
import OccurAnal( occurAnalyseExpr )
import qualified Type
import Type ( Type, TvSubst(..), TvSubstEnv )
......@@ -215,7 +211,7 @@ lookupIdSubst (Subst in_scope ids _) v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the Subst]
| otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope )
| otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v )
Var v
-- | Find the substitution for a 'TyVar' in the 'Subst'
......@@ -478,40 +474,31 @@ substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
substIdInfo subst new_id info
| nothing_to_do = Nothing
| otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
`setUnfoldingInfo` substUnfolding subst old_unf)
`setWorkerInfo` substWorker subst old_wrkr
`setUnfoldingInfo` noUnfolding)
where
old_rules = specInfo info
old_unf = unfoldingInfo info
nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
old_wrkr = workerInfo info
nothing_to_do = isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
------------------
-- | Substitutes for the 'Id's within an unfolding
substUnfolding :: Subst -> Unfolding -> Unfolding
-- Seq'ing on the returned Unfolding is enough to cause
-- all the substitutions to happen completely
substUnfolding subst unf@(InlineRule { uf_tmpl = tmpl, uf_worker = mb_wkr })
-- Retain an InlineRule!
= seqExpr new_tmpl `seq`
new_mb_wkr `seq`
unf { uf_tmpl = new_tmpl, uf_worker = new_mb_wkr }
where
new_tmpl = substExpr subst tmpl
new_mb_wkr = case mb_wkr of
Nothing -> Nothing
Just w -> subst_wkr w
subst_wkr w = case lookupIdSubst subst w of
Var w1 -> Just w1
other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
Nothing -- Worker has got substituted away altogether
-- (This can happen if it's trivial,
-- via postInlineUnconditionally, hence warning)
substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard
-- Always zap a CoreUnfolding, to save substitution work
substUnfolding _ unf = unf -- Otherwise no substitution to do
-- | Substitutes for the 'Id's within the 'WorkerInfo'
substWorker :: Subst -> WorkerInfo -> WorkerInfo
-- Seq'ing on the returned WorkerInfo is enough to cause all the
-- substitutions to happen completely
substWorker _ NoWorker
= NoWorker
substWorker subst (HasWorker w a)
= case lookupIdSubst subst w of
Var w1 -> HasWorker w1 a
other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
NoWorker -- Worker has got substituted away altogether
-- (This can happen if it's trivial,
-- via postInlineUnconditionally, hence warning)
------------------
-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
......@@ -525,7 +512,7 @@ substSpec subst new_fn (SpecInfo rules rhs_fvs)
do_subst rule@(BuiltinRule {}) = rule
do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
= rule { ru_bndrs = bndrs',
ru_fn = new_name, -- Important: the function may have changed its name!
ru_fn = new_name, -- Important: the function may have changed its name!
ru_args = map (substExpr subst') args,
ru_rhs = substExpr subst' rhs }
where
......@@ -540,85 +527,3 @@ substVarSet subst fvs
| isId fv = exprFreeVars (lookupIdSubst subst fv)
| otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
\end{code}
%************************************************************************
%* *
The Very Simple Optimiser
%* *
%************************************************************************
\begin{code}
simpleOptExpr :: CoreExpr -> CoreExpr
-- Return an occur-analysed and slightly optimised expression
-- The optimisation is very straightforward: just
-- inline non-recursive bindings that are used only once,
-- or where the RHS is trivial
simpleOptExpr expr
= go init_subst (occurAnalyseExpr expr)
where
init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
-- It's potentially to make a proper in-scope set
-- Consider let x = ..y.. in \y. ...x...
-- Then we should remember to clone y before substituting
-- for x. It's very unlikely to occur, because we probably
-- won't *be* substituting for x if it occurs inside a
-- lambda.
--
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
go subst (Var v) = lookupIdSubst subst v
go subst (App e1 e2) = App (go subst e1) (go subst e2)
go subst (Type ty) = Type (substTy subst ty)
go _ (Lit lit) = Lit lit
go subst (Note note e) = Note note (go subst e)
go subst (Cast e co) = Cast (go subst e) (substTy subst co)
go subst (Let bind body) = go_bind subst bind body
go subst (Lam bndr body) = Lam bndr' (go subst' body)
where
(subst', bndr') = substBndr subst bndr
go subst (Case e b ty as) = Case (go subst e) b'
(substTy subst ty)
(map (go_alt subst') as)
where
(subst', b') = substBndr subst b
----------------------
go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
where
(subst', bndrs') = substBndrs subst bndrs
----------------------
go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
(go subst' body)
where
(bndrs, rhss) = unzip prs
(subst', bndrs') = substRecBndrs subst bndrs
rhss' = map (go subst') rhss
go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
----------------------
go_nonrec subst b (Type ty') body
| isTyVar b = go (extendTvSubst subst b ty') body
-- let a::* = TYPE ty in <body>
go_nonrec subst b r' body
| isId b -- let x = e in <body>
, exprIsTrivial r' || safe_to_inline (idOccInfo b)
= go (extendIdSubst subst b r') body
go_nonrec subst b r' body
= Let (NonRec b' r') (go subst' body)
where
(subst', b') = substBndr subst b
----------------------
-- Unconditionally safe to inline
safe_to_inline :: OccInfo -> Bool
safe_to_inline IAmDead = True
safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
safe_to_inline (IAmALoopBreaker {}) = False
safe_to_inline NoOccInfo = False
\end{code}
......@@ -41,10 +41,9 @@ module CoreSyn (
noUnfolding, evaldUnfolding, mkOtherCon,
-- ** Predicates and deconstruction on 'Unfolding'
unfoldingTemplate, setUnfoldingTemplate,
maybeUnfoldingTemplate, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
isInlineRule, isClosedUnfolding, hasSomeUnfolding, canUnfold, neverUnfoldGuidance,
hasUnfolding, hasSomeUnfolding, neverUnfold,
-- * Strictness
seqExpr, seqExprs, seqUnfolding,
......@@ -272,7 +271,21 @@ See #type_let#
-- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
data Note
= SCC CostCentre -- ^ A cost centre annotation for profiling
| InlineMe -- ^ Instructs the core simplifer to treat the enclosed expression
-- as very small, and inline it at its call sites
| CoreNote String -- ^ A generic core annotation, propagated but not used by GHC
-- NOTE: we also treat expressions wrapped in InlineMe as
-- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
-- What this means is that we obediently inline even things that don't
-- look like valuse. This is sometimes important:
-- {-# INLINE f #-}
-- f = g . h
-- Here, f looks like a redex, and we aren't going to inline (.) because it's
-- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
-- should inline f even inside lambdas. In effect, we should trust the programmer.
\end{code}
......@@ -391,73 +404,45 @@ data Unfolding
--
-- Here, @f@ gets an @OtherCon []@ unfolding.
| CompulsoryUnfolding { -- There is /no original definition/, so you'd better unfold.
uf_tmpl :: CoreExpr -- The unfolding is guaranteed to have no free variables
} -- so no need to think about it during dependency analysis
| InlineRule { -- The function has an INLINE pragma, with the specified (original) RHS
-- (The inline phase, if any, is in the InlinePragInfo for this Id.)
-- Inline when (a) applied to at least this number of args
-- (b) if there is something interesting about args or context
uf_tmpl :: CoreExpr, -- The *original* RHS; occurrence info is correct
-- (The actual RHS of the function may be different by now,
-- but what we inline is still the original RHS (kept in the InlineRule).)
uf_is_top :: Bool,
uf_arity :: Arity, -- Don't inline unless applied to this number of *value* args
uf_is_value :: Bool, -- True <=> exprIsHNF is true; save to discard a `seq`
uf_worker :: Maybe Id -- Just wrk_id <=> this unfolding is a the wrapper in a worker/wrapper
-- split from the strictness analyser
-- Used to abbreviate the uf_tmpl in interface files
-- In the Just case, interface files don't actually
-- need to contain the RHS; it can be derived from
-- the strictness info
-- Also used in CoreUnfold to guide inlining decisions
}
| CompulsoryUnfolding CoreExpr -- ^ There is /no original definition/,
-- so you'd better unfold.
| CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
-- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
uf_tmpl :: CoreExpr, -- Template; binder-info is correct
uf_is_top :: Bool, -- True <=> top level binding
uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on
-- this variable
uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining
-- Basically it's exprIsCheap
uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
}
| CoreUnfolding
CoreExpr
Bool
Bool
Bool
UnfoldingGuidance
-- ^ An unfolding with redundant cached information. Parameters:
--
-- uf_tmpl: Template used to perform unfolding; binder-info is correct
-- 1) Template used to perform unfolding; binder-info is correct
--
-- uf_is_top: Is this a top level binding?
-- 2) Is this a top level binding?
--
-- uf_is_valiue: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
-- 3) 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
-- this variable
--
-- uf_is_cheap: Does this waste only a little work if we expand it inside an inlining?
-- 4) Does this waste only a little work if we expand it inside an inlining?
-- Basically this is a cached version of 'exprIsCheap'
--
-- uf_guidance: Tells us about the /size/ of the unfolding template
-- 5) Tells us about the /size/ of the unfolding template
------------------------------------------------
-- | 'UnfoldingGuidance' says when unfolding should take place
-- | When unfolding should take place
data UnfoldingGuidance
= UnfoldNever
| UnfoldIfGoodArgs {
ug_arity :: Arity, -- "n" value args
| UnfoldIfGoodArgs Int -- and "n" value args
ug_args :: [Int], -- Discount if the argument is evaluated.
-- (i.e., a simplification will definitely
-- be possible). One elt of the list per *value* arg.
[Int] -- Discount if the argument is evaluated.
-- (i.e., a simplification will definitely
-- be possible). One elt of the list per *value* arg.
ug_size :: Int, -- The "size" of the unfolding; to be elaborated
-- later. ToDo
Int -- The "size" of the unfolding; to be elaborated
-- later. ToDo
ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in
} -- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
Int -- Scrutinee discount: the discount to substract if the thing is in
-- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
------------------------------------------------
noUnfolding :: Unfolding
-- ^ There is no known 'Unfolding'
evaldUnfolding :: Unfolding
......@@ -470,8 +455,7 @@ mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
uf_is_value = b1, uf_is_cheap = b2, uf_guidance = g})
seqUnfolding (CoreUnfolding e top b1 b2 g)
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
seqUnfolding _ = ()
......@@ -483,17 +467,15 @@ seqGuidance _ = ()
\begin{code}
-- | Retrieves the template of an unfolding: panics if none is known
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate = uf_tmpl
setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding
setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs }
unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
unfoldingTemplate (CompulsoryUnfolding expr) = expr
unfoldingTemplate _ = panic "getUnfoldingTemplate"
-- | Retrieves the template of an unfolding if possible
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding { uf_tmpl = expr }) = Just expr
maybeUnfoldingTemplate (InlineRule { uf_tmpl = expr }) = Just expr
maybeUnfoldingTemplate _ = Nothing
maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
maybeUnfoldingTemplate _ = Nothing
-- | The constructors that the unfolding could never be:
-- returns @[]@ if no information is available
......@@ -504,53 +486,45 @@ otherCons _ = []
-- | Determines if it is certainly the case that the unfolding will
-- yield a value (something in HNF): returns @False@ if unsure
isValueUnfolding :: Unfolding -> Bool
-- Returns False for OtherCon
isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
isValueUnfolding (InlineRule { uf_is_value = is_evald }) = is_evald
isValueUnfolding _ = False
isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
isValueUnfolding _ = False
-- | Determines if it possibly the case that the unfolding will
-- yield a value. Unlike 'isValueUnfolding' it returns @True@
-- for 'OtherCon'
isEvaldUnfolding :: Unfolding -> Bool
-- Returns True for OtherCon
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
isEvaldUnfolding (InlineRule { uf_is_value = is_evald }) = is_evald
isEvaldUnfolding _ = False
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
isEvaldUnfolding _ = False
-- | Is the thing we will unfold into certainly cheap?