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}
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -171,6 +171,7 @@ make_exp (Case e v ty alts) = do
return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary
make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s) -- hdaume: core annotations
make_exp (Note InlineMe e) = make_exp e >>= (return . C.Note "InlineMe")
make_exp _ = error "MkExternalCore died: make_exp"
make_alt :: CoreAlt -> CoreM C.Alt
......
......@@ -209,6 +209,9 @@ ppr_expr add_par (Let bind expr)
ppr_expr add_par (Note (SCC cc) expr)
= add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
ppr_expr add_par (Note InlineMe expr)
= add_par $ ptext (sLit "__inline_me") <+> pprParendExpr expr
ppr_expr add_par (Note (CoreNote s) expr)
= add_par $
sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
......@@ -265,9 +268,6 @@ pprCoreBinder LambdaBind bndr
-- Case bound things don't get a signature or a herald, unless we have debug on
pprCoreBinder CaseBind bndr
| isDeadBinder bndr -- False for tyvars
= ptext (sLit "_")
| otherwise
= getPprStyle $ \ sty ->
if debugStyle sty then
parens (pprTypedBinder bndr)
......@@ -325,10 +325,6 @@ pprIdBndrInfo info
\end{code}
-----------------------------------------------------
-- IdInfo
-----------------------------------------------------
\begin{code}
pprIdDetails :: Id -> SDoc
pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
......@@ -339,13 +335,13 @@ ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo _ info
= brackets $
vcat [ ppArityInfo a,
ppWorkerInfo (workerInfo info),
ppCafInfo (cafInfo info),
#ifdef OLD_STRICTNESS
ppStrictnessInfo s,
ppCprInfo m,
#endif
pprNewStrictness (newStrictnessInfo info),
pprInlineInfo (unfoldingInfo info),
if null rules then empty
else ptext (sLit "RULES:") <+> vcat (map pprRule rules)
-- Inline pragma, occ, demand, lbvar info
......@@ -361,38 +357,6 @@ ppIdInfo _ info
rules = specInfoRules (specInfo info)
\end{code}
-----------------------------------------------------
-- Unfolding and UnfoldingGuidance
-----------------------------------------------------
\begin{code}
instance Outputable UnfoldingGuidance where
ppr UnfoldNever = ptext (sLit "NEVER")
ppr (UnfoldIfGoodArgs { ug_arity = v, ug_args = cs
, ug_size = size, ug_res = discount })
= hsep [ ptext (sLit "IF_ARGS"), int v,
brackets (hsep (map int cs)),
int size,
int discount ]
instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e
ppr (InlineRule { uf_tmpl = e, uf_is_value = hnf, uf_arity = arity, uf_worker = wkr })
= ptext (sLit "INLINE") <+> sep [ppr arity <+> ppr hnf <+> ppr wkr, ppr e]
ppr (CoreUnfolding e top hnf cheap g)
= ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr g,
ppr e]
pprInlineInfo :: Unfolding -> SDoc -- Print an inline RULE
pprInlineInfo unf | isInlineRule unf = ppr unf
| otherwise = empty
\end{code}
-----------------------------------------------------
-- Rules
-----------------------------------------------------
\begin{code}
instance Outputable CoreRule where
......
This diff is collapsed.
......@@ -19,7 +19,6 @@ import DsMonad
import HsSyn
import DataCon
import CoreUtils
import CoreUnfold
import Id
import Literal
import Module
......@@ -231,10 +230,9 @@ dsFCall fn_id fcall = do
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkLams (tvs ++ args) wrapper_body
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (length args)
wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
\end{code}
......
......@@ -13,7 +13,7 @@
-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------
{-# OPTIONS -fwarn-unused-imports #-}
{-# OPTIONS -fno-warn-unused-imports #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
......@@ -33,6 +33,7 @@ module DsMeta( dsBracket,
import {-# SOURCE #-} DsExpr ( dsExpr )
import MatchLit
import DsUtils
import DsMonad
import qualified Language.Haskell.TH as TH
......@@ -44,11 +45,11 @@ import PrelNames
-- OccName.varName we do this by removing varName from the import of
-- OccName above, making a qualified instance of OccName and using
-- OccNameAlias.varName where varName ws previously used in this file.
import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
import qualified OccName
import Module
import Id
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
import Name
import NameEnv
import TcType
import TyCon
......
......@@ -131,9 +131,7 @@ data HsBindLR idL idR
| VarBind { -- Dictionary binding and suchlike
var_id :: idL, -- All VarBinds are introduced by the type checker
var_rhs :: LHsExpr idR, -- Located only for consistency
var_inline :: Bool -- True <=> inline this binding regardless
-- (used for implication constraints)
var_rhs :: LHsExpr idR -- Located only for consistency
}
| AbsBinds { -- Binds abstraction; TRANSLATION
......@@ -355,6 +353,7 @@ data HsWrapper
| WpLam Var -- \d. [] the 'd' is a type-class dictionary or coercion variable
| WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
| WpInline -- inline_me [] Wrap inline around the thing
-- Non-empty bindings, so that the identity coercion
-- is always exactly WpHole
......@@ -375,6 +374,7 @@ pprHsWrapper it wrap =
help it (WpLam id) = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
help it (WpTyLam tv) = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
help it WpInline = sep [ptext (sLit "_inline_me_"), it]
in
-- in debug mode, print the wrapper
-- otherwise just print what's inside
......
%
% (c) The University of Glasgow, 1992-2006
%
......@@ -300,12 +299,8 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc
fun_tick = Nothing }
mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
mkVarBind :: id -> LHsExpr id -> LHsBind id
mkVarBind var rhs = L (getLoc rhs) $
VarBind { var_id = var, var_rhs = rhs, var_inline = False }
mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
------------
mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
......
......@@ -1124,6 +1124,10 @@ instance Binary IfaceInfoItem where
put_ bh ad
put_ bh HsNoCafRefs = do
putByte bh 4
put_ bh (HsWorker ae af) = do
putByte bh 5
put_ bh ae
put_ bh af
get bh = do
h <- getByte bh
case h of
......@@ -1135,36 +1139,17 @@ instance Binary IfaceInfoItem where
return (HsUnfold ad)
3 -> do ad <- get bh
return (HsInline ad)
_ -> do return HsNoCafRefs
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold e) = do
putByte bh 0
put_ bh e
put_ bh (IfInlineRule a e) = do
putByte bh 1
put_ bh a
put_ bh e
put_ bh (IfWrapper a n) = do
putByte bh 2
put_ bh a
put_ bh n
get bh = do
h <- getByte bh
case h of
0 -> do e <- get bh
return (IfCoreUnfold e)
1 -> do a <- get bh
e <- get bh
return (IfInlineRule a e)
_ -> do a <- get bh
n <- get bh
return (IfWrapper a n)
4 -> do return HsNoCafRefs
_ -> do ae <- get bh
af <- get bh
return (HsWorker ae af)
instance Binary IfaceNote where
put_ bh (IfaceSCC aa) = do
putByte bh 0
put_ bh aa
put_ bh IfaceInlineMe = do
putByte bh 3
put_ bh (IfaceCoreNote s) = do
putByte bh 4
put_ bh s
......@@ -1173,6 +1158,7 @@ instance Binary IfaceNote where
case h of
0 -> do aa <- get bh
return (IfaceSCC aa)
3 -> do return IfaceInlineMe
4 -> do ac <- get bh
return (IfaceCoreNote ac)
_ -> panic ("get IfaceNote " ++ show h)
......
......@@ -9,7 +9,7 @@ module IfaceSyn (
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceUnfolding(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceInst(..), IfaceFamInst(..),
......@@ -192,18 +192,15 @@ data IfaceInfoItem