Commit d95ce839 authored by simonpj@microsoft.com's avatar 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.
parent ccd0e382
......@@ -68,7 +68,6 @@ module Id (
idArity,
idNewDemandInfo, idNewDemandInfo_maybe,
idNewStrictness, idNewStrictness_maybe,
idWorkerInfo,
idUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
......@@ -86,7 +85,6 @@ module Id (
setIdArity,
setIdNewDemandInfo,
setIdNewStrictness, zapIdNewStrictness,
setIdWorkerInfo,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
......@@ -134,7 +132,6 @@ infixl 1 `setIdUnfolding`,
`setIdArity`,
`setIdNewDemandInfo`,
`setIdNewStrictness`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
`idCafInfo`
......@@ -533,14 +530,6 @@ 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,11 +49,6 @@ module IdInfo (
cprInfoFromNewStrictness,
#endif
-- ** The WorkerInfo type
WorkerInfo(..),
workerExists, wrapperArity, workerId,
workerInfo, setWorkerInfo, ppWorkerInfo,
-- ** Unfolding Info
unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
......@@ -94,7 +89,6 @@ import CoreSyn ( CoreRule, setRuleIdName, seqRules, Unfolding, noUnfolding )
import Class
import PrimOp
import Name
import Var
import VarSet
import BasicTypes
import DataCon
......@@ -119,7 +113,6 @@ infixl 1 `setSpecInfo`,
`setArityInfo`,
`setInlinePragInfo`,
`setUnfoldingInfo`,
`setWorkerInfo`,
`setLBVarInfo`,
`setOccInfo`,
`setCafInfo`,
......@@ -321,15 +314,6 @@ 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
......@@ -355,7 +339,6 @@ 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
......@@ -378,8 +361,6 @@ 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
......@@ -435,7 +416,6 @@ vanillaIdInfo
strictnessInfo = NoStrictnessInfo,
#endif
specInfo = emptySpecInfo,
workerInfo = NoWorker,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = AlwaysActive,
......@@ -542,67 +522,6 @@ 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}
......@@ -779,7 +698,6 @@ 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 = mkImplicitUnfolding $ Note InlineMe $
mkLams wrap_tvs $
wrap_unf = mkInlineRule wrap_rhs (length dict_args + length id_args)
wrap_rhs = mkLams wrap_tvs $
mkLams eq_args $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
......
......@@ -16,6 +16,7 @@ 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
......@@ -25,7 +26,8 @@ module CoreFVs (
exprFreeNames, exprsFreeNames,
-- * Free variables of Rules, Vars and Ids
idRuleVars, idFreeVars, varTypeTyVars,
idRuleVars, idRuleRhsVars, idFreeVars, idInlineFreeVars,
varTypeTyVars,
ruleRhsFreeVars, rulesFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
......@@ -71,6 +73,10 @@ 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
......@@ -378,7 +384,24 @@ bndrRuleVars v | isTyVar v = emptyVarSet
| otherwise = idRuleVars v
idRuleVars ::Id -> VarSet
idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
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
\end{code}
......
......@@ -28,7 +28,6 @@ import VarEnv
import VarSet
import Name
import Id
import IdInfo
import PprCore
import ErrUtils
import SrcLoc
......@@ -228,10 +227,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
where
binder_ty = idType binder
maybeDmdTy = idNewStrictness_maybe binder
bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
| otherwise = emptyVarSet
wkr_info = idWorkerInfo binder
bndr_vars = varSetElems (idFreeVars binder)
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
\end{code}
......
......@@ -276,8 +276,7 @@ corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
-- This one is used for *local* bindings
corePrepBind env (NonRec bndr rhs) = do
rhs1 <- etaExpandRhs bndr rhs
(floats, rhs2) <- corePrepExprFloat env rhs1
(floats, rhs2) <- corePrepExprFloat env rhs
(_, bndr') <- cloneBndr env bndr
(floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2
-- We want bndr'' in the envt, because it records
......@@ -310,8 +309,7 @@ corePrepRhs :: TopLevelFlag -> RecFlag
-> UniqSM (Floats, CoreExpr)
-- Used for top-level bindings, and local recursive bindings
corePrepRhs top_lvl is_rec env (bndr, rhs) = do
rhs' <- etaExpandRhs bndr rhs
floats_w_rhs <- corePrepExprFloat env rhs'
floats_w_rhs <- corePrepExprFloat env rhs
floatRhs top_lvl is_rec bndr floats_w_rhs
......@@ -322,14 +320,15 @@ corePrepRhs top_lvl is_rec env (bndr, rhs) = do
-- This is where we arrange that a non-trivial argument is let-bound
corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
-> UniqSM (Floats, CoreArg)
corePrepArg env arg dem = do
(floats, arg') <- corePrepExprFloat env arg
if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats
-- Note [Floating unlifted arguments]
then return (floats, arg')
else do v <- newVar (exprType arg')
(floats', v') <- mkLocalNonRec v dem floats arg'
return (floats', Var v')
corePrepArg env arg dem
= do { (floats, arg') <- corePrepExprFloat env arg
; if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats
-- Note [Floating unlifted arguments]
then return (floats, arg')
else do { v <- newVar (exprType arg')
-- Note [Eta expand arguments]
; (floats', v') <- mkLocalNonRec v dem floats arg'
; return (floats', Var v') } }
-- version that doesn't consider an scc annotation to be trivial.
exprIsTrivial :: CoreExpr -> Bool
......@@ -519,7 +518,6 @@ 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
......@@ -589,20 +587,60 @@ floatRhs :: TopLevelFlag -> RecFlag
-> UniqSM (Floats, -- Floats out of this bind
CoreExpr) -- Final Rhs
floatRhs top_lvl is_rec _bndr (floats, rhs)
floatRhs top_lvl is_rec bndr (floats, rhs)
| isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
allLazy top_lvl is_rec floats -- at top level
= -- Why the test for allLazy?
-- v = f (x `divInt#` y)
-- we don't want to float the case, even if f has arity 2,
-- because floating the case would make it evaluated too early
return (floats, rhs)
do { us <- getUniquesM
; let eta_rhs = etaExpand arity us rhs (idType bndr)
-- For a GlobalId, take the Arity from the Id.
-- It was set in CoreTidy and must not change
-- For all others, just expand at will
-- See Note [Eta expansion]
arity | isGlobalId bndr = idArity bndr
| otherwise = exprArity rhs
; return (floats, eta_rhs) }
| otherwise = do
-- Don't float; the RHS isn't a value
rhs' <- mkBinds floats rhs
return (emptyFloats, rhs')
\end{code}
Note [Eta expansion]
~~~~~~~~~~~~~~~~~~~~~
Eta expand to match the arity claimed by the binder Remember,
CorePrep must not change arity
Eta expansion might not have happened already, because it is done by
the simplifier only when there at least one lambda already.
NB1:we could refrain when the RHS is trivial (which can happen
for exported things). This would reduce the amount of code
generated (a little) and make things a little words for
code compiled without -O. The case in point is data constructor
wrappers.
NB2: we have to be careful that the result of etaExpand doesn't
invalidate any of the assumptions that CorePrep is attempting
to establish. One possible cause is eta expanding inside of
an SCC note - we're now careful in etaExpand to make sure the
SCC is pushed inside any new lambdas that are generated.
NB3: It's important to do eta expansion, and *then* ANF-ising
f = /\a -> g (h 3) -- h has arity 2
If we ANF first we get
f = /\a -> let s = h 3 in g s
and now eta expansion gives
f = /\a -> \ y -> (let s = h 3 in g s) y
which is horrible.
Eta expanding first gives
f = /\a -> \y -> let s = h 3 in g s y
\begin{code}
-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
-> Floats -> CoreExpr -- Rhs: let binds in body
......@@ -648,50 +686,6 @@ mkBinds (Floats _ binds) body
mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr
etaExpandRhs bndr rhs = do
-- Eta expand to match the arity claimed by the binder
-- Remember, CorePrep must not change arity
--
-- Eta expansion might not have happened already,
-- because it is done by the simplifier only when
-- there at least one lambda already.
--
-- NB1:we could refrain when the RHS is trivial (which can happen
-- for exported things). This would reduce the amount of code
-- generated (a little) and make things a little words for
-- code compiled without -O. The case in point is data constructor
-- wrappers.
--
-- NB2: we have to be careful that the result of etaExpand doesn't
-- invalidate any of the assumptions that CorePrep is attempting
-- to establish. One possible cause is eta expanding inside of
-- an SCC note - we're now careful in etaExpand to make sure the
-- SCC is pushed inside any new lambdas that are generated.
--
-- NB3: It's important to do eta expansion, and *then* ANF-ising
-- f = /\a -> g (h 3) -- h has arity 2
-- If we ANF first we get
-- f = /\a -> let s = h 3 in g s
-- and now eta expansion gives
-- f = /\a -> \ y -> (let s = h 3 in g s) y
-- which is horrible.
-- Eta expanding first gives
-- f = /\a -> \y -> let s = h 3 in g s y
--
us <- getUniquesM
let eta_rhs = etaExpand arity us rhs (idType bndr)
ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs))
$$ ppr rhs $$ ppr eta_rhs )
-- Assertion checks that eta expansion was successful
return eta_rhs
where
-- For a GlobalId, take the Arity from the Id.
-- It was set in CoreTidy and must not change
-- For all others, just expand at will
arity | isGlobalId bndr = idArity bndr
| otherwise = exprArity rhs
-- ---------------------------------------------------------------------------
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
......
......@@ -12,7 +12,7 @@ module CoreSubst (
-- ** Substituting into expressions and related types
deShadowBinds,
substTy, substExpr, substSpec, substWorker,
substTy, substExpr, substSpec, substUnfolding,
lookupIdSubst, lookupTvSubst,
-- ** Operations on substitutions
......@@ -211,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 )
| otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope )
Var v
-- | Find the substitution for a 'TyVar' in the 'Subst'
......@@ -474,31 +474,40 @@ 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
`setWorkerInfo` substWorker subst old_wrkr
`setUnfoldingInfo` noUnfolding)
`setUnfoldingInfo` substUnfolding subst old_unf)
where
old_rules = specInfo info
old_wrkr = workerInfo info
nothing_to_do = isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
old_unf = unfoldingInfo info
nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
------------------
-- | 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 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' given the new function 'Id'
......@@ -512,7 +521,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
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -171,7 +171,6 @@ 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,9 +209,6 @@ 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)],
......@@ -268,6 +265,9 @@ 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,6 +325,10 @@ pprIdBndrInfo info
\end{code}
-----------------------------------------------------
-- IdInfo
-----------------------------------------------------
\begin{code}
pprIdDetails :: Id -> SDoc
pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
......@@ -335,13 +339,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
......@@ -357,6 +361,38 @@ 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,6 +19,7 @@ import DsMonad
import HsSyn
import DataCon
import CoreUtils
import CoreUnfold
import Id
import Literal
import Module
......@@ -230,9 +231,10 @@ 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 = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
wrap_rhs = mkLams (tvs ++ args) wrapper_body
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (length args)
return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
\end{code}
......
......@@ -13,7 +13,7 @@
-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-unused-imports #-}
{-# OPTIONS -fwarn-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,7 +33,6 @@ module DsMeta( dsBracket,
import {-# SOURCE #-} DsExpr ( dsExpr )
import MatchLit
import DsUtils
import DsMonad
import qualified Language.Haskell.TH as TH
......@@ -45,11 +44,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
import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
import Module
import Id
import Name
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
import NameEnv
import TcType
import TyCon
......
......@@ -131,7 +131,9 @@ 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_rhs :: LHsExpr idR, -- Located only for consistency
var_inline :: Bool -- True <=> inline this binding regardless
-- (used for implication constraints)
}
| AbsBinds { -- Binds abstraction; TRANSLATION
......@@ -353,7 +355,6 @@ 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
......@@ -374,7 +375,6 @@ 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
%
......@@ -299,8 +300,12 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc
fun_tick = Nothing }
mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
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 }
------------
mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
......
......@@ -1124,10 +1124,6 @@ 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
......@@ -1139,17 +1135,36 @@ instance Binary IfaceInfoItem where
return (HsUnfold ad)
3 -> do ad <- get bh
return (HsInline ad)
4 -> do return HsNoCafRefs
_ -> do ae <- get bh
af <- get bh
return (HsWorker ae af)
_ -> do return HsNoCafRefs
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold e) = do
putByte bh 0
put_ bh e
put_ bh (IfInlineRule a e) = do