conType, conPrimRep,
conOkForApp, conOkForAlt, isWHNFCon, isDataCon,
conIsTrivial, conIsCheap, conIsDupable, conStrictness,
- conOkForSpeculation,
+ conOkForSpeculation, hashCon,
DataCon, PrimOp, -- For completeness
import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
)
-import PrimOp ( PrimOp, primOpType, primOpIsDupable,
+import Name ( hashName )
+import PrimOp ( PrimOp, primOpType, primOpIsDupable, primOpTag,
primOpIsCheap, primOpStrictness, primOpOkForSpeculation )
import PrimRep ( PrimRep(..) )
-import DataCon ( DataCon, dataConType, dataConTyCon, isNullaryDataCon, dataConRepStrictness )
+import DataCon ( DataCon, dataConName, dataConType, dataConTyCon, isNullaryDataCon, dataConRepStrictness )
import TyCon ( isNewTyCon )
import Type ( Type, typePrimRep )
import PprType ( pprParendType )
import Util ( thenCmp )
import Ratio ( numerator, denominator )
+import FastString ( uniqueOfFS )
+import Char ( ord )
\end{code}
-- thin air. Integer is, so the type here is really redundant.
\end{code}
-
\begin{code}
instance Outputable Literal where
ppr lit = pprLit lit
pprFSAsString s,
pprParendType ty])
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Hashing
+%* *
+%************************************************************************
+
+Hash values should be zero or a positive integer. No negatives please.
+(They mess up the UniqFM for some reason.)
+
+\begin{code}
+hashCon :: Con -> Int
+hashCon (DataCon dc) = hashName (dataConName dc)
+hashCon (PrimOp op) = primOpTag op + 500 -- Keep it out of range of common ints
+hashCon (Literal lit) = hashLiteral lit
+hashCon other = pprTrace "hashCon" (ppr other) 0
+
+hashLiteral :: Literal -> Int
+hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints
+hashLiteral (MachStr s) = hashFS s
+hashLiteral (MachAddr i) = hashInteger i
+hashLiteral (MachInt i _) = hashInteger i
+hashLiteral (MachInt64 i _) = hashInteger i
+hashLiteral (MachFloat r) = hashRational r
+hashLiteral (MachDouble r) = hashRational r
+hashLiteral (MachLitLit s _) = hashFS s
+hashLiteral (NoRepStr s _) = hashFS s
+hashLiteral (NoRepInteger i _) = hashInteger i
+hashLiteral (NoRepRational r _) = hashRational r
+
+hashRational :: Rational -> Int
+hashRational r = hashInteger (numerator r)
+
+hashInteger :: Integer -> Int
+hashInteger i = abs (fromInteger (i `rem` 10000))
+
+hashFS :: FAST_STRING -> Int
+hashFS s = IBOX( uniqueOfFS s )
+\end{code}
+
-- not safe to print or parse LBVarInfo because it is not really a
-- property of the definition, but a property of the context.
-ppLBVarInfo _ = empty
+pprLBVarInfo NoLBVarInfo = empty
+pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot")
instance Outputable LBVarInfo where
- ppr = ppLBVarInfo
+ ppr = pprLBVarInfo
instance Show LBVarInfo where
showsPrec p c = showsPrecSDoc p (ppr c)
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
- isWiredInName,
+ isWiredInName, hashName,
nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason,
tidyTopName,
-- Provenance
Provenance(..), ImportReason(..), pprProvenance,
ExportFlag(..), PrintUnqualified,
- pprNameProvenance, systemProvenance, hasBetterProv,
+ pprNameProvenance, hasBetterProv,
-- Class NamedThing and overloaded friends
NamedThing(..),
import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
-import Unique ( pprUnique, Unique, Uniquable(..) )
+import Unique ( pprUnique, Unique, Uniquable(..), u2i )
import Outputable
import GlaExts
\end{code}
mkSysLocalName :: Unique -> FAST_STRING -> Name
mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local,
- n_occ = mkSrcVarOcc fs, n_prov = SystemProv }
+ n_occ = mkSrcVarOcc fs, n_prov = systemProvenance }
mkTopName :: Unique -> Module -> FAST_STRING -> Name
-- Make a top-level name; make it Global if top-level
+hashName :: Name -> Int
+hashName name = IBOX( u2i (nameUnique name) )
+
nameUnique name = n_uniq name
nameOccName name = n_occ name
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.31 1999/06/09 14:27:38 simonmar Exp $
+% $Id: CgCase.lhs,v 1.32 1999/06/22 07:59:59 simonpj Exp $
%
%********************************************************
%* *
cgPrimEvalAlts bndr ty alts deflt
= cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
where
- reg = dataReturnConvPrim kind
+ reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty )
+ dataReturnConvPrim kind
kind = typePrimRep ty
cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.21 1999/06/08 15:56:48 simonmar Exp $
+% $Id: CgTailCall.lhs,v 1.22 1999/06/22 08:00:00 simonpj Exp $
%
%********************************************************
%* *
import CgMonad
import AbsCSyn
+import PprAbsC ( pprAmode )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
performPrimReturn doc amode
= let
kind = getAmodeRep amode
- ret_reg = dataReturnConvPrim kind
+ ret_reg = WARN( case kind of { PtrRep -> True; other -> False }, text "primRet" <+> doc <+> pprAmode amode )
+ dataReturnConvPrim kind
assign_possibly = case kind of
VoidRep -> AbsCNop
_interface_ CoreUnfold 1
_exports_
-CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding;
+CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding;
_declarations_
1 data Unfolding;
1 data UnfoldingGuidance;
1 mkUnfolding _:_ CoreSyn.CoreExpr -> Unfolding ;;
1 noUnfolding _:_ Unfolding ;;
1 hasUnfolding _:_ Unfolding -> PrelBase.Bool ;;
+1 isEvaldUnfolding _:_ Unfolding -> PrelBase.Bool ;;
__interface CoreUnfold 1 0 where
-__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding;
+__export CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding hasUnfolding isEvaldUnfolding;
1 data Unfolding;
1 data UnfoldingGuidance;
1 mkUnfolding :: CoreSyn.CoreExpr -> Unfolding ;
1 noUnfolding :: Unfolding ;
1 hasUnfolding :: Unfolding -> PrelBase.Bool ;
+1 isEvaldUnfolding :: Unfolding -> PrelBase.Bool ;
\begin{code}
module CoreUnfold (
- Unfolding(..), UnfoldingGuidance, -- types
+ Unfolding, UnfoldingGuidance, -- types
- noUnfolding, mkUnfolding, getUnfoldingTemplate,
- isEvaldUnfolding, hasUnfolding,
+ noUnfolding, mkUnfolding,
+ mkOtherCon, otherCons,
+ unfoldingTemplate, maybeUnfoldingTemplate,
+ isEvaldUnfolding, isCheapUnfolding,
+ hasUnfolding,
couldBeSmallEnoughToInline,
certainlySmallEnoughToInline,
import PprCore ( pprCoreExpr )
import OccurAnal ( occurAnalyseGlobalExpr )
import BinderInfo ( )
-import CoreUtils ( coreExprType, exprIsTrivial, mkFormSummary, whnfOrBottom,
- FormSummary(..) )
+import CoreUtils ( coreExprType, exprIsTrivial, exprIsValue, exprIsCheap )
import Id ( Id, idType, idUnique, isId,
getIdSpecialisation, getInlinePragma, getIdUnfolding
)
import VarSet
+import Name ( isLocallyDefined )
import Const ( Con(..), isLitLitLit, isWHNFCon )
import PrimOp ( PrimOp(..), primOpIsDupable )
import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..) )
import TyCon ( tyConFamilySize )
-import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe )
+import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe, isUnLiftedType )
import Const ( isNoRepLit )
import Unique ( Unique, buildIdKey, augmentIdKey, runSTRepIdKey )
import Maybes ( maybeToBool )
-- Here, f gets an OtherCon [] unfolding.
| CoreUnfolding -- An unfolding with redundant cached information
- FormSummary -- Tells whether the template is a WHNF or bottom
- UnfoldingGuidance -- Tells about the *size* of the template.
CoreExpr -- Template; binder-info is correct
+ Bool -- exprIsCheap template (cached); it won't duplicate (much) work
+ -- if you inline this in more than one place
+ Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
+ -- this variable
+ UnfoldingGuidance -- Tells about the *size* of the template.
\end{code}
\begin{code}
noUnfolding = NoUnfolding
+mkOtherCon = OtherCon
mkUnfolding expr
- = let
- -- strictness mangling (depends on there being no CSE)
- ufg = calcUnfoldingGuidance opt_UF_CreationThreshold expr
- occ = occurAnalyseGlobalExpr expr
- in
- CoreUnfolding (mkFormSummary expr) ufg occ
+ = CoreUnfolding (occurAnalyseGlobalExpr expr)
+ (exprIsCheap expr)
+ (exprIsValue expr)
+ (calcUnfoldingGuidance opt_UF_CreationThreshold expr)
+
+unfoldingTemplate :: Unfolding -> CoreExpr
+unfoldingTemplate (CoreUnfolding expr _ _ _) = expr
+unfoldingTemplate other = panic "getUnfoldingTemplate"
+
+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _) = Just expr
+maybeUnfoldingTemplate other = Nothing
-getUnfoldingTemplate :: Unfolding -> CoreExpr
-getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr
-getUnfoldingTemplate other = panic "getUnfoldingTemplate"
+otherCons (OtherCon cons) = cons
+otherCons other = []
isEvaldUnfolding :: Unfolding -> Bool
-isEvaldUnfolding (OtherCon _) = True
-isEvaldUnfolding (CoreUnfolding ValueForm _ expr) = True
-isEvaldUnfolding other = False
+isEvaldUnfolding (OtherCon _) = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _) = is_evald
+isEvaldUnfolding other = False
+
+isCheapUnfolding :: Unfolding -> Bool
+isCheapUnfolding (CoreUnfolding _ is_cheap _ _) = is_cheap
+isCheapUnfolding other = False
hasUnfolding :: Unfolding -> Bool
-hasUnfolding NoUnfolding = False
-hasUnfolding other = True
+hasUnfolding (CoreUnfolding _ _ _ _) = True
+hasUnfolding other = False
+
+hasSomeUnfolding :: Unfolding -> Bool
+hasSomeUnfolding NoUnfolding = False
+hasSomeUnfolding other = True
data UnfoldingGuidance
= UnfoldNever
size_up (Let (NonRec binder rhs) body)
= nukeScrutDiscount (size_up rhs) `addSize`
size_up body `addSizeN`
- 1 -- For the allocation
+ (if isUnLiftedType (idType binder) then 0 else 1)
+ -- For the allocation
+ -- If the binder has an unlifted type there is no allocation
size_up (Let (Rec pairs) body)
= nukeScrutDiscount rhs_size `addSize`
size_up (Case scrut _ alts)
= nukeScrutDiscount (size_up scrut) `addSize`
arg_discount scrut `addSize`
- foldr (addSize . size_up_alt) sizeZero alts `addSizeN`
- case (splitAlgTyConApp_maybe (coreExprType scrut)) of
- Nothing -> 1
- Just (tc,_,_) -> tyConFamilySize tc
+ foldr (addSize . size_up_alt) sizeZero alts
+
+-- Just charge for the alts that exist, not the ones that might exist
+-- `addSizeN`
+-- case (splitAlgTyConApp_maybe (coreExprType scrut)) of
+-- Nothing -> 1
+-- Just (tc,_,_) -> tyConFamilySize tc
------------
size_up_app (App fun arg) args = size_up_app fun (arg:args)
-- A function application with at least one value argument
-- so if the function is an argument give it an arg-discount
-- Also behave specially if the function is a build
- fun_discount (Var fun) | idUnique fun == buildIdKey = buildSize
+ fun_discount (Var fun) | idUnique fun == buildIdKey = buildSize
+ | idUnique fun == augmentIdKey = augmentSize
| fun `is_elem` args = scrutArg fun
fun_discount other = sizeZero
-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
-- Indeed, we should add a result_discount becuause build is
-- very like a constructor. We don't bother to check that the
- -- build is saturated (it usually is). The "-2" discounts for the \c n
+ -- build is saturated (it usually is). The "-2" discounts for the \c n,
-- The "4" is rather arbitrary.
+
+augmentSize = SizeIs (-2#) emptyBag 4#
+ -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
+ -- e plus ys. The -2 accounts for the \cn
scrutArg v = SizeIs 0# (unitBag v) 0#
= case getIdUnfolding id of {
NoUnfolding -> Nothing ;
OtherCon _ -> Nothing ;
- CoreUnfolding form guidance unf_template ->
+ CoreUnfolding unf_template is_cheap _ guidance ->
let
result | yes_or_no = Just unf_template
inline_prag = getInlinePragma id
arg_infos = map interestingArg val_args
val_args = filter isValArg args
- whnf = whnfOrBottom form
yes_or_no =
case inline_prag of
IMustNotBeINLINEd -> False
IAmALoopBreaker -> False
IMustBeINLINEd -> True -- Overrides absolutely everything, including the black list
- ICanSafelyBeINLINEd in_lam one_br -> consider in_lam one_br
- NoInlinePragInfo -> consider InsideLam False
+ ICanSafelyBeINLINEd in_lam one_br -> consider in_lam True one_br
+ NoInlinePragInfo -> consider InsideLam False False
- consider in_lam one_branch
+ consider in_lam once once_in_one_branch
| black_listed = False
| inline_call = True
- | one_branch -- Be very keen to inline something if this is its unique occurrence; that
- -- gives a good chance of eliminating the original binding for the thing.
- -- The only time we hold back is when substituting inside a lambda;
- -- then if the context is totally uninteresting (not applied, not scrutinised)
- -- there is no point in substituting because it might just increase allocation.
+ | once_in_one_branch -- Be very keen to inline something if this is its unique occurrence; that
+ -- gives a good chance of eliminating the original binding for the thing.
+ -- The only time we hold back is when substituting inside a lambda;
+ -- then if the context is totally uninteresting (not applied, not scrutinised)
+ -- there is no point in substituting because it might just increase allocation.
= WARN( case in_lam of { NotInsideLam -> True; other -> False },
text "callSiteInline:oneOcc" <+> ppr id )
-- If it has one occurrence, not inside a lambda, PreInlineUnconditionally
-- should have zapped it already
- whnf && (not (null args) || interesting_cont)
+ is_cheap && (not (null args) || interesting_cont)
| otherwise -- Occurs (textually) more than once, so look at its size
= case guidance of
-- Size of call is n_vals_wanted (+1 for the function)
-> case in_lam of
NotInsideLam -> True
- InsideLam -> whnf
+ InsideLam -> is_cheap
- | not (or arg_infos || really_interesting_cont)
+ | not (or arg_infos || really_interesting_cont || once)
-- If it occurs more than once, there must be something interesting
-- about some argument, or the result, to make it worth inlining
+ -- We also drop this case if the thing occurs once, although perhaps in
+ -- several branches. In this case we are keener about inlining in the hope
+ -- that we'll be able to drop the allocation for the function altogether.
-> False
| otherwise
-> case in_lam of
NotInsideLam -> small_enough
- InsideLam -> whnf && small_enough
+ InsideLam -> is_cheap && small_enough
where
n_args = length arg_infos
text "inline prag:" <+> ppr inline_prag,
text "arg infos" <+> ppr arg_infos,
text "interesting continuation" <+> ppr interesting_cont,
- text "whnf" <+> ppr whnf,
+ text "is cheap" <+> ppr is_cheap,
text "guidance" <+> ppr guidance,
text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",
if yes_or_no then
-- There is little point in inlining f here.
interestingArg (Type _) = False
interestingArg (App fn (Type _)) = interestingArg fn
-interestingArg (Var v) = hasUnfolding (getIdUnfolding v)
+interestingArg (Var v) = hasSomeUnfolding (getIdUnfolding v)
interestingArg other = True
-- inlined because of the inline phase we are in. This is the sole
-- place that the inline phase number is looked at.
--- Phase 0: used for 'no inlinings please'
+-- Phase 0: used for 'no imported inlinings please'
+-- This prevents wrappers getting inlined which in turn is bad for full laziness
blackListed rule_vars (Just 0)
- = \v -> True
+ = \v -> not (isLocallyDefined v)
-- Phase 1: don't inline any rule-y things or things with specialisations
blackListed rule_vars (Just 1)
module CoreUtils (
coreExprType, coreAltsType,
- exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap, exprIsValue,
- exprOkForSpeculation,
- FormSummary(..), mkFormSummary, whnfOrBottom, exprArity,
+ exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,
+ exprOkForSpeculation, exprIsBig, hashExpr,
+ exprArity,
cheapEqExpr, eqExpr, applyTypeToArgs
) where
#include "HsVersions.h"
+import {-# SOURCE #-} CoreUnfold ( isEvaldUnfolding )
+
import CoreSyn
import PprCore ( pprCoreExpr )
import Var ( IdOrTyVar, isId, isTyVar )
import VarSet
import VarEnv
-import Name ( isLocallyDefined )
+import Name ( isLocallyDefined, hashName )
import Const ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
- conType, conOkForSpeculation, conStrictness
+ conType, conOkForSpeculation, conStrictness, hashCon
)
import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
- getIdArity,
+ getIdArity, idName,
getIdSpecialisation, setIdSpecialisation,
getInlinePragma, setInlinePragma,
getIdUnfolding, setIdUnfolding, idInfo
%* *
%************************************************************************
-\begin{code}
-data FormSummary
- = VarForm -- Expression is a variable (or scc var, etc)
-
- | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
- -- May 1999: I'm experimenting with allowing "cheap" non-values
- -- here.
-
- | BottomForm -- Expression is guaranteed to be bottom. We're more gung
- -- ho about inlining such things, because it can't waste work
- | OtherForm -- Anything else
-
-instance Outputable FormSummary where
- ppr VarForm = ptext SLIT("Var")
- ppr ValueForm = ptext SLIT("Value")
- ppr BottomForm = ptext SLIT("Bot")
- ppr OtherForm = ptext SLIT("Other")
-
-whnfOrBottom :: FormSummary -> Bool
-whnfOrBottom VarForm = True
-whnfOrBottom ValueForm = True
-whnfOrBottom BottomForm = True
-whnfOrBottom OtherForm = False
-\end{code}
-
-\begin{code}
-mkFormSummary :: CoreExpr -> FormSummary
- -- Used exclusively by CoreUnfold.mkUnfolding
- -- Returns ValueForm for cheap things, not just values
-mkFormSummary expr
- = go (0::Int) expr -- The "n" is the number of *value* arguments so far
- where
- go n (Con con _) | isWHNFCon con = ValueForm
- | otherwise = OtherForm
-
- go n (Note _ e) = go n e
-
- go n (Let (NonRec b r) e) | exprIsCheap r = go n e -- let f = f' alpha in (f,g)
- -- should be treated as a value
- go n (Let _ e) = OtherForm
-
- -- We want selectors to look like values
- -- e.g. case x of { (a,b) -> a }
- -- should give a ValueForm, so that it will be inlined vigorously
- -- [June 99. I can't remember why this is a good idea. It means that
- -- all overloading selectors get inlined at their usage sites, which is
- -- not at all necessarily a good thing. So I'm rescinding this decision for now.]
--- go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
-
- go n expr@(Case _ _ _) = OtherForm
-
- go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom!
- | otherwise = go 0 e
- go n (Lam x e) | isId x = go (n-1) e -- Applied lambda
- | otherwise = go n e
-
- go n (App fun (Type _)) = go n fun -- Ignore type args
- go n (App fun arg) = go (n+1) fun
-
- go n (Var f) | idAppIsBottom f n = BottomForm
- go 0 (Var f) = VarForm
- go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
- | otherwise = OtherForm
-\end{code}
-
@exprIsTrivial@ is true of expressions we are unconditionally
happy to duplicate; simple variables and constants,
and type applications.
@exprIsDupable@ is true of expressions that can be duplicated at a modest
- cost in space. This will only happen in different case
+ cost in code size. This will only happen in different case
branches, so there's no issue about duplicating work.
+
+ That is, exprIsDupable returns True of (f x) even if
+ f is very very expensive to call.
+
Its only purpose is to avoid fruitless let-binding
and then inlining of case join points
it is obviously in weak head normal form, or is cheap to get to WHNF.
[Note that that's not the same as exprIsDupable; an expression might be
big, and hence not dupable, but still cheap.]
-By ``cheap'' we mean a computation we're willing to push inside a lambda
-in order to bring a couple of lambdas together. That might mean it gets
-evaluated more than once, instead of being shared. The main examples of things
-which aren't WHNF but are ``cheap'' are:
+
+By ``cheap'' we mean a computation we're willing to:
+ push inside a lambda, or
+ inline at more than one place
+That might mean it gets evaluated more than once, instead of being
+shared. The main examples of things which aren't WHNF but are
+``cheap'' are:
* case e of
pi -> ei
where op is a cheap primitive operator
+ * error "foo"
+
Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once.
exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
-exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
-exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
- all (\(_,_,rhs) -> exprIsCheap rhs) alts
+
+-- I'm not at all convinced about these two!!
+-- [SLPJ June 99]
+-- exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
+-- exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
+-- all (\(_,_,rhs) -> exprIsCheap rhs) alts
exprIsCheap other_expr -- look for manifest partial application
= case collectArgs other_expr of
go n (Lam _ _) = False
\end{code}
-@exprIsValue@ returns true for expressions that are evaluated.
-It does not treat variables as evaluated.
+@exprIsValue@ returns true for expressions that are certainly *already*
+evaluated to WHNF. This is used to decide wether it's ok to change
+ case x of _ -> e ===> e
+
+and to decide whether it's safe to discard a `seq`
+
+So, it does *not* treat variables as evaluated, unless they say they are
\begin{code}
exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
-- copying them
-exprIsValue (Var v) = False
+exprIsValue (Var v) = isEvaldUnfolding (getIdUnfolding v)
exprIsValue (Lam b e) = isId b || exprIsValue e
exprIsValue (Note _ e) = exprIsValue e
exprIsValue (Let _ e) = False
_ -> False
\end{code}
-exprIsWHNF reports True for head normal forms. Note that does not necessarily
-mean *normal* forms; constructors might have non-trivial argument expressions, for
-example. We use a let binding for WHNFs, rather than a case binding, even if it's
-used strictly. We try to expose WHNFs by floating lets out of the RHS of lets.
-
- We treat applications of buildId and augmentId as honorary WHNFs,
- because we want them to get exposed.
- [May 99: I've disabled this because it looks jolly dangerous:
- we'll substitute inside lambda with potential big loss of sharing.]
-
-\begin{code}
-exprIsWHNF :: CoreExpr -> Bool -- True => Variable, value-lambda, constructor, PAP
-exprIsWHNF (Type ty) = True -- Types are honorary WHNFs; we don't mind
- -- copying them
-exprIsWHNF (Var v) = True
-exprIsWHNF (Lam b e) = isId b || exprIsWHNF e
-exprIsWHNF (Note _ e) = exprIsWHNF e
-exprIsWHNF (Let _ e) = False
-exprIsWHNF (Case _ _ _) = False
-exprIsWHNF (Con con _) = isWHNFCon con
-exprIsWHNF e@(App _ _) = case collectArgs e of
- (Var v, args) -> n_val_args == 0
- || fun_arity > n_val_args
--- [May 99: disabled. See note above] || v_uniq == buildIdKey
--- || v_uniq == augmentIdKey
- where
- n_val_args = valArgCount args
- fun_arity = arityLowerBound (getIdArity v)
- v_uniq = idUnique v
-
- _ -> False
-\end{code}
-
\begin{code}
exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
exprArity (Lam b e) | isTyVar b = exprArity e
cheapEqExpr (Type t1) (Type t2) = t1 == t2
cheapEqExpr _ _ = False
+
+exprIsBig :: Expr b -> Bool
+-- Returns True of expressions that are too big to be compared by cheapEqExpr
+exprIsBig (Var v) = False
+exprIsBig (Type t) = False
+exprIsBig (App f a) = exprIsBig f || exprIsBig a
+exprIsBig (Con _ args) = any exprIsBig args
+exprIsBig other = True
\end{code}
eq_note env other1 other2 = False
\end{code}
+%************************************************************************
+%* *
+\subsection{Hashing}
+%* *
+%************************************************************************
+
+\begin{code}
+hashExpr :: CoreExpr -> Int
+hashExpr (Note _ e) = hashExpr e
+hashExpr (Let (NonRec b r) e) = hashId b
+hashExpr (Let (Rec ((b,r):_)) e) = hashId b
+hashExpr (Case _ b _) = hashId b
+hashExpr (App f e) = hashExpr f
+hashExpr (Var v) = hashId v
+hashExpr (Con con args) = hashArgs args (hashCon con)
+hashExpr (Lam b _) = hashId b
+hashExpr (Type t) = trace "hashExpr: type" 0 -- Shouldn't happen
+
+hashArgs [] con = con
+hashArgs (Type t : args) con = hashArgs args con
+hashArgs (arg : args) con = hashExpr arg
+
+hashId :: Id -> Int
+hashId id = hashName (idName id)
+\end{code}
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
demandInfo, updateInfo, ppUpdateInfo, specInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
- cprInfo, ppCprInfo
+ cprInfo, ppCprInfo, lbvarInfo
)
import Const ( Con(..), DataCon )
import DataCon ( isTupleCon, isUnboxedTupleCon )
-- It's important that the type is parenthesised too, at least when
-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
--- When printing any Id binder in debug mode, we print its inline pragma
-pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id))
+-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
+pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id))
\end{code}
ppr d,
ppCafInfo c,
ppCprInfo m,
+ ppr (lbvarInfo info),
pprIfaceCoreRules p
-- Inline pragma printed out with all binders; see PprCore.pprIdBndr
]
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules
)
-import CoreUnfold ( hasUnfolding, noUnfolding )
import CoreFVs ( exprFreeVars )
import Type ( Type(..), ThetaType, TyNote(..),
tyVarsOfType, tyVarsOfTypes, mkAppTy
opt_D_dump_absC,
opt_D_dump_asm,
opt_D_dump_cpranal,
+ opt_D_dump_cse,
opt_D_dump_deriv,
opt_D_dump_ds,
opt_D_dump_flatC,
| CoreDoSpecialising
| CoreDoUSPInf
| CoreDoCPResult
+ | CoreCSE
\end{code}
\begin{code}
opt_D_dump_tc = lookUp SLIT("-ddump-tc")
opt_D_dump_rules = lookUp SLIT("-ddump-rules")
opt_D_dump_usagesp = lookUp SLIT("-ddump-usagesp")
+opt_D_dump_cse = lookUp SLIT("-ddump-cse")
opt_D_dump_worker_wrapper = lookUp SLIT("-ddump-workwrap")
opt_D_show_passes = lookUp SLIT("-dshow-passes")
opt_D_dump_rn_trace = lookUp SLIT("-ddump-rn-trace")
opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int)
opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (2.0::Float)
-opt_UF_CheapOp = ( 1 :: Int)
-opt_UF_DearOp = ( 8 :: Int)
+opt_UF_CheapOp = ( 0 :: Int) -- Only one instruction; and the args are charged for
+opt_UF_DearOp = ( 4 :: Int)
opt_UF_NoRepLit = ( 20 :: Int) -- Strings can be pretty big
opt_ProduceS = lookup_str "-S="
"-ffloat-inwards" -> CORE_TD(CoreDoFloatInwards)
"-ffull-laziness" -> CORE_TD(CoreDoFullLaziness)
"-fliberate-case" -> CORE_TD(CoreLiberateCase)
+ "-fcse" -> CORE_TD(CoreCSE)
"-fprint-core" -> CORE_TD(CoreDoPrintCore)
"-fstatic-args" -> CORE_TD(CoreDoStaticArgs)
"-fstrictness" -> CORE_TD(CoreDoStrictness)
import Name ( Name, OccName, Provenance(..),
NameSpace, tcName, clsName, varName, dataName,
mkKnownKeyGlobal,
- getName, mkGlobalName, nameRdrName, systemProvenance
+ getName, mkGlobalName, nameRdrName
)
import RdrName ( rdrNameModule, rdrNameOcc, mkSrcQual )
import Class ( Class, classKey )
module PrimOp (
PrimOp(..), allThePrimOps,
primOpType, primOpSig, primOpUsg,
- mkPrimOpIdName, primOpRdrName,
+ mkPrimOpIdName, primOpRdrName, primOpTag,
commutableOp,
Used for the Ord instance
\begin{code}
+primOpTag :: PrimOp -> Int
+primOpTag op = IBOX( tagOf_PrimOp op )
+
tagOf_PrimOp CharGtOp = (ILIT( 1) :: FAST_INT)
tagOf_PrimOp CharGeOp = ILIT( 2)
tagOf_PrimOp CharEqOp = ILIT( 3)
= mkWiredInIdName key pREL_GHC occ_name id
where
occ_name = primOpOcc op
- key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
+ key = mkPrimOpIdUnique (primOpTag op)
primOpRdrName :: PrimOp -> RdrName
import PrimOp ( PrimOp(..) )
import SimplMonad
import TysWiredIn ( trueDataCon, falseDataCon )
-import TyCon ( tyConDataCons, isEnumerationTyCon )
-import DataCon ( dataConTag, fIRST_TAG )
+import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon )
+import DataCon ( dataConTag, dataConTyCon, fIRST_TAG )
import Const ( conOkForAlt )
-import CoreUnfold ( Unfolding(..), isEvaldUnfolding )
+import CoreUnfold ( maybeUnfoldingTemplate )
import CoreUtils ( exprIsValue )
import Type ( splitTyConApp_maybe )
+import Maybes ( maybeToBool )
import Char ( ord, chr )
import Outputable
\end{code}
\begin{code}
tryPrimOp SeqOp [Type ty, arg]
- | is_evald arg
+ | exprIsValue arg
= Just (Con (Literal (mkMachInt 1)) [])
- where
- is_evald (Var v) = isEvaldUnfolding (getIdUnfolding v)
- is_evald arg = exprIsValue arg
\end{code}
\begin{code}
tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
= Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
tryPrimOp DataToTagOp [Type ty, Var x]
- | has_unfolding && unfolding_is_constr
- = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+ | maybeToBool maybe_constr
+ = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+ Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
where
- has_unfolding = case unfolding of
- CoreUnfolding _ _ _ -> True
- other -> False
- unfolding = getIdUnfolding x
- CoreUnfolding form guidance unf_template = unfolding
- unfolding_is_constr = case unf_template of
- Con con@(DataCon _) _ -> conOkForAlt con
- other -> False
- Con (DataCon dc) con_args = unf_template
+ maybe_constr = case maybeUnfoldingTemplate (getIdUnfolding x) of
+ Just (Con (DataCon dc) _) -> Just dc
+ other -> Nothing
+ Just dc = maybe_constr
\end{code}
\begin{code}
fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
noFloatIntoRhs (AnnNote InlineMe _) = True
-noFloatIntoRhs (AnnLam _ _) = True
+noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b)
+ -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
+ -- This makes a big difference for things like
+ -- f x# = let x = I# x#
+ -- in let j = \() -> ...x...
+ -- in if <condition> then normal-path else j ()
+ -- If x is used only in the error case join point, j, we must float the
+ -- boxing constructor into it, else we box it every time which is very bad
+ -- news indeed.
noFloatIntoRhs (AnnCon con _) = isDataCon con
noFloatIntoRhs other = False
\end{code}
* We clone the binders of any floatable let-binding, so that when it is
floated out it will be unique. (This used to be done by the simplifier
but the latter now only ensures that there's no shadowing.)
+ NOTE: Very tiresomely, we must apply this substitution to
+ the rules stored inside a variable too.
import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom )
import CoreFVs -- all of it
-import Id ( Id, idType, mkSysLocal, isOneShotLambda )
+import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo )
+import IdInfo ( specInfo, setSpecInfo )
import Var ( IdOrTyVar, Var, setVarUnique )
import VarEnv
+import Subst
import VarSet
import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
import VarSet
ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
\end{code}
-\begin{code}
-type LevelEnv = VarEnv (Var, Level)
- -- We clone let-bound variables so that they are still
- -- distinct when floated out; hence the Var in the range
-
-extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
- -- Used when *not* cloning
-extendLvlEnv env prs = foldl add env prs
- where
- add env (v,l) = extendVarEnv env v (v,l)
-
-varLevel :: LevelEnv -> IdOrTyVar -> Level
-varLevel env v
- = case lookupVarEnv env v of
- Just (_,level) -> level
- Nothing -> tOP_LEVEL
-
-maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
-maxIdLvl env var lvl | isTyVar var = lvl
- | otherwise = case lookupVarEnv env var of
- Just (_,lvl') -> maxLvl lvl' lvl
- Nothing -> lvl
-
-maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
-maxTyVarLvl env var lvl | isId var = lvl
- | otherwise = case lookupVarEnv env var of
- Just (_,lvl') -> maxLvl lvl' lvl
- Nothing -> lvl
-\end{code}
-
%************************************************************************
%* *
\subsection{Main level-setting code}
do_them bs `thenLvl` \ lvld_binds ->
returnLvl (lvld_bind ++ lvld_binds)
-initialEnv = emptyVarEnv
-
lvlTopBind (NonRec binder rhs)
= lvlBind Top initialEnv (AnnNonRec binder (freeVars rhs))
-- Rhs can have no free vars!
lvlBind ctxt_lvl env (AnnNonRec bndr rhs)
= setFloatLevel (Just bndr) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') ->
- cloneVar ctxt_lvl bndr `thenLvl` \ new_bndr ->
- let
- new_env = extendVarEnv env bndr (new_bndr,final_lvl)
- in
+ cloneVar ctxt_lvl env bndr final_lvl `thenLvl` \ (new_env, new_bndr) ->
returnLvl ([NonRec (new_bndr, final_lvl) rhs'], new_env)
where
ty = idType bndr
\begin{code}
lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
-lvlExpr _ env (_, AnnVar v) = case lookupVarEnv env v of
- Just (v',_) -> returnLvl (Var v')
- Nothing -> returnLvl (Var v)
+lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
lvlExpr ctxt_lvl env (_, AnnCon con args)
= mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' ->
= lvlMFE incd_lvl new_env body `thenLvl` \ body' ->
returnLvl (mkLams lvld_bndrs body')
where
- bndr_is_id = isId bndr
- bndr_is_tyvar = isTyVar bndr
- (bndrs, body) = go rhs
+ bndr_is_id = isId bndr
+ bndr_is_tyvar = isTyVar bndr
+ (more_bndrs, body) = go rhs
+ bndrs = bndr : more_bndrs
incd_lvl | bndr_is_id && not (all isOneShotLambda bndrs) = incMajorLvl ctxt_lvl
| otherwise = incMinorLvl ctxt_lvl
-- Only bump the major level number if the binders include
-- at least one more-than-one-shot lambda
- lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
+ lvld_bndrs = [(b,incd_lvl) | b <- bndrs]
new_env = extendLvlEnv env lvld_bndrs
go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr
where
expr_type = coreExprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
- alts_env = extendVarEnv env case_bndr (case_bndr,incd_lvl)
+ alts_env = extendLvlEnv env [(case_bndr,incd_lvl)]
lvl_alt (con, bs, rhs)
= let
in
mapLvl (lvlExpr incd_lvl rhs_env) rhss `thenLvl` \ rhss' ->
mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
- mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs ->
+ cloneVars ctxt_lvl env bndrs ctxt_lvl `thenLvl` \ (new_env, new_bndrs) ->
let
-- The "d_rhss" are the right-hand sides of "D" and "D'"
-- in the documentation above
-- The new right-hand sides, just a type application,
-- aren't worth floating so pin it with ctxt_lvl
bndrs_w_lvl = new_bndrs `zip` repeat ctxt_lvl
- new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvl)
-- "d_binds" are the "D" in the documentation above
d_binds = zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss
| otherwise
= -- Let it float freely
- mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs ->
+ cloneVars ctxt_lvl env bndrs expr_lvl `thenLvl` \ (new_env, new_bndrs) ->
let
bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl
- new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvls)
in
mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' ->
returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env)
%************************************************************************
\begin{code}
+type LevelEnv = (VarEnv Level, SubstEnv)
+ -- We clone let-bound variables so that they are still
+ -- distinct when floated out; hence the SubstEnv
+ -- The domain of the VarEnv is *pre-cloned* Ids, though
+
+initialEnv :: LevelEnv
+initialEnv = (emptyVarEnv, emptySubstEnv)
+
+extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
+ -- Used when *not* cloning
+extendLvlEnv (lvl_env, subst_env) prs
+ = (foldl add lvl_env prs, subst_env)
+ where
+ add env (v,l) = extendVarEnv env v l
+
+varLevel :: LevelEnv -> IdOrTyVar -> Level
+varLevel (lvl_env, _) v
+ = case lookupVarEnv lvl_env v of
+ Just level -> level
+ Nothing -> tOP_LEVEL
+
+lookupVar :: LevelEnv -> Id -> LevelledExpr
+lookupVar (_, subst) v = case lookupSubstEnv subst v of
+ Just (DoneEx (Var v')) -> Var v' -- Urgh! Types don't match
+ other -> Var v
+
+maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxIdLvl (lvl_env,_) var lvl | isTyVar var = lvl
+ | otherwise = case lookupVarEnv lvl_env var of
+ Just lvl' -> maxLvl lvl' lvl
+ Nothing -> lvl
+
+maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxTyVarLvl (lvl_env,_) var lvl | isId var = lvl
+ | otherwise = case lookupVarEnv lvl_env var of
+ Just lvl' -> maxLvl lvl' lvl
+ Nothing -> lvl
+\end{code}
+
+\begin{code}
type LvlM result = UniqSM result
initLvl = initUs_
newLvlVar ty = getUniqueUs `thenLvl` \ uniq ->
returnUs (mkSysLocal SLIT("lvl") uniq ty)
-cloneVar :: Level -> Id -> LvlM Id
-cloneVar Top v = returnUs v -- Don't clone top level things
-cloneVar _ v = getUniqueUs `thenLvl` \ uniq ->
- returnUs (setVarUnique v uniq)
+-- The deeply tiresome thing is that we have to apply the substitution
+-- to the rules inside each Id. Grr. But it matters.
+
+cloneVar :: Level -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id)
+cloneVar Top env v lvl
+ = returnUs (env, v) -- Don't clone top level things
+cloneVar _ (lvl_env, subst_env) v lvl
+ = getUniqueUs `thenLvl` \ uniq ->
+ let
+ subst = mkSubst emptyVarSet subst_env
+ v' = setVarUnique v uniq
+ v'' = apply_to_rules subst v'
+ subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
+ lvl_env' = extendVarEnv lvl_env v lvl
+ in
+ returnUs ((lvl_env', subst_env'), v'')
+
+cloneVars :: Level -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
+cloneVars Top env vs lvl
+ = returnUs (env, vs) -- Don't clone top level things
+cloneVars _ (lvl_env, subst_env) vs lvl
+ = getUniquesUs (length vs) `thenLvl` \ uniqs ->
+ let
+ subst = mkSubst emptyVarSet subst_env'
+ vs' = zipWith setVarUnique vs uniqs
+ vs'' = map (apply_to_rules subst) vs'
+ subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
+ lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl)
+ in
+ returnUs ((lvl_env', subst_env'), vs'')
+
+-- Apply the substitution to the rules
+apply_to_rules subst id
+ = modifyIdInfo go_spec id
+ where
+ go_spec info = info `setSpecInfo` substRules subst (specInfo info)
\end{code}
-%\r
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
-%\r
-\section[SimplCore]{Driver for simplifying @Core@ programs}\r
-\r
-\begin{code}\r
-module SimplCore ( core2core ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), \r
- SwitchResult(..), switchIsOn, intSwitchSet,\r
- opt_D_dump_occur_anal, opt_D_dump_rules,\r
- opt_D_dump_simpl_iterations,\r
- opt_D_dump_simpl_stats,\r
- opt_D_dump_simpl, opt_D_dump_rules,\r
- opt_D_verbose_core2core,\r
- opt_D_dump_occur_anal,\r
- opt_UsageSPOn,\r
- )\r
-import CoreLint ( beginPass, endPass )\r
-import CoreTidy ( tidyCorePgm )\r
-import CoreSyn\r
-import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )\r
-import CoreUnfold\r
-import PprCore ( pprCoreBindings )\r
-import OccurAnal ( occurAnalyseBinds )\r
-import CoreUtils ( exprIsTrivial, coreExprType )\r
-import Simplify ( simplTopBinds, simplExpr )\r
-import SimplUtils ( etaCoreExpr, findDefault, simplBinders )\r
-import SimplMonad\r
-import Const ( Con(..), Literal(..), literalType, mkMachInt )\r
-import ErrUtils ( dumpIfSet )\r
-import FloatIn ( floatInwards )\r
-import FloatOut ( floatOutwards )\r
-import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,\r
- idType, setIdType, idName, idInfo, setIdNoDiscard\r
- )\r
-import VarEnv\r
-import VarSet\r
-import Module ( Module )\r
-import Name ( mkLocalName, tidyOccName, tidyTopName, \r
- NamedThing(..), OccName\r
- )\r
-import TyCon ( TyCon, isDataTyCon )\r
-import PrimOp ( PrimOp(..) )\r
-import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )\r
-import Type ( Type, splitAlgTyConApp_maybe, \r
- isUnLiftedType,\r
- tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,\r
- Type\r
- )\r
-import TysWiredIn ( smallIntegerDataCon, isIntegerTy )\r
-import LiberateCase ( liberateCase )\r
-import SAT ( doStaticArgs )\r
-import Specialise ( specProgram)\r
-import UsageSPInf ( doUsageSPInf )\r
-import StrictAnal ( saBinds )\r
-import WorkWrap ( wwTopBinds )\r
-import CprAnalyse ( cprAnalyse )\r
-\r
-import Unique ( Unique, Uniquable(..),\r
- ratioTyConKey\r
- )\r
-import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )\r
-import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )\r
-import Util ( mapAccumL )\r
-import SrcLoc ( noSrcLoc )\r
-import Bag\r
-import Maybes\r
-import IO ( hPutStr, stderr )\r
-import Outputable\r
-\r
-import Ratio ( numerator, denominator )\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{The driver for the simplifier}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-core2core :: [CoreToDo] -- Spec of what core-to-core passes to do\r
- -> [CoreBind] -- Binds in\r
- -> [ProtoCoreRule] -- Rules\r
- -> IO ([CoreBind], [ProtoCoreRule])\r
-\r
-core2core core_todos binds rules\r
- = do\r
- us <- mkSplitUniqSupply 's'\r
- let (cp_us, us1) = splitUniqSupply us\r
- (ru_us, ps_us) = splitUniqSupply us1\r
-\r
- better_rules <- simplRules ru_us rules binds\r
-\r
- let (binds1, rule_base) = prepareRuleBase binds better_rules\r
-\r
- -- Do the main business\r
- (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 \r
- rule_base core_todos\r
-\r
- dumpIfSet opt_D_dump_simpl_stats\r
- "Grand total simplifier statistics"\r
- (pprSimplCount stats)\r
-\r
- -- Do the post-simplification business\r
- post_simpl_binds <- doPostSimplification ps_us processed_binds\r
-\r
- -- Return results\r
- return (post_simpl_binds, filter orphanRule better_rules)\r
- \r
-\r
-doCorePasses stats us binds irs []\r
- = return (stats, binds)\r
-\r
-doCorePasses stats us binds irs (to_do : to_dos) \r
- = do\r
- let (us1, us2) = splitUniqSupply us\r
- (stats1, binds1) <- doCorePass us1 binds irs to_do\r
- doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos\r
-\r
-doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds\r
-doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)\r
-doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)\r
-doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)\r
-doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)\r
-doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)\r
-doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)\r
-doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)\r
-doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)\r
-doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)\r
-doCorePass us binds rb CoreDoUSPInf\r
- = _scc_ "CoreUsageSPInf" \r
- if opt_UsageSPOn then\r
- noStats (doUsageSPInf us binds)\r
- else\r
- trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $\r
- noStats (return binds)\r
-\r
-printCore binds = do dumpIfSet True "Print Core"\r
- (pprCoreBindings binds)\r
- return binds\r
-\r
-noStats thing = do { result <- thing; return (zeroSimplCount, result) }\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Dealing with rules}\r
-%* *\r
-%************************************************************************\r
-\r
-We must do some gentle simplifiation on the template (but not the RHS)\r
-of each rule. The case that forced me to add this was the fold/build rule,\r
-which without simplification looked like:\r
- fold k z (build (/\a. g a)) ==> ...\r
-This doesn't match unless you do eta reduction on the build argument.\r
-\r
-\begin{code}\r
-simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]\r
-simplRules us rules binds\r
- = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)\r
- \r
- dumpIfSet opt_D_dump_rules\r
- "Transformation rules"\r
- (vcat (map pprProtoCoreRule better_rules))\r
-\r
- return better_rules\r
- where\r
- black_list_all v = True -- This stops all inlining\r
- sw_chkr any = SwBool False -- A bit bogus\r
-\r
- -- Boringly, we need to gather the in-scope set.\r
- -- Typically this thunk won't even be force, but the test in\r
- -- simpVar fails if it isn't right, and it might conceivably matter\r
- bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds\r
-\r
-\r
-simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))\r
- | not is_local\r
- = returnSmpl rule -- No need to fiddle with imported rules\r
- | otherwise\r
- = simplBinders bndrs $ \ bndrs' -> \r
- mapSmpl simplExpr args `thenSmpl` \ args' ->\r
- simplExpr rhs `thenSmpl` \ rhs' ->\r
- returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{The driver for the simplifier}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-simplifyPgm :: RuleBase\r
- -> (SimplifierSwitch -> SwitchResult)\r
- -> UniqSupply\r
- -> [CoreBind] -- Input\r
- -> IO (SimplCount, [CoreBind]) -- New bindings\r
-\r
-simplifyPgm (imported_rule_ids, rule_lhs_fvs) \r
- sw_chkr us binds\r
- = do {\r
- beginPass "Simplify";\r
-\r
- -- Glom all binds together in one Rec, in case any\r
- -- transformations have introduced any new dependencies\r
- let { recd_binds = [Rec (flattenBinds binds)] };\r
-\r
- (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;\r
-\r
- dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)\r
- "Simplifier statistics"\r
- (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",\r
- text "",\r
- pprSimplCount counts_out]);\r
-\r
- endPass "Simplify" \r
- (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)\r
- binds' ;\r
-\r
- return (counts_out, binds')\r
- }\r
- where\r
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations\r
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)\r
-\r
- core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds\r
- | otherwise = empty\r
-\r
- iteration us iteration_no counts binds\r
- = do {\r
- -- Occurrence analysis\r
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;\r
-\r
- dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"\r
- (pprCoreBindings tagged_binds);\r
-\r
- -- Simplify\r
- let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids \r
- black_list_fn \r
- (simplTopBinds tagged_binds);\r
- all_counts = counts `plusSimplCount` counts'\r
- } ;\r
-\r
- -- Stop if nothing happened; don't dump output\r
- if isZeroSimplCount counts' then\r
- return ("Simplifier reached fixed point", iteration_no, all_counts, binds')\r
- else do {\r
-\r
- -- Dump the result of this iteration\r
- dumpIfSet opt_D_dump_simpl_iterations\r
- ("Simplifier iteration " ++ show iteration_no \r
- ++ " out of " ++ show max_iterations)\r
- (pprSimplCount counts') ;\r
-\r
- if opt_D_dump_simpl_iterations then\r
- endPass ("Simplifier iteration " ++ show iteration_no ++ " result")\r
- opt_D_verbose_core2core\r
- binds'\r
- else\r
- return [] ;\r
-\r
- -- Stop if we've run out of iterations\r
- if iteration_no == max_iterations then\r
- do {\r
- if max_iterations > 2 then\r
- hPutStr stderr ("NOTE: Simplifier still going after " ++ \r
- show max_iterations ++ \r
- " iterations; bailing out.\n")\r
- else return ();\r
-\r
- return ("Simplifier baled out", iteration_no, all_counts, binds')\r
- }\r
-\r
- -- Else loop\r
- else iteration us2 (iteration_no + 1) all_counts binds'\r
- } }\r
- where\r
- (us1, us2) = splitUniqSupply us\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{PostSimplification}\r
-%* *\r
-%************************************************************************\r
-\r
-Several tasks are performed by the post-simplification pass\r
-\r
-1. Make the representation of NoRep literals explicit, and\r
- float their bindings to the top level. We only do the floating\r
- part for NoRep lits inside a lambda (else no gain). We need to\r
- take care with let x = "foo" in e\r
- that we don't end up with a silly binding\r
- let x = y in e\r
- with a floated "foo". What a bore.\r
- \r
-4. Do eta reduction for lambda abstractions appearing in:\r
- - the RHS of case alternatives\r
- - the body of a let\r
-\r
- These will otherwise turn into local bindings during Core->STG;\r
- better to nuke them if possible. (In general the simplifier does\r
- eta expansion not eta reduction, up to this point. It does eta\r
- on the RHSs of bindings but not the RHSs of case alternatives and\r
- let bodies)\r
-\r
-\r
-------------------- NOT DONE ANY MORE ------------------------\r
-[March 98] Indirections are now elimianted by the occurrence analyser\r
-1. Eliminate indirections. The point here is to transform\r
- x_local = E\r
- x_exported = x_local\r
- ==>\r
- x_exported = E\r
-\r
-[Dec 98] [Not now done because there is no penalty in the code\r
- generator for using the former form]\r
-2. Convert\r
- case x of {...; x' -> ...x'...}\r
- ==>\r
- case x of {...; _ -> ...x... }\r
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.\r
---------------------------------------------------------------\r
-\r
-Special case\r
-~~~~~~~~~~~~\r
-\r
-NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish\r
-things, and we need local Ids for non-floated stuff):\r
-\r
- Don't float stuff out of a binder that's marked as a bottoming Id.\r
- Reason: it doesn't do any good, and creates more CAFs that increase\r
- the size of SRTs.\r
-\r
-eg.\r
-\r
- f = error "string"\r
-\r
-is translated to\r
-\r
- f' = unpackCString# "string"\r
- f = error f'\r
-\r
-hence f' and f become CAFs. Instead, the special case for\r
-tidyTopBinding below makes sure this comes out as\r
-\r
- f = let f' = unpackCString# "string" in error f'\r
-\r
-and we can safely ignore f as a CAF, since it can only ever be entered once.\r
-\r
-\r
-\r
-\begin{code}\r
-doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]\r
-doPostSimplification us binds_in\r
- = do\r
- beginPass "Post-simplification pass"\r
- let binds_out = initPM us (postSimplTopBinds binds_in)\r
- endPass "Post-simplification pass" opt_D_verbose_core2core binds_out\r
-\r
-postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]\r
-postSimplTopBinds binds\r
- = mapPM postSimplTopBind binds `thenPM` \ binds' ->\r
- returnPM (bagToList (unionManyBags binds'))\r
-\r
-postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)\r
-postSimplTopBind (NonRec bndr rhs)\r
- | isBottomingId bndr -- Don't lift out floats for bottoming Ids\r
- -- See notes above\r
- = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->\r
- returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))\r
-\r
-postSimplTopBind bind\r
- = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->\r
- returnPM (floats `snocBag` bind')\r
-\r
-postSimplBind (NonRec bndr rhs)\r
- = postSimplExpr rhs `thenPM` \ rhs' ->\r
- returnPM (NonRec bndr rhs')\r
-\r
-postSimplBind (Rec pairs)\r
- = mapPM postSimplExpr rhss `thenPM` \ rhss' ->\r
- returnPM (Rec (bndrs `zip` rhss'))\r
- where\r
- (bndrs, rhss) = unzip pairs\r
-\end{code}\r
-\r
-\r
-Expressions\r
-~~~~~~~~~~~\r
-\begin{code}\r
-postSimplExpr (Var v) = returnPM (Var v)\r
-postSimplExpr (Type ty) = returnPM (Type ty)\r
-\r
-postSimplExpr (App fun arg)\r
- = postSimplExpr fun `thenPM` \ fun' ->\r
- postSimplExpr arg `thenPM` \ arg' ->\r
- returnPM (App fun' arg')\r
-\r
-postSimplExpr (Con (Literal lit) args)\r
- = ASSERT( null args )\r
- litToRep lit `thenPM` \ (lit_ty, lit_expr) ->\r
- getInsideLambda `thenPM` \ in_lam ->\r
- if in_lam && not (exprIsTrivial lit_expr) then\r
- -- It must have been a no-rep literal with a\r
- -- non-trivial representation; and we're inside a lambda;\r
- -- so float it to the top\r
- addTopFloat lit_ty lit_expr `thenPM` \ v ->\r
- returnPM (Var v)\r
- else\r
- returnPM lit_expr\r
-\r
-postSimplExpr (Con con args)\r
- = mapPM postSimplExpr args `thenPM` \ args' ->\r
- returnPM (Con con args')\r
-\r
-postSimplExpr (Lam bndr body)\r
- = insideLambda bndr $\r
- postSimplExpr body `thenPM` \ body' ->\r
- returnPM (Lam bndr body')\r
-\r
-postSimplExpr (Let bind body)\r
- = postSimplBind bind `thenPM` \ bind' ->\r
- postSimplExprEta body `thenPM` \ body' ->\r
- returnPM (Let bind' body')\r
-\r
-postSimplExpr (Note note body)\r
- = postSimplExprEta body `thenPM` \ body' ->\r
- returnPM (Note note body')\r
-\r
-postSimplExpr (Case scrut case_bndr alts)\r
- = postSimplExpr scrut `thenPM` \ scrut' ->\r
- mapPM ps_alt alts `thenPM` \ alts' ->\r
- returnPM (Case scrut' case_bndr alts')\r
- where\r
- ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->\r
- returnPM (con, bndrs, rhs')\r
-\r
-postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->\r
- returnPM (etaCoreExpr e')\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection[coreToStg-lits]{Converting literals}\r
-%* *\r
-%************************************************************************\r
-\r
-Literals: the NoRep kind need to be de-no-rep'd.\r
-We always replace them with a simple variable, and float a suitable\r
-binding out to the top level.\r
-\r
-\begin{code}\r
-litToRep :: Literal -> PostM (Type, CoreExpr)\r
-\r
-litToRep (NoRepStr s ty)\r
- = returnPM (ty, rhs)\r
- where\r
- rhs = if (any is_NUL (_UNPK_ s))\r
-\r
- then -- Must cater for NULs in literal string\r
- mkApps (Var unpackCString2Id)\r
- [mkLit (MachStr s),\r
- mkLit (mkMachInt (toInteger (_LENGTH_ s)))]\r
-\r
- else -- No NULs in the string\r
- App (Var unpackCStringId) (mkLit (MachStr s))\r
-\r
- is_NUL c = c == '\0'\r
-\end{code}\r
-\r
-If an Integer is small enough (Haskell implementations must support\r
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;\r
-otherwise, wrap with @addr2Integer@.\r
-\r
-\begin{code}\r
-litToRep (NoRepInteger i integer_ty)\r
- = returnPM (integer_ty, rhs)\r
- where\r
- rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int\r
- i < tARGET_MAX_INT\r
- = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]\r
- \r
- | otherwise -- Big, so start from a string\r
- = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])\r
-\r
-\r
-litToRep (NoRepRational r rational_ty)\r
- = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->\r
- postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->\r
- returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])\r
- where\r
- (ratio_data_con, integer_ty)\r
- = case (splitAlgTyConApp_maybe rational_ty) of\r
- Just (tycon, [i_ty], [con])\r
- -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)\r
- (con, i_ty)\r
-\r
- _ -> (panic "ratio_data_con", panic "integer_ty")\r
-\r
-litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{The monad}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-type PostM a = Bool -- True <=> inside a *value* lambda\r
- -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in \r
- -> (a, (UniqSupply, Bag CoreBind))\r
-\r
-initPM :: UniqSupply -> PostM a -> a\r
-initPM us m\r
- = case m False {- not inside lambda -} (us, emptyBag) of \r
- (result, _) -> result\r
-\r
-returnPM v in_lam usf = (v, usf)\r
-thenPM m k in_lam usf = case m in_lam usf of\r
- (r, usf') -> k r in_lam usf'\r
-\r
-mapPM f [] = returnPM []\r
-mapPM f (x:xs) = f x `thenPM` \ r ->\r
- mapPM f xs `thenPM` \ rs ->\r
- returnPM (r:rs)\r
-\r
-insideLambda :: CoreBndr -> PostM a -> PostM a\r
-insideLambda bndr m in_lam usf | isId bndr = m True usf\r
- | otherwise = m in_lam usf\r
-\r
-getInsideLambda :: PostM Bool\r
-getInsideLambda in_lam usf = (in_lam, usf)\r
-\r
-getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)\r
-getFloatsPM m in_lam (us, floats)\r
- = let\r
- (a, (us', floats')) = m in_lam (us, emptyBag)\r
- in\r
- ((a, floats'), (us', floats))\r
-\r
-addTopFloat :: Type -> CoreExpr -> PostM Id\r
-addTopFloat lit_ty lit_rhs in_lam (us, floats)\r
- = let\r
- (us1, us2) = splitUniqSupply us\r
- uniq = uniqFromSupply us1\r
- lit_id = mkSysLocal SLIT("lf") uniq lit_ty\r
- in\r
- (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))\r
-\end{code}\r
-\r
-\r
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[SimplCore]{Driver for simplifying @Core@ programs}
+
+\begin{code}
+module SimplCore ( core2core ) where
+
+#include "HsVersions.h"
+
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
+ SwitchResult(..), switchIsOn, intSwitchSet,
+ opt_D_dump_occur_anal, opt_D_dump_rules,
+ opt_D_dump_simpl_iterations,
+ opt_D_dump_simpl_stats,
+ opt_D_dump_simpl, opt_D_dump_rules,
+ opt_D_verbose_core2core,
+ opt_D_dump_occur_anal,
+ opt_UsageSPOn,
+ )
+import CoreLint ( beginPass, endPass )
+import CoreTidy ( tidyCorePgm )
+import CoreSyn
+import CSE ( cseProgram )
+import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
+import CoreUnfold
+import PprCore ( pprCoreBindings )
+import OccurAnal ( occurAnalyseBinds )
+import CoreUtils ( exprIsTrivial, coreExprType )
+import Simplify ( simplTopBinds, simplExpr )
+import SimplUtils ( etaCoreExpr, findDefault, simplBinders )
+import SimplMonad
+import Const ( Con(..), Literal(..), literalType, mkMachInt )
+import ErrUtils ( dumpIfSet )
+import FloatIn ( floatInwards )
+import FloatOut ( floatOutwards )
+import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
+ idType, setIdType, idName, idInfo, setIdNoDiscard
+ )
+import VarEnv
+import VarSet
+import Module ( Module )
+import Name ( mkLocalName, tidyOccName, tidyTopName,
+ NamedThing(..), OccName
+ )
+import TyCon ( TyCon, isDataTyCon )
+import PrimOp ( PrimOp(..) )
+import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
+import Type ( Type, splitAlgTyConApp_maybe,
+ isUnLiftedType,
+ tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
+ Type
+ )
+import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
+import LiberateCase ( liberateCase )
+import SAT ( doStaticArgs )
+import Specialise ( specProgram)
+import UsageSPInf ( doUsageSPInf )
+import StrictAnal ( saBinds )
+import WorkWrap ( wwTopBinds )
+import CprAnalyse ( cprAnalyse )
+
+import Unique ( Unique, Uniquable(..),
+ ratioTyConKey
+ )
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
+import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
+import Util ( mapAccumL )
+import SrcLoc ( noSrcLoc )
+import Bag
+import Maybes
+import IO ( hPutStr, stderr )
+import Outputable
+
+import Ratio ( numerator, denominator )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
+
+\begin{code}
+core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
+ -> [CoreBind] -- Binds in
+ -> [ProtoCoreRule] -- Rules
+ -> IO ([CoreBind], [ProtoCoreRule])
+
+core2core core_todos binds rules
+ = do
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, us1) = splitUniqSupply us
+ (ru_us, ps_us) = splitUniqSupply us1
+
+ better_rules <- simplRules ru_us rules binds
+
+ let (binds1, rule_base) = prepareRuleBase binds better_rules
+
+ -- Do the main business
+ (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
+ rule_base core_todos
+
+ dumpIfSet opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
+
+ -- Do the post-simplification business
+ post_simpl_binds <- doPostSimplification ps_us processed_binds
+
+ -- Return results
+ return (post_simpl_binds, filter orphanRule better_rules)
+
+
+doCorePasses stats us binds irs []
+ = return (stats, binds)
+
+doCorePasses stats us binds irs (to_do : to_dos)
+ = do
+ let (us1, us2) = splitUniqSupply us
+ (stats1, binds1) <- doCorePass us1 binds irs to_do
+ doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
+
+doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
+doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
+doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
+doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
+doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
+doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
+doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
+doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
+doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
+doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
+doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
+doCorePass us binds rb CoreDoUSPInf
+ = _scc_ "CoreUsageSPInf"
+ if opt_UsageSPOn then
+ noStats (doUsageSPInf us binds)
+ else
+ trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
+ noStats (return binds)
+
+printCore binds = do dumpIfSet True "Print Core"
+ (pprCoreBindings binds)
+ return binds
+
+noStats thing = do { result <- thing; return (zeroSimplCount, result) }
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Dealing with rules}
+%* *
+%************************************************************************
+
+We must do some gentle simplifiation on the template (but not the RHS)
+of each rule. The case that forced me to add this was the fold/build rule,
+which without simplification looked like:
+ fold k z (build (/\a. g a)) ==> ...
+This doesn't match unless you do eta reduction on the build argument.
+
+\begin{code}
+simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
+simplRules us rules binds
+ = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
+
+ dumpIfSet opt_D_dump_rules
+ "Transformation rules"
+ (vcat (map pprProtoCoreRule better_rules))
+
+ return better_rules
+ where
+ black_list_all v = True -- This stops all inlining
+ sw_chkr any = SwBool False -- A bit bogus
+
+ -- Boringly, we need to gather the in-scope set.
+ -- Typically this thunk won't even be force, but the test in
+ -- simpVar fails if it isn't right, and it might conceivably matter
+ bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+
+simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
+ | not is_local
+ = returnSmpl rule -- No need to fiddle with imported rules
+ | otherwise
+ = simplBinders bndrs $ \ bndrs' ->
+ mapSmpl simplExpr args `thenSmpl` \ args' ->
+ simplExpr rhs `thenSmpl` \ rhs' ->
+ returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The driver for the simplifier}
+%* *
+%************************************************************************
+
+\begin{code}
+simplifyPgm :: RuleBase
+ -> (SimplifierSwitch -> SwitchResult)
+ -> UniqSupply
+ -> [CoreBind] -- Input
+ -> IO (SimplCount, [CoreBind]) -- New bindings
+
+simplifyPgm (imported_rule_ids, rule_lhs_fvs)
+ sw_chkr us binds
+ = do {
+ beginPass "Simplify";
+
+ -- Glom all binds together in one Rec, in case any
+ -- transformations have introduced any new dependencies
+ let { recd_binds = [Rec (flattenBinds binds)] };
+
+ (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
+
+ dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
+ "Simplifier statistics"
+ (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
+ text "",
+ pprSimplCount counts_out]);
+
+ endPass "Simplify"
+ (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
+ binds' ;
+
+ return (counts_out, binds')
+ }
+ where
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+ black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+
+ core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
+ | otherwise = empty
+
+ iteration us iteration_no counts binds
+ = do {
+ -- Occurrence analysis
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
+
+ dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
+ (pprCoreBindings tagged_binds);
+
+ -- Simplify
+ let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
+ black_list_fn
+ (simplTopBinds tagged_binds);
+ all_counts = counts `plusSimplCount` counts'
+ } ;
+
+ -- Stop if nothing happened; don't dump output
+ if isZeroSimplCount counts' then
+ return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+ else do {
+
+ -- Dump the result of this iteration
+ dumpIfSet opt_D_dump_simpl_iterations
+ ("Simplifier iteration " ++ show iteration_no
+ ++ " out of " ++ show max_iterations)
+ (pprSimplCount counts') ;
+
+ if opt_D_dump_simpl_iterations then
+ endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
+ opt_D_verbose_core2core
+ binds'
+ else
+ return [] ;
+
+ -- Stop if we've run out of iterations
+ if iteration_no == max_iterations then
+ do {
+ if max_iterations > 2 then
+ hPutStr stderr ("NOTE: Simplifier still going after " ++
+ show max_iterations ++
+ " iterations; bailing out.\n")
+ else return ();
+
+ return ("Simplifier baled out", iteration_no, all_counts, binds')
+ }
+
+ -- Else loop
+ else iteration us2 (iteration_no + 1) all_counts binds'
+ } }
+ where
+ (us1, us2) = splitUniqSupply us
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{PostSimplification}
+%* *
+%************************************************************************
+
+Several tasks are performed by the post-simplification pass
+
+1. Make the representation of NoRep literals explicit, and
+ float their bindings to the top level. We only do the floating
+ part for NoRep lits inside a lambda (else no gain). We need to
+ take care with let x = "foo" in e
+ that we don't end up with a silly binding
+ let x = y in e
+ with a floated "foo". What a bore.
+
+4. Do eta reduction for lambda abstractions appearing in:
+ - the RHS of case alternatives
+ - the body of a let
+
+ These will otherwise turn into local bindings during Core->STG;
+ better to nuke them if possible. (In general the simplifier does
+ eta expansion not eta reduction, up to this point. It does eta
+ on the RHSs of bindings but not the RHSs of case alternatives and
+ let bodies)
+
+
+------------------- NOT DONE ANY MORE ------------------------
+[March 98] Indirections are now elimianted by the occurrence analyser
+1. Eliminate indirections. The point here is to transform
+ x_local = E
+ x_exported = x_local
+ ==>
+ x_exported = E
+
+[Dec 98] [Not now done because there is no penalty in the code
+ generator for using the former form]
+2. Convert
+ case x of {...; x' -> ...x'...}
+ ==>
+ case x of {...; _ -> ...x... }
+ See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+--------------------------------------------------------------
+
+Special case
+~~~~~~~~~~~~
+
+NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
+things, and we need local Ids for non-floated stuff):
+
+ Don't float stuff out of a binder that's marked as a bottoming Id.
+ Reason: it doesn't do any good, and creates more CAFs that increase
+ the size of SRTs.
+
+eg.
+
+ f = error "string"
+
+is translated to
+
+ f' = unpackCString# "string"
+ f = error f'
+
+hence f' and f become CAFs. Instead, the special case for
+tidyTopBinding below makes sure this comes out as
+
+ f = let f' = unpackCString# "string" in error f'
+
+and we can safely ignore f as a CAF, since it can only ever be entered once.
+
+
+
+\begin{code}
+doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
+doPostSimplification us binds_in
+ = do
+ beginPass "Post-simplification pass"
+ let binds_out = initPM us (postSimplTopBinds binds_in)
+ endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
+
+postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
+postSimplTopBinds binds
+ = mapPM postSimplTopBind binds `thenPM` \ binds' ->
+ returnPM (bagToList (unionManyBags binds'))
+
+postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
+postSimplTopBind (NonRec bndr rhs)
+ | isBottomingId bndr -- Don't lift out floats for bottoming Ids
+ -- See notes above
+ = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
+ returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
+
+postSimplTopBind bind
+ = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
+ returnPM (floats `snocBag` bind')
+
+postSimplBind (NonRec bndr rhs)
+ = postSimplExpr rhs `thenPM` \ rhs' ->
+ returnPM (NonRec bndr rhs')
+
+postSimplBind (Rec pairs)
+ = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
+ returnPM (Rec (bndrs `zip` rhss'))
+ where
+ (bndrs, rhss) = unzip pairs
+\end{code}
+
+
+Expressions
+~~~~~~~~~~~
+\begin{code}
+postSimplExpr (Var v) = returnPM (Var v)
+postSimplExpr (Type ty) = returnPM (Type ty)
+
+postSimplExpr (App fun arg)
+ = postSimplExpr fun `thenPM` \ fun' ->
+ postSimplExpr arg `thenPM` \ arg' ->
+ returnPM (App fun' arg')
+
+postSimplExpr (Con (Literal lit) args)
+ = ASSERT( null args )
+ litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
+ getInsideLambda `thenPM` \ in_lam ->
+ if in_lam && not (exprIsTrivial lit_expr) then
+ -- It must have been a no-rep literal with a
+ -- non-trivial representation; and we're inside a lambda;
+ -- so float it to the top
+ addTopFloat lit_ty lit_expr `thenPM` \ v ->
+ returnPM (Var v)
+ else
+ returnPM lit_expr
+
+postSimplExpr (Con con args)
+ = mapPM postSimplExpr args `thenPM` \ args' ->
+ returnPM (Con con args')
+
+postSimplExpr (Lam bndr body)
+ = insideLambda bndr $
+ postSimplExpr body `thenPM` \ body' ->
+ returnPM (Lam bndr body')
+
+postSimplExpr (Let bind body)
+ = postSimplBind bind `thenPM` \ bind' ->
+ postSimplExprEta body `thenPM` \ body' ->
+ returnPM (Let bind' body')
+
+postSimplExpr (Note note body)
+ = postSimplExprEta body `thenPM` \ body' ->
+ returnPM (Note note body')
+
+postSimplExpr (Case scrut case_bndr alts)
+ = postSimplExpr scrut `thenPM` \ scrut' ->
+ mapPM ps_alt alts `thenPM` \ alts' ->
+ returnPM (Case scrut' case_bndr alts')
+ where
+ ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
+ returnPM (con, bndrs, rhs')
+
+postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
+ returnPM (etaCoreExpr e')
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[coreToStg-lits]{Converting literals}
+%* *
+%************************************************************************
+
+Literals: the NoRep kind need to be de-no-rep'd.
+We always replace them with a simple variable, and float a suitable
+binding out to the top level.
+
+\begin{code}
+litToRep :: Literal -> PostM (Type, CoreExpr)
+
+litToRep (NoRepStr s ty)
+ = returnPM (ty, rhs)
+ where
+ rhs = if (any is_NUL (_UNPK_ s))
+
+ then -- Must cater for NULs in literal string
+ mkApps (Var unpackCString2Id)
+ [mkLit (MachStr s),
+ mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
+
+ else -- No NULs in the string
+ App (Var unpackCStringId) (mkLit (MachStr s))
+
+ is_NUL c = c == '\0'
+\end{code}
+
+If an Integer is small enough (Haskell implementations must support
+Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
+otherwise, wrap with @addr2Integer@.
+
+\begin{code}
+litToRep (NoRepInteger i integer_ty)
+ = returnPM (integer_ty, rhs)
+ where
+ rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int
+ i < tARGET_MAX_INT
+ = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
+
+ | otherwise -- Big, so start from a string
+ = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
+
+
+litToRep (NoRepRational r rational_ty)
+ = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
+ postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
+ returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
+ where
+ (ratio_data_con, integer_ty)
+ = case (splitAlgTyConApp_maybe rational_ty) of
+ Just (tycon, [i_ty], [con])
+ -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
+ (con, i_ty)
+
+ _ -> (panic "ratio_data_con", panic "integer_ty")
+
+litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The monad}
+%* *
+%************************************************************************
+
+\begin{code}
+type PostM a = Bool -- True <=> inside a *value* lambda
+ -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
+ -> (a, (UniqSupply, Bag CoreBind))
+
+initPM :: UniqSupply -> PostM a -> a
+initPM us m
+ = case m False {- not inside lambda -} (us, emptyBag) of
+ (result, _) -> result
+
+returnPM v in_lam usf = (v, usf)
+thenPM m k in_lam usf = case m in_lam usf of
+ (r, usf') -> k r in_lam usf'
+
+mapPM f [] = returnPM []
+mapPM f (x:xs) = f x `thenPM` \ r ->
+ mapPM f xs `thenPM` \ rs ->
+ returnPM (r:rs)
+
+insideLambda :: CoreBndr -> PostM a -> PostM a
+insideLambda bndr m in_lam usf | isId bndr = m True usf
+ | otherwise = m in_lam usf
+
+getInsideLambda :: PostM Bool
+getInsideLambda in_lam usf = (in_lam, usf)
+
+getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
+getFloatsPM m in_lam (us, floats)
+ = let
+ (a, (us', floats')) = m in_lam (us, emptyBag)
+ in
+ ((a, floats'), (us', floats))
+
+addTopFloat :: Type -> CoreExpr -> PostM Id
+addTopFloat lit_ty lit_rhs in_lam (us, floats)
+ = let
+ (us1, us2) = splitUniqSupply us
+ uniq = uniqFromSupply us1
+ lit_id = mkSysLocal SLIT("lf") uniq lit_ty
+ in
+ (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
+\end{code}
+
+
contIsInteresting (CoerceIt _ cont) = contIsInteresting cont
contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
contIsInteresting (ApplyTo _ _ _ _) = True
-contIsInteresting (ArgOf _ _ _) = True
+
+contIsInteresting (ArgOf _ _ _) = False
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
-- evaluation information to avoid repeated evals: e.g.
-- Here the contIsInteresting makes the '*' keener to inline,
-- which in turn exposes a constructor which makes the '+' inline.
-- Assuming that +,* aren't small enough to inline regardless.
+ --
+ -- HOWEVER, I put this back to False when I discovered that strings
+ -- were getting inlined straight back into applications of 'error'
+ -- because the latter is strict.
+ -- s = "foo"
+ -- f = \x -> ...(error s)...
+
contIsInteresting (InlinePlease _) = True
contIsInteresting other = False
import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType,
- exprIsWHNF, FormSummary(..)
- )
+import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap )
import Subst ( substBndrs, substBndr, substIds )
import Id ( Id, idType, getIdArity, isId, idName,
getInlinePragma, setInlinePragma,
worth_it (Let _ e) = whnf_in_middle e
worth_it other = False
whnf_in_middle (Let _ e) = whnf_in_middle e
- whnf_in_middle e = exprIsWHNF e
+ whnf_in_middle e = exprIsCheap e
main_tyvar_set = mkVarSet tyvars
import Name ( isLocallyDefined )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUnfold ( Unfolding(..), mkUnfolding, callSiteInline,
- isEvaldUnfolding, blackListed )
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
+import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons,
+ callSiteInline, blackListed
+ )
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
coreExprType, coreAltsType, exprArity, exprIsValue,
exprOkForSpeculation
)
(floats_out, rhs'') | float_ubx = (floats, rhs')
| otherwise = splitFloats floats rhs'
in
- if (isTopLevel top_lvl || exprIsWHNF rhs') && -- Float lets if (a) we're at the top level
- not (null floats_out) -- or (b) it exposes a HNF
+ if (isTopLevel top_lvl || exprIsCheap rhs') && -- Float lets if (a) we're at the top level
+ not (null floats_out) -- or (b) it exposes a cheap (i.e. duplicatable) expression
then
tickLetFloat floats_out `thenSmpl_`
-- Do the float
-- Check that the scrutinee can be let-bound instead of case-bound
&& ( (isUnLiftedType (idType bndr) && -- It's unlifted and floatable
exprOkForSpeculation scrut) -- NB: scrut = an unboxed variable satisfies
- || is_a_value scrut -- It's a value
+ || exprIsValue scrut -- It's already evaluated
+ || var_demanded_later scrut -- It'll be demanded later
-- || not opt_SimplPedanticBottoms) -- Or we don't care!
-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
(rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
binders_unused (_, bndrs, _) = all isDeadBinder bndrs
- -- Check whether or not scrut is known to be evaluted
- is_a_value (Var v) = isEvaldUnfolding (getIdUnfolding v) -- It's been evaluated
- || isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later
- is_a_value scrut = exprIsValue scrut
+ var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later
+ var_demanded_later other = False
\end{code}
Case elimination [see the code above]
where
-- scrut_cons tells what constructors the scrutinee can't possibly match
scrut_cons = case scrut of
- Var v -> case getIdUnfolding v of
- OtherCon cons -> cons
- other -> []
+ Var v -> otherCons (getIdUnfolding v)
other -> []
= -- In the default case we record the constructors that the
-- case-binder *can't* be.
-- We take advantage of any OtherCon info in the case scrutinee
- modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
+ modifyInScope (case_bndr'' `setIdUnfolding` mkOtherCon handled_cons) $
simplExprC rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
cat_evals [] [] = []
cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | isStrict str = (v' `setIdUnfolding` OtherCon []) : cat_evals vs strs
- | otherwise = v' : cat_evals vs strs
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
+ | otherwise = v' : cat_evals vs strs
where
v' = zap_occ_info v
\end{code}
import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails )
import BinderInfo ( markMany )
import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
-import CoreUnfold ( Unfolding(..) )
-import CoreUtils ( whnfOrBottom, eqExpr )
+import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
+import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
-- (Its occurrence information is not necessarily up to date,
-- so we don't use it.)
match e1 (Var v2) tpl_vars kont subst
- = case getIdUnfolding v2 of
- CoreUnfolding form guidance unfolding
- | whnfOrBottom form
- -> match e1 unfolding tpl_vars kont subst
+ | isCheapUnfolding unfolding
+ = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
+ where
+ unfolding = getIdUnfolding v2
- other -> match_fail
-- We can't cope with lets in the template
mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
- final_uds = foldr addDictBind rhs_uds (zipEqual "spec_call" rhs_dicts' call_ds)
+ final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
in
returnSM ((spec_f, spec_rhs),
final_uds,
spec_env_rule)
+
+ where
+ my_zipEqual doc xs ys
+ | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+ | otherwise = zipEqual doc xs ys
\end{code}
%************************************************************************
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
-import CoreUnfold ( Unfolding(..) )
+import CoreUnfold ( Unfolding, maybeUnfoldingTemplate )
import PrimOp ( primOpStrictness )
import Id ( Id, idType, getIdStrictness, getIdUnfolding )
import Const ( Con(..) )
-- error's arg
absId anal var env
- = case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
+ = case (lookupAbsValEnv env var, getIdStrictness var, maybeUnfoldingTemplate (getIdUnfolding var)) of
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, CoreUnfolding _ _ unfolding) ->
+ (Nothing, NoStrictnessInfo, Just unfolding) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
-> Id -- Augmented with strictness
addStrictnessInfoToId str_val abs_val binder body
- = case collectBinders body of
- -- We could use 'collectBindersIgnoringNotes', but then the
- -- strictness info may have more items than the visible binders
- -- used by WorkWrap.tryWW
+ = case collectBindersIgnoringNotes body of
+ -- It's imporant to use collectBindersIgnoringNotes, so that INLINE prags
+ -- don't inhibit strictness info. In particular, foldr is marked INLINE,
+ -- but we still want it to be strict in its third arg, so that
+ -- foldr k z (case e of p -> build g)
+ -- gets transformed to
+ -- case e of p -> foldr k z (build g)
(binders, rhs) -> binder `setIdStrictness`
mkStrictnessInfo strictness
where
= returnUs [ (fn_id, rhs) ]
| otherwise -- Do w/w split
- = let
- (tyvars, wrap_args, body) = collectTyAndValBinders rhs
- in
- mkWwBodies tyvars wrap_args
+ = mkWwBodies tyvars wrap_args
(coreExprType body)
- revised_wrap_args_info
+ wrap_demands
cpr_info
`thenUs` \ (wrap_fn, work_fn, work_demands) ->
getUniqueUs `thenUs` \ work_uniq ->
let
work_rhs = work_fn body
work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
- (if has_strictness_info then mkStrictnessInfo (work_demands, result_bot)
+ (if has_strictness_info then mkStrictnessInfo (work_demands ++ remaining_arg_demands, result_bot)
else noStrictnessInfo)
wrap_rhs = wrap_fn work_id
wrap_id = fn_id `setIdStrictness`
- (if has_strictness_info then mkStrictnessInfo (revised_wrap_args_info, result_bot)
+ (if has_strictness_info then mkStrictnessInfo (wrap_demands ++ remaining_arg_demands, result_bot)
else noStrictnessInfo)
`setIdWorkerInfo` Just work_id
`setIdArity` exactArity (length wrap_args)
returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
-- Worker first, because wrapper mentions it
where
+ (tyvars, wrap_args, body) = collectTyAndValBinders rhs
+ n_wrap_args = length wrap_args
+
strictness_info = getIdStrictness fn_id
has_strictness_info = case strictness_info of
StrictnessInfo _ _ -> True
other -> False
- StrictnessInfo wrap_args_info result_bot = strictness_info
+ StrictnessInfo arg_demands result_bot = strictness_info
- revised_wrap_args_info = if has_strictness_info
- then setUnpackStrategy wrap_args_info
- else repeat wwLazy
+ -- NB: There maybe be more items in arg_demands than wrap_args, because
+ -- the strictness info is semantic and looks through InlineMe and Scc
+ -- Notes, whereas wrap_args does not
+ demands_for_visible_args = take n_wrap_args arg_demands
+ remaining_arg_demands = drop n_wrap_args arg_demands
+
+ wrap_demands | has_strictness_info = setUnpackStrategy demands_for_visible_args
+ | otherwise = repeat wwLazy
- do_strict_ww = has_strictness_info && worthSplitting revised_wrap_args_info result_bot
+ do_strict_ww = has_strictness_info && worthSplitting wrap_demands result_bot
cpr_info = getIdCprInfo fn_id
has_cpr_info = case cpr_info of
import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, setInlinePragma, getIdUnfolding, idType, idName )
-import CoreUnfold ( getUnfoldingTemplate )
+import CoreUnfold ( unfoldingTemplate )
import IdInfo
import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
import NameSet ( emptyNameSet )
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
-- The selector binds are already in the selector Id's unfoldings
- sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
+ sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id))
| sel_id <- sc_sel_ids ++ op_sel_ids
]
in
gen_Ord_binds :: TyCon -> RdrNameMonoBinds
gen_Ord_binds tycon
- = defaulted `AndMonoBinds` compare
+ = compare -- `AndMonoBinds` compare
+ -- The default declaration in PrelBase handles this
where
tycon_loc = getSrcLoc tycon
--------------------------------------------------------------------
-- Tags are equal, no args => return EQ
--------------------------------------------------------------------
+{- Not necessary: the default decls in PrelBase handle these
+
defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
+-}
\end{code}
%************************************************************************
-- maybe_expr doesn't get looked at if the unfolding
-- is never inspected; so the typecheck doesn't even happen
unfold_info = case maybe_expr' of
- Nothing -> NoUnfolding
+ Nothing -> noUnfolding
Just expr' -> mkUnfolding expr'
info1 = info `setUnfoldingInfo` unfold_info
info2 = info1 `setInlinePragInfo` inline_prag
import Bag ( bagToList, Bag )
import Class ( Class )
-import Var ( TyVar, Id )
+import Var ( TyVar, Id, idName )
import InstEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
-import Name ( getSrcLoc )
+import Name ( getSrcLoc, nameModule, isLocallyDefined )
import SrcLoc ( SrcLoc )
import Type ( ThetaType, Type )
import PprType ( pprConstraint )
= -- Add the instance to the class's instance environment
case addToInstEnv opt_AllowOverlappingInstances
class_inst_env inst_tyvars inst_tys dfun_id of
- Failed (ty', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, src_loc)
- (ty', getSrcLoc dfun_id'))
+ Failed (tys', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, dfun_id)
+ (tys', dfun_id'))
`thenNF_Tc_`
returnNF_Tc class_inst_env
\end{code}
\begin{code}
-dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2)
+dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2)
-- Overlapping/duplicate instances for given class; msg could be more glamourous
= hang (ptext SLIT("Duplicate or overlapping instance declarations"))
4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
- nest 4 (sep [ptext SLIT("at") <+> ppr locn1,
- ptext SLIT("and") <+> ppr locn2])])
+ nest 4 (sep [ppr_loc dfun1, ptext SLIT("and") <+> ppr_loc dfun2])])
+ where
+ ppr_loc dfun
+ | isLocallyDefined dfun = ptext SLIT("defined at") <+> ppr (getSrcLoc dfun)
+ | otherwise = ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun)))
\end{code}
)
import MkId ( mkDataConId, mkRecordSelId, mkNewTySelId )
import Id ( getIdUnfolding )
-import CoreUnfold ( getUnfoldingTemplate )
+import CoreUnfold ( unfoldingTemplate )
import FieldLabel
import Var ( Id, TyVar )
import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
-- For the locally-defined things
-- we need to turn the unfoldings inside the Ids into bindings,
binds | isLocallyDefined tycon
- = [ CoreMonoBind data_id (getUnfoldingTemplate (getIdUnfolding data_id))
+ = [ CoreMonoBind data_id (unfoldingTemplate (getIdUnfolding data_id))
| data_id <- data_ids, isLocallyDefined data_id
]
| otherwise
import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily )
import Panic
import GlaExts -- Lots of Int# operations
+import Outputable
#if ! OMIT_NATIVE_CODEGEN
#define IF_NCG(a) a
(UniqFM ele)
(UniqFM ele)
--- for debugging only :-)
{-
-instance Text (UniqFM a) where
- showsPrec _ (NodeUFM a b t1 t2) =
- showString "NodeUFM " . shows (IBOX(a))
- . showString " " . shows (IBOX(b))
- . showString " (" . shows t1
- . showString ") (" . shows t2
- . showString ")"
- showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x))
- showsPrec _ (EmptyUFM) = id
+-- for debugging only :-)
+instance Outputable (UniqFM a) where
+ ppr(NodeUFM a b t1 t2) =
+ sep [text "NodeUFM " <+> int IBOX(a) <+> int IBOX(b),
+ nest 1 (parens (ppr t1)),
+ nest 1 (parens (ppr t2))]
+ ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
+ ppr (EmptyUFM) = empty
-}
\end{code}
'-fsimplify',
'[',
- '-finline-phase1', # Don't inline rule Ids till specialisation has bitten
-
-# APR 99: the stuff in this comment is now
-# handled by -finline-phase1
-#
-# I don't understand why we want -fessential-unfoldings-only here
-# If we have it, the following nasty thing happens:
-# f = E
-# g* = f
-# ...g...
-# where "*" means exported.
-# In the essential-unfoldings pass we still substitute f for g
-# but we don't substitute E for f first. So we get
-# f = E
-# g* = f
-# ...f...
-# The g=f will get reverse-substituted later, but it's untidy. --SLPJ
-#
-# SDM: Here's why it's necessary.
-#
-# If we unfold in the first pass before the specialiser is run
-# we miss opportunities for specialisation because eg. wrappers
-# have been inlined for specialisable functions.
-#
-# This shows up in PrelArr.lhs - the specialised instance for newArray
-# calls the generic rangeSize, because rangeSize is strict and is
-# replaced by its wrapper by the simplifier.
-# '-fessential-unfoldings-only',
-# '-fsimpl-uf-use-threshold0',
-
- '-fmax-simplifier-iterations2',
+ '-finline-phase0', # Don't inline anything till full laziness has bitten
+ # In particular, inlining wrappers inhibits floating
+ # e.g. ...(case f x of ...)...
+ # ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ # ==> ...(case x of I# x# -> case fw x# of ...)...
+ # and now the redex (f x) isn't floatable any more
+ '-fmax-simplifier-iterations2',
']',
+ # Specialisation is best done before full laziness
+ # so that overloaded functions have all their dictionary lambdas manifest
($Oopt_DoSpecialise) ? ( $Oopt_DoSpecialise, ) : (),
+ '-ffull-laziness',
+ '-ffloat-inwards',
+
+# '-fsimplify',
+# '[',
+# # Run the simplifier before specialising, so that overloaded functions
+# # look like f = \d -> ...
+# # (Full laziness may lift out something hiding the \d
+# '-finline-phase1',
+# '-fmax-simplifier-iterations1',
+# ']',
- $Oopt_UsageSPInf, # infer usage information here in case we need it later.
- # (add more of these where you need them --KSW 1999-04)
'-fsimplify',
'[',
- $Oopt_MaxSimplifierIterations,
-
- # Still don't inline transformation rule Ids, to give the
- # rules a good chance to fire
- '-finline-phase1',
+ '-finline-phase1',
+ # Want to run with inline phase 1 after the specialiser to give
+ # maximum chance for fusion to work before we inline build/augment
+ # in phase 2. This made a difference in 'ansi' where an overloaded
+ # function wasn't inlined till too late.
+ $Oopt_MaxSimplifierIterations,
']',
- '-ffull-laziness',
-
- '-ffloat-inwards',
+ $Oopt_UsageSPInf, # infer usage information here in case we need it later.
+ # (add more of these where you need them --KSW 1999-04)
'-fsimplify',
'[',
- '-finline-phase2',
- $Oopt_MaxSimplifierIterations,
+ # Need inline-phase2 here so that build/augment get
+ # inlined. I found that spectral/hartel/genfft lost some useful
+ # strictness in the function sumcode' if augment is not inlined
+ # before strictness analysis runs
+
+ '-finline-phase2',
+ $Oopt_MaxSimplifierIterations,
']',
+
'-fstrictness',
- # '-fcpr-analyse',
+ '-fcpr-analyse',
'-fworker-wrapper',
'-fsimplify',
']',
'-ffloat-inwards',
+ '-fcse',
# Case-liberation for -O2. This should be after
# strictness analysis and the simplification which follows it.
'-fsimplify',
'[',
$Oopt_MaxSimplifierIterations,
+ # No -finline-phase: allow all Ids to be inlined now
']',
# '-fstatic-args',
/^-fallow-overlapping-instances$/ && do { push(@HsC_flags, $_); next arg; };
/^-fallow-undecidable-instances$/ && do { push(@HsC_flags, $_); next arg; };
/^-fhistory-size.*$/ && do { push(@HsC_flags, $_); next arg; };
+ /^-fdicts-strict$/ && do { push(@HsC_flags, $_); next arg; };
/^-fglasgow-exts$/
&& do { push(@HsC_flags, $_);
\begin{code}
foldr :: (a -> b -> b) -> b -> [a] -> b
-foldr _ z [] = z
-foldr f z (x:xs) = f x (foldr f z xs)
+-- foldr _ z [] = z
+-- foldr f z (x:xs) = f x (foldr f z xs)
+{-# INLINE foldr #-}
+foldr k z xs = go xs
+ where
+ go [] = z
+ go (x:xs) = x `k` go xs
build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
{-# INLINE build #-}
{-# INLINE map #-}
map f xs = build (\c n -> foldr (mapFB c f) n xs)
-mapFB c f xs = c (f xs)
+-- Note eta expanded
+mapFB c f x ys = c (f x) ys
mapList :: (a -> b) -> [a] -> [b]
mapList _ [] = []
\begin{code}
type String = [Char]
-data Char = C# Char# deriving (Eq, Ord)
+data Char = C# Char#
+
+-- We don't use deriving for Eq and Ord, because for Ord the derived
+-- instance defines only compare, which takes two primops. Then
+-- '>' uses compare, and therefore takes two primops instead of one.
+
+instance Eq Char where
+ (C# c1) == (C# c2) = c1 `eqChar#` c2
+ (C# c1) /= (C# c2) = c1 `neChar#` c2
+
+instance Ord Char where
+ (C# c1) > (C# c2) = c1 `gtChar#` c2
+ (C# c1) >= (C# c2) = c1 `geChar#` c2
+ (C# c1) <= (C# c2) = c1 `leChar#` c2
+ (C# c1) < (C# c2) = c1 `ltChar#` c2
chr :: Int -> Char
chr (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
head :: [a] -> a
head (x:_) = x
-head [] = errorEmptyList "head"
+head [] = badHead
+
+badHead = errorEmptyList "head"
+
+-- This rule is useful in cases like
+-- head [y | (x,y) <- ps, x==t]
+{-# RULES
+"head/build" forall g::forall b.(Bool->b->b)->b->b .
+ head (build g) = g (\x _ -> x) badHead
+"head/augment" forall xs, g::forall b. (a->b->b) -> b -> b .
+ head (augment g xs) = g (\x _ -> x) (head xs)
+ #-}
tail :: [a] -> [a]
tail (_:xs) = xs
# that will break compatibility with older versions, up this variable.
#
HscIfaceFileVersion=5
+# But watch out: interface file format after Simon's renamer
+# hacking isn't the same as before, but it may not make
+# any difference for the GHC boot files.
+# May 1999
projects / ghc-hetmet.git / commitdiff