Commit edd06d67 authored by simonpj's avatar simonpj

[project @ 1999-06-22 07:59:54 by simonpj]

Many small tuning changes
parent 9636548d
......@@ -9,7 +9,7 @@ module Const (
conType, conPrimRep,
conOkForApp, conOkForAlt, isWHNFCon, isDataCon,
conIsTrivial, conIsCheap, conIsDupable, conStrictness,
conOkForSpeculation,
conOkForSpeculation, hashCon,
DataCon, PrimOp, -- For completeness
......@@ -27,10 +27,11 @@ module Const (
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 )
......@@ -41,6 +42,8 @@ import Outputable
import Util ( thenCmp )
import Ratio ( numerator, denominator )
import FastString ( uniqueOfFS )
import Char ( ord )
\end{code}
......@@ -185,7 +188,6 @@ data Literal
-- thin air. Integer is, so the type here is really redundant.
\end{code}
\begin{code}
instance Outputable Literal where
ppr lit = pprLit lit
......@@ -374,3 +376,44 @@ 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}
......@@ -658,10 +658,11 @@ noLBVarInfo = NoLBVarInfo
-- 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)
......
......@@ -15,7 +15,7 @@ module Name (
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
isWiredInName,
isWiredInName, hashName,
nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason,
tidyTopName,
......@@ -30,7 +30,7 @@ module Name (
-- Provenance
Provenance(..), ImportReason(..), pprProvenance,
ExportFlag(..), PrintUnqualified,
pprNameProvenance, systemProvenance, hasBetterProv,
pprNameProvenance, hasBetterProv,
-- Class NamedThing and overloaded friends
NamedThing(..),
......@@ -48,7 +48,7 @@ import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
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}
......@@ -116,7 +116,7 @@ mkKnownKeyGlobal (rdr_name, uniq)
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
......@@ -376,6 +376,9 @@ isExternallyVisibleName :: Name -> Bool
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 $
%
%********************************************************
%* *
......@@ -745,7 +745,8 @@ cgPrimInlineAlts bndr ty alts deflt
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 $
%
%********************************************************
%* *
......@@ -28,6 +28,7 @@ module CgTailCall (
import CgMonad
import AbsCSyn
import PprAbsC ( pprAmode )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
......@@ -118,7 +119,8 @@ performPrimReturn :: SDoc -- Just for debugging (sigh)
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 ;
......@@ -14,10 +14,13 @@ find, unsurprisingly, a Core expression.
\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,
......@@ -44,17 +47,17 @@ import CoreSyn
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 )
......@@ -83,34 +86,51 @@ data Unfolding
-- 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
......@@ -232,7 +252,9 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
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`
......@@ -244,10 +266,13 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
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)
......@@ -256,7 +281,8 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
-- 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
......@@ -332,8 +358,12 @@ buildSize = SizeIs (-2#) emptyBag 4#
-- 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#
......@@ -450,7 +480,7 @@ callSiteInline black_listed inline_call id args interesting_cont
= 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
......@@ -459,7 +489,6 @@ callSiteInline black_listed inline_call id args interesting_cont
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
......@@ -467,22 +496,22 @@ callSiteInline black_listed inline_call id args interesting_cont
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
......@@ -494,17 +523,20 @@ callSiteInline black_listed inline_call id args interesting_cont
-- 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
......@@ -531,7 +563,7 @@ callSiteInline black_listed inline_call id args interesting_cont
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
......@@ -550,7 +582,7 @@ callSiteInline black_listed inline_call id args interesting_cont
-- 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
......@@ -604,9 +636,10 @@ blackListed :: IdSet -- Used in transformation rules
-- 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)
......
......@@ -7,26 +7,28 @@
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
......@@ -106,71 +108,6 @@ applyTypeToArgs e op_ty (other_arg : args)
%* *
%************************************************************************
\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.
......@@ -190,8 +127,12 @@ exprIsTrivial other = False
@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
......@@ -215,10 +156,13 @@ dupAppSize = 4 -- Size of application we are prepared to duplicate
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
......@@ -234,6 +178,8 @@ which aren't WHNF but are ``cheap'' are:
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.
......@@ -244,9 +190,12 @@ exprIsCheap (Var _) = True
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
......@@ -326,14 +275,19 @@ exprIsBottom e = go 0 e
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
......@@ -346,39 +300,6 @@ exprIsValue e@(App _ _) = case collectArgs e of
_ -> 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: