Commit e0d750be authored by simonpj's avatar simonpj

[project @ 2001-09-26 15:12:33 by simonpj]

------------------
		Simon's big commit
		------------------

This commit, which I don't think I can sensibly do piecemeal, consists
of the things I've been doing recently, mainly directed at making
Manuel, George, and Marcin happier with RULES.


Reogranise the simplifier
~~~~~~~~~~~~~~~~~~~~~~~~~
1. The simplifier's environment is now an explicit parameter.  This
makes it a bit easier to figure out where it is going.

2. Constructor arguments can now be arbitrary expressions, except
when the application is the RHS of a let(rec).  This makes it much
easier to match rules like

	RULES
	    "foo"  f (h x, g y) = f' x y

In the simplifier, it's Simplify.mkAtomicArgs that ANF-ises a
constructor application where necessary.  In the occurrence analyser,
there's a new piece of context info (OccEncl) to say whether a
constructor app is in a place where it should be in ANF.  (Unless
it knows this it'll give occurrence info which will inline the
argument back into the constructor app.)

3. I'm experimenting with doing the "float-past big lambda" transformation
in the full laziness pass, rather than mixed in with the simplifier (was
tryRhsTyLam).

4.  Arrange that
	case (coerce (S,T) (x,y)) of ...
will simplify.  Previous it didn't.
A local change to CoreUtils.exprIsConApp_maybe.

5. Do a better job in CoreUtils.exprEtaExpandArity when there's an
error function in one branch.


Phase numbers, RULES, and INLINE pragmas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.  Phase numbers decrease from N towards zero (instead of increasing).
This makes it easier to add new earlier phases, which is what users want
to do.

2.  RULES get their own phase number, N, and are disabled in phases before N.

e.g. 	{-# RULES "foo" [2] forall x y.  f (x,y) = f' x y #-}

Note the [2], which says "only active in phase 2 and later".

3.  INLINE and NOINLINE pragmas have a phase number to.  This is now treated
in just the same way as the phase number on RULE; that is, the Id is not inlined
in phases earlier than N.  In phase N and later the Id *may* be inlined, and
here is where INLINE and NOINLINE differ: INLNE makes the RHS look small, so
as soon as it *may* be inlined it probably *will* be inlined.

The syntax of the phase number on an INLINE/NOINLINE pragma has changed to be
like the RULES case (i.e. in square brackets).  This should also make sure
you examine all such phase numbers; many will need to change now the numbering
is reversed.

Inlining Ids is no longer affected at all by whether the Id appears on the
LHS of a rule.  Now it's up to the programmer to put a suitable INLINE/NOINLINE
pragma to stop it being inlined too early.


Implementation notes:

*  A new data type, BasicTypes.Activation says when a rule or inline pragma
is active.   Functions isAlwaysActive, isNeverActive, isActive, do the
obvious thing (all in BasicTypes).

* Slight change in the SimplifierSwitch data type, which led to a lot of
simplifier-specific code moving from CmdLineOpts to SimplMonad; a Good Thing.

* The InlinePragma in the IdInfo of an Id is now simply an Activation saying
when the Id can be inlined.  (It used to be a rather bizarre pair of a
Bool and a (Maybe Phase), so this is much much easier to understand.)

* The simplifier has a "mode" environment switch, replacing the old
black list.  Unfortunately the data type decl has to be in
CmdLineOpts, because it's an argument to the CoreDoSimplify switch

    data SimplifierMode = SimplGently | SimplPhase Int

Here "gently" means "no rules, no inlining".   All the crucial
inlining decisions are now collected together in SimplMonad
(preInlineUnconditionally, postInlineUnconditionally, activeInline,
activeRule).


Specialisation
~~~~~~~~~~~~~~
1.  Only dictionary *functions* are made INLINE, not dictionaries that
have no parameters.  (This inline-dictionary-function thing is Marcin's
idea and I'm still not sure whether it's a good idea.  But it's definitely
a Bad Idea when there are no arguments.)

2.  Be prepared to specialise an INLINE function: an easy fix in
Specialise.lhs

But there is still a problem, which is that the INLINE wins
at the call site, so we don't use the specialised version anyway.
I'm still unsure whether it makes sense to SPECIALISE something
you want to INLINE.





Random smaller things
~~~~~~~~~~~~~~~~~~~~~~

* builtinRules (there was only one, but may be more) in PrelRules are now
  incorporated.   They were being ignored before...

* OrdList.foldOL -->  OrdList.foldrOL, OrdList.foldlOL

* Some tidying up of the tidyOpenTyVar, tidyTyVar functions.  I've
  forgotten exactly what!
parent 5cd3527d
......@@ -38,7 +38,10 @@ module BasicTypes(
EP(..),
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
CompilerPhase, pprPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive
) where
#include "HsVersions.h"
......@@ -289,7 +292,7 @@ isDeadOcc other = False
isFragileOcc :: OccInfo -> Bool
isFragileOcc (OneOcc _ _) = True
isFragileOcc other = False
isFragileOcc other = False
\end{code}
\begin{code}
......@@ -335,3 +338,43 @@ instance Outputable StrictnessMark where
ppr MarkedUnboxed = ptext SLIT("! !")
ppr NotMarkedStrict = empty
\end{code}
%************************************************************************
%* *
\subsection{Activation}
%* *
%************************************************************************
When a rule or inlining is active
\begin{code}
type CompilerPhase = Int -- Compilation phase
-- Phases decrease towards zero
-- Zero is the last phase
pprPhase :: CompilerPhase -> SDoc
pprPhase n = brackets (int n)
data Activation = NeverActive
| AlwaysActive
| ActiveAfter CompilerPhase -- Active in this phase and later
deriving( Eq ) -- Eq used in comparing rules in HsDecls
instance Outputable Activation where
ppr AlwaysActive = empty -- The default
ppr (ActiveAfter n) = pprPhase n
ppr NeverActive = ptext SLIT("NEVER")
isActive :: CompilerPhase -> Activation -> Bool
isActive p NeverActive = False
isActive p AlwaysActive = True
isActive p (ActiveAfter n) = p <= n
isNeverActive, isAlwaysActive :: Activation -> Bool
isNeverActive NeverActive = True
isNeverActive act = False
isAlwaysActive AlwaysActive = True
isAlwaysActive other = False
\end{code}
\ No newline at end of file
......@@ -533,3 +533,4 @@ zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
\end{code}
......@@ -50,8 +50,7 @@ module IdInfo (
-- Inline prags
InlinePragInfo(..),
inlinePragInfo, setInlinePragInfo, pprInlinePragInfo,
isNeverInlinePrag, neverInlinePrag,
inlinePragInfo, setInlinePragInfo,
-- Occurrence info
OccInfo(..), isFragileOcc, isDeadOcc, isLoopBreaker,
......@@ -89,7 +88,8 @@ import Var ( Id )
import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
Arity
Arity,
Activation(..)
)
import DataCon ( DataCon )
import ForeignCall ( ForeignCall )
......@@ -331,7 +331,7 @@ vanillaIdInfo
unfoldingInfo = noUnfolding,
cprInfo = NoCPRInfo,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = NoInlinePragInfo,
inlinePragInfo = AlwaysActive,
occInfo = NoOccInfo,
newDemandInfo = topDmd,
newStrictnessInfo = Nothing
......@@ -390,36 +390,13 @@ ppArityInfo (Just arity) = hsep [ptext SLIT("Arity"), int arity]
%************************************************************************
\begin{code}
data InlinePragInfo
= NoInlinePragInfo
| IMustNotBeINLINEd Bool -- True <=> came from an INLINE prag, False <=> came from a NOINLINE prag
(Maybe Int) -- Phase number from pragma, if any
deriving( Eq )
-- The True, Nothing case doesn't need to be recorded
-- SEE COMMENTS WITH CoreUnfold.blackListed on the
-- exact significance of the IMustNotBeINLINEd pragma
isNeverInlinePrag :: InlinePragInfo -> Bool
isNeverInlinePrag (IMustNotBeINLINEd _ Nothing) = True
isNeverInlinePrag other = False
neverInlinePrag :: InlinePragInfo
neverInlinePrag = IMustNotBeINLINEd True{-should be False? --SDM -} Nothing
instance Outputable InlinePragInfo where
-- This is now parsed in interface files
ppr NoInlinePragInfo = empty
ppr other_prag = ptext SLIT("__U") <> pprInlinePragInfo other_prag
pprInlinePragInfo NoInlinePragInfo = empty
pprInlinePragInfo (IMustNotBeINLINEd True Nothing) = empty
pprInlinePragInfo (IMustNotBeINLINEd True (Just n)) = brackets (int n)
pprInlinePragInfo (IMustNotBeINLINEd False Nothing) = brackets (char '!')
pprInlinePragInfo (IMustNotBeINLINEd False (Just n)) = brackets (char '!' <> int n)
instance Show InlinePragInfo where
showsPrec p prag = showsPrecSDoc p (ppr prag)
type InlinePragInfo = Activation
-- Tells when the inlining is active
-- When it is active the thing may be inlined, depending on how
-- big it is.
--
-- If there was an INLINE pragma, then as a separate matter, the
-- RHS will have been made to look small with a CoreSyn Inline Note
\end{code}
......
......@@ -435,7 +435,6 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
`setArityInfo` arity
`setUnfoldingInfo` mkTopUnfolding rhs_w_str
`setNewStrictnessInfo` Just strict_sig
-- Unfolding and strictness added by dmdAnalTopId
-- Allocate Ids. We do it a funny way round because field_dict_tys is
-- almost always empty. Also note that we use length_tycon_theta
......@@ -902,8 +901,6 @@ pcMiscPrelId key mod str ty info
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
arity = 1
strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
-- these "bottom" out, no matter what their arguments
......
......@@ -11,7 +11,7 @@ module VarSet (
elemVarSet, varSetElems, subVarSet,
unionVarSet, unionVarSets,
intersectVarSet, intersectsVarSet,
isEmptyVarSet, delVarSet, delVarSetByKey,
isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
minusVarSet, foldVarSet, filterVarSet,
lookupVarSet, mapVarSet, sizeVarSet, seqVarSet
) where
......@@ -44,6 +44,7 @@ unitVarSet :: Var -> VarSet
extendVarSet :: VarSet -> Var -> VarSet
elemVarSet :: Var -> VarSet -> Bool
delVarSet :: VarSet -> Var -> VarSet
delVarSetList :: VarSet -> [Var] -> VarSet
minusVarSet :: VarSet -> VarSet -> VarSet
isEmptyVarSet :: VarSet -> Bool
mkVarSet :: [Var] -> VarSet
......@@ -74,6 +75,7 @@ varSetElems = uniqSetToList
elemVarSet = elementOfUniqSet
minusVarSet = minusUniqSet
delVarSet = delOneFromUniqSet
delVarSetList = delListFromUniqSet
isEmptyVarSet = isEmptyUniqSet
mkVarSet = mkUniqSet
foldVarSet = foldUniqSet
......
......@@ -161,7 +161,7 @@ make the whole module an orphan module, which is bad.
\begin{code}
ruleLhsFreeNames :: IdCoreRule -> NameSet
ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn)
ruleLhsFreeNames (fn, Rule _ tpl_vars tpl_args rhs)
ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs)
= addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
exprFreeNames :: CoreExpr -> NameSet
......@@ -202,14 +202,14 @@ del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bnd
\begin{code}
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule _ _) = noFVs
ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
= rule_fvs isLocalVar emptyVarSet
where
rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
ruleSomeFreeVars interesting (BuiltinRule _ _) = noFVs
ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
ruleSomeFreeVars interesting (Rule _ _ tpl_vars tpl_args rhs)
= rule_fvs interesting emptyVarSet
where
rule_fvs = addBndrs tpl_vars $
......@@ -219,7 +219,7 @@ ruleLhsFreeIds :: CoreRule -> VarSet
-- This finds all the free Ids on the LHS of the rule
-- *including* imported ids
ruleLhsFreeIds (BuiltinRule _ _) = noFVs
ruleLhsFreeIds (Rule _ tpl_vars tpl_args rhs)
ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
= foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars
\end{code}
......
......@@ -10,7 +10,7 @@ module CorePrep (
#include "HsVersions.h"
import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand )
import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
......@@ -103,15 +103,22 @@ corePrepExpr dflags expr
-- ---------------------------------------------------------------------------
data FloatingBind = FloatLet CoreBind
| FloatCase Id CoreExpr
| FloatCase Id CoreExpr Bool
-- The bool indicates "ok-for-speculation"
type CloneEnv = IdEnv Id -- Clone local Ids
allLazy :: OrdList FloatingBind -> Bool
allLazy floats = foldOL check True floats
allLazy floats = foldrOL check True floats
where
check (FloatLet _) y = y
check (FloatCase _ _) y = False
check (FloatLet _) y = y
check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
-- The ok-for-speculation flag says that it's safe to
-- float this Case out of a let, and thereby do it more eagerly
-- ---------------------------------------------------------------------------
-- Bindings
-- ---------------------------------------------------------------------------
corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
corePrepTopBinds env [] = returnUs []
......@@ -120,15 +127,11 @@ corePrepTopBinds env (bind : binds)
= corePrepBind env bind `thenUs` \ (env', floats) ->
ASSERT( allLazy floats )
corePrepTopBinds env' binds `thenUs` \ binds' ->
returnUs (foldOL add binds' floats)
returnUs (foldrOL add binds' floats)
where
add (FloatLet bind) binds = bind : binds
-- ---------------------------------------------------------------------------
-- Bindings
-- ---------------------------------------------------------------------------
corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
-- Used for non-top-level bindings
-- We return a *list* of bindings, because we may start with
......@@ -345,7 +348,7 @@ maybeSaturate fn expr n_args ty
fn_arity = idArity fn
excess_arity = fn_arity - n_args
saturate_it = getUs `thenUs` \ us ->
returnUs (etaExpand excess_arity us expr ty)
returnUs (etaExpand excess_arity (uniqsFromSupply us) expr ty)
-- ---------------------------------------------------------------------------
-- Precipitating the floating bindings
......@@ -384,7 +387,7 @@ mkNonRec bndr dem floats rhs
-- It's a strict let, or the binder is unlifted,
-- so we definitely float all the bindings
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
returnUs (floats `snocOL` FloatCase bndr rhs)
returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs))
| otherwise
-- Don't float
......@@ -398,10 +401,10 @@ mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
| isNilOL binds = returnUs body
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldOL mk_bind body' binds)
returnUs (foldrOL mk_bind body' binds)
where
mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
-- ---------------------------------------------------------------------------
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
......@@ -569,7 +572,7 @@ cloneBndrs env bs = mapAccumLUs cloneBndr env bs
cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr env bndr
| isId bndr && isLocalId bndr -- Top level things, which we don't want
-- to clone, have become ConstantIds by now
-- to clone, have become GlobalIds by now
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
......
......@@ -18,7 +18,7 @@ module CoreSyn (
isTyVar, isId,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs, collectBindersIgnoringNotes,
collectArgs,
coreExprCc,
flattenBinds,
......@@ -55,6 +55,7 @@ import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConId )
import BasicTypes ( Activation )
import VarSet
import Outputable
\end{code}
......@@ -169,6 +170,7 @@ type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside the
data CoreRule
= Rule RuleName
Activation -- When the rule is active
[CoreBndr] -- Forall'd variables
[CoreExpr] -- LHS args
CoreExpr -- RHS
......@@ -181,7 +183,7 @@ isBuiltinRule (BuiltinRule _ _) = True
isBuiltinRule _ = False
ruleName :: CoreRule -> RuleName
ruleName (Rule n _ _ _) = n
ruleName (Rule n _ _ _ _) = n
ruleName (BuiltinRule n _) = n
\end{code}
......@@ -423,7 +425,6 @@ order.
\begin{code}
collectBinders :: Expr b -> ([b], Expr b)
collectBindersIgnoringNotes :: Expr b -> ([b], Expr b)
collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
collectValBinders :: CoreExpr -> ([Id], CoreExpr)
collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
......@@ -434,16 +435,6 @@ collectBinders expr
go bs (Lam b e) = go (b:bs) e
go bs e = (reverse bs, e)
-- This one ignores notes. It's used in CoreUnfold and StrAnal
-- when we aren't going to put the expression back together from
-- the pieces, so we don't mind losing the Notes
collectBindersIgnoringNotes expr
= go [] expr
where
go bs (Lam b e) = go (b:bs) e
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
collectTyAndValBinders expr
= (tvs, ids, body)
where
......@@ -571,8 +562,8 @@ seqRules :: CoreRules -> ()
seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
seq_rules [] = ()
seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
seq_rules (BuiltinRule _ _ : rules) = seq_rules rules
seq_rules (Rule fs _ bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
seq_rules (BuiltinRule _ _ : rules) = seq_rules rules
\end{code}
......
......@@ -15,24 +15,27 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
import PprCore ( pprIdCoreRule )
import CoreLint ( showPass, endPass )
import VarEnv
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
idSpecialisation, idUnique, isDataConWrapId,
mkVanillaGlobal, isLocalId, isRecordSelector,
setIdUnfolding, hasNoBinding, mkUserLocal,
idNewDemandInfo, setIdNewDemandInfo
mkVanillaGlobal, mkGlobalId, isLocalId,
hasNoBinding, mkUserLocal, isGlobalId, globalIdDetails,
idNewDemandInfo, setIdNewDemandInfo,
idNewStrictness_maybe, setIdNewStrictness
)
import IdInfo {- loads of stuff -}
import NewDemand ( isBottomingSig, topSig, isStrictDmd )
import BasicTypes ( isNeverActive )
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
localiseName, isGlobalName, setNameUnique
)
import NameEnv ( filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTyVar )
import Type ( tidyTopType, tidyType, tidyTyVarBndr )
import Module ( Module, moduleName )
import HscTypes ( PersistentCompilerState( pcs_PRS ),
PersistentRenamerState( prsOrig ),
......@@ -42,12 +45,13 @@ import HscTypes ( PersistentCompilerState( pcs_PRS ),
)
import FiniteMap ( lookupFM, addToFM )
import Maybes ( maybeToBool, orElse )
import ErrUtils ( showPass )
import ErrUtils ( showPass, dumpIfSet_core )
import SrcLoc ( noSrcLoc )
import UniqFM ( mapUFM )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import List ( partition )
import Util ( mapAccumL )
import Maybe ( isNothing, fromJust )
import Outputable
\end{code}
......@@ -178,6 +182,9 @@ tidyCorePgm dflags mod pcs cg_info_env
md_binds = tidy_binds }
; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
; dumpIfSet_core dflags Opt_D_dump_simpl
"Tidy Core Rules"
(vcat (map pprIdCoreRule tidy_rules))
; return (pcs', tidy_details)
}
......@@ -307,7 +314,7 @@ addExternal (id,rhs) needed
spec_ids
idinfo = idInfo id
dont_inline = isNeverInlinePrag (inlinePragInfo idinfo)
dont_inline = isNeverActive (inlinePragInfo idinfo)
loop_breaker = isLoopBreaker (occInfo idinfo)
bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
spec_ids = rulesRhsFreeVars (specInfo idinfo)
......@@ -429,11 +436,6 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
-- all, but in any case it will have the error message inline so it won't matter.
| isRecordSelector id -- We can't use the "otherwise" case, because that
-- forgets the IdDetails, which forgets that this is
-- a record selector, which confuses an importing module
= (env, id `setIdUnfolding` unfold_info)
| otherwise
-- This function is the heart of Step 2
-- The second env is the one to use for the IdInfo
......@@ -452,7 +454,11 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
cg_info = lookupCgInfo cg_info_env name'
idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id
id' = mkVanillaGlobal name' ty' idinfo'
id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo'
| otherwise = mkVanillaGlobal name' ty' idinfo'
-- The test ensures that record selectors (which must be tidied; see above)
-- retain their details. If it's forgotten, importing modules get confused.
subst_env' = extendVarEnv subst_env2 id id'
maybe_external = lookupVarEnv ext_ids id
......@@ -542,10 +548,10 @@ tidyIdRules env ((fn,rule) : rules)
tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule env rule@(BuiltinRule _ _) = rule
tidyRule env (Rule name vars tpl_args rhs)
tidyRule env (Rule name act vars tpl_args rhs)
= tidyBndrs env vars =: \ (env', vars) ->
map (tidyExpr env') tpl_args =: \ tpl_args ->
(Rule name vars tpl_args (tidyExpr env' rhs))
(Rule name act vars tpl_args (tidyExpr env' rhs))
\end{code}
%************************************************************************
......@@ -560,11 +566,11 @@ tidyBind :: TidyEnv
-> (TidyEnv, CoreBind)
tidyBind env (NonRec bndr rhs)
= tidyBndrWithRhs env (bndr,rhs) =: \ (env', bndr') ->
= tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
(env', NonRec bndr' (tidyExpr env' rhs))
tidyBind env (Rec prs)
= mapAccumL tidyBndrWithRhs env prs =: \ (env', bndrs') ->
= mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
map (tidyExpr env') (map snd prs) =: \ rhss' ->
(env', Rec (zip bndrs' rhss'))
......@@ -611,26 +617,43 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
-- tidyBndr is used for lambda and case binders
tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr env var
| isTyVar var = tidyTyVar env var
| otherwise = tidyId env var
| isTyVar var = tidyTyVarBndr env var
| otherwise = tidyIdBndr env var
tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs env vars = mapAccumL tidyBndr env vars
-- tidyBndrWithRhs is used for let binders
tidyBndrWithRhs :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
tidyBndrWithRhs env (id,rhs)
= add_dmd_info (tidyId env id)
tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
-- Used for local (non-top-level) let(rec)s
tidyLetBndr env (id,rhs)
= ((tidy_env,new_var_env), final_id)
where
-- We add demand info for let(rec) binders, because
-- that's what tells CorePrep to generate a case instead of a thunk
add_dmd_info (env,new_id)
| isStrictDmd dmd_info = (env, setIdNewDemandInfo new_id dmd_info)
| otherwise = (env, new_id)
dmd_info = idNewDemandInfo id
tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
tidyId env@(tidy_env, var_env) id
((tidy_env,var_env), new_id) = tidyIdBndr env id
-- We need to keep around any interesting strictness and demand info
-- because later on we may need to use it when converting to A-normal form.
-- eg.
-- f (g x), where f is strict in its argument, will be converted
-- into case (g x) of z -> f z by CorePrep, but only if f still
-- has its strictness info.
--
-- Similarly for the demand info - on a let binder, this tells
-- CorePrep to turn the let into a case.
final_id
| totally_boring_info = new_id
| otherwise = new_id `setIdNewDemandInfo` dmd_info
`setIdNewStrictness` fromJust maybe_new_strictness
-- override the env we get back from tidyId with the new IdInfo
-- so it gets propagated to the usage sites.
new_var_env = extendVarEnv var_env id final_id
dmd_info = idNewDemandInfo id
maybe_new_strictness = idNewStrictness_maybe id
totally_boring_info = isNothing maybe_new_strictness && not (isStrictDmd dmd_info)
tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr env@(tidy_env, var_env) id
= -- Non-top-level variables
let
-- Give the Id a fresh print-name, *and* rename its type
......@@ -640,7 +663,7 @@ tidyId env@(tidy_env, var_env) id
-- All local Ids now have the same IdInfo, which should save some
-- space.
(tidy_env', occ') = tidyOccName tidy_env (getOccName id)
ty' = tidyType (tidy_env,var_env) (idType id)
ty' = tidyType env (idType id)
id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
var_env' = extendVarEnv var_env id id'
in
......
......@@ -26,7 +26,7 @@ module CoreUnfold (
certainlyWillInline,
okToUnfoldInHiFile,
callSiteInline, blackListed
callSiteInline
) where
#include "HsVersions.h"
......@@ -43,16 +43,14 @@ import PprCore ( pprCoreExpr )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial )
import Id ( Id, idType, isId,
idSpecialisation, idInlinePragma, idUnfolding,
idUnfolding,
isFCallId_maybe, globalIdDetails
)
import VarSet
import DataCon ( isUnboxedTupleCon )
import Literal ( isLitLitLit, litSize )
import PrimOp ( primOpIsDupable, primOpOutOfLine )
import ForeignCall ( okToExposeFCall )
import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
isNeverInlinePrag
)
import IdInfo ( OccInfo(..), GlobalIdDetails(..) )
import Type ( isUnLiftedType )
import PrelNames ( hasKey, buildIdKey, augmentIdKey )
import Bag
......@@ -77,6 +75,7 @@ mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseGlobalExpr expr)
top_lvl
(exprIsValue expr)
-- Already evaluated
......@@ -298,7 +297,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
| fun `hasKey` augmentIdKey = augmentSize
| otherwise
= case globalIdDetails fun of
DataConId dc -> conSizeN (valArgCount args)
DataConId dc -> conSizeN dc (valArgCount args)
FCallId fc -> sizeN opt_UF_DearOp
PrimOpId op -> primOpSize op (valArgCount args)
......@@ -370,24 +369,35 @@ maxSize _ TooBig = TooBig
maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1
| otherwise = s2
sizeZero = SizeIs (_ILIT 0) emptyBag (_ILIT 0)
sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0)
sizeZero = SizeIs (_ILIT 0) emptyBag (_ILIT 0)
sizeOne = SizeIs (_ILIT 1) emptyBag (_ILIT 0)
sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT 0)
conSizeN n = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1)
conSizeN dc n
| isUnboxedTupleCon dc = SizeIs (_ILIT 0) emptyBag (iUnbox n +# _ILIT 1)
| otherwise = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1)
-- Treat constructors as size 1; we are keen to expose them
-- (and we charge separately for their args). We can't treat
-- them as size zero, else we find that (iBox x) has size 1,
-- which is the same as a lone variable; and hence 'v' will
-- always be replaced by (iBox x), where v is bound to iBox x.
--
-- However, unboxed tuples count as size zero
-- I found occasions where we had
-- f x y z = case op# x y z of { s -> (# s, () #) }
-- and f wasn't getting inlined
primOpSize op n_args
| not (primOpIsDupable op) = sizeN opt_UF_DearOp
| not (primOpOutOfLine op) = sizeN (1 - n_args)
| not (primOpOutOfLine op) = sizeN (2 - n_args)
-- Be very keen to inline simple primops.
-- We give a discount of 1 for each arg so that (op# x y z) costs 1.
-- I found occasions where we had
-- f x y z = case op# x y z of { s -> (# s, () #) }
-- and f wasn't getting inlined
-- We give a discount of 1 for each arg so that (op# x y z) costs 2.
-- We can't make it cost 1, else we'll inline let v = (op# x y z)
-- at every use of v, which is excessive.
--
-- A good example is:
-- let x = +# p q in C {x}
-- Even though x get's an occurrence of 'many', its RHS looks cheap,
-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
| otherwise = sizeOne
buildSize = SizeIs (-2#) emptyBag 4#
......@@ -456,8 +466,8 @@ certainlyWillInline :: Id -> Bool
certainlyWillInline v
= case idUnfolding v of
CoreUnfolding _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _)
-> is_value