Commit 451a8613 authored by simonmar's avatar simonmar

[project @ 1999-05-26 14:12:07 by simonmar]

Several bugfixes (from SLPJ's tree).
parent b2368438
......@@ -34,6 +34,9 @@ module Id (
isConstantId, isBottomingId, idAppIsBottom,
isExportedId, isUserExportedId,
-- One shot lambda stuff
isOneShotLambda, setOneShotLambda,
-- IdInfo stuff
setIdUnfolding,
setIdArity,
......@@ -360,3 +363,16 @@ idMustBeINLINEd id = case getInlinePragma id of
IMustBeINLINEd -> True
other -> False
\end{code}
---------------------------------
-- ONE-SHOT LAMBDAS
\begin{code}
isOneShotLambda :: Id -> Bool
isOneShotLambda id = case lbvarInfo (idInfo id) of
IsOneShotLambda -> True
NoLBVarInfo -> False
setOneShotLambda :: Id -> Id
setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
\end{code}
......@@ -550,9 +550,11 @@ zapLamIdInfo info@(IdInfo {inlinePragInfo = inline_prag, demandInfo = demand})
= Just (info {inlinePragInfo = safe_inline_prag,
demandInfo = wwLazy})
where
-- The "unsafe" prags are the ones that say I'm not in a lambda
-- because that might not be true for an unsaturated lambda
is_safe_inline_prag = case inline_prag of
ICanSafelyBeINLINEd dup_danger nalts -> notInsideLambda dup_danger
other -> True
ICanSafelyBeINLINEd NotInsideLam nalts -> False
other -> True
safe_inline_prag = case inline_prag of
ICanSafelyBeINLINEd _ nalts
......@@ -644,15 +646,14 @@ work.
data LBVarInfo
= NoLBVarInfo
| IsOneShotLambda -- the lambda that binds this Id is applied
-- at most once
| IsOneShotLambda -- The lambda that binds this Id is applied
-- at most once
-- HACK ALERT! placing this info here is a short-term hack,
-- but it minimises changes to the rest of the compiler.
-- Hack agreed by SLPJ/KSW 1999-04.
\end{code}
\begin{code}
noLBVarInfo = NoLBVarInfo
-- not safe to print or parse LBVarInfo because it is not really a
......
......@@ -41,7 +41,7 @@ import TysWiredIn ( boolTy, charTy, mkListTy )
import PrelMods ( pREL_ERR, pREL_GHC )
import Type ( Type, ThetaType,
mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
......@@ -52,7 +52,7 @@ import Subst ( mkTopTyVarSubst, substTheta )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
import Class ( Class, classBigSig, classTyCon )
import Var ( Id, TyVar )
import VarEnv ( zipVarEnv )
import VarSet ( isEmptyVarSet )
import Const ( Con(..) )
import Name ( mkDerivedName, mkWiredInIdName, mkLocalName,
mkWorkerOcc, mkSuperDictSelOcc,
......@@ -458,7 +458,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
-- want to have any dict arguments, so that we can
-- expose the constant methods.
other -> nub (inst_decl_theta ++ sc_theta')
other -> nub (inst_decl_theta ++ filter not_const sc_theta')
-- Otherwise we pass the superclass dictionaries to
-- the dictionary function; the Mark Jones optimisation.
--
......@@ -467,8 +467,15 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
-- instance Monad m => MonadT (EnvT env) m where ...
-- Here, the inst_decl_theta has (Monad m); but so
-- does the sc_theta'!
--
-- NOTE the "not_const". I got caught by this one too:
-- class Foo a => Baz a b where ...
-- instance Wob b => Baz T b where..
-- Now sc_theta' has Foo T
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
\end{code}
......
......@@ -26,6 +26,7 @@ module Unique (
getKey, -- Used in Var only!
incrUnique, -- Used for renumbering
deriveUnique, -- Ditto
initTyVarUnique,
initTidyUniques,
......@@ -233,6 +234,7 @@ mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int# -- for Var
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
\end{code}
......@@ -242,9 +244,11 @@ mkUniqueGrimily x = MkUnique x
{-# INLINE getKey #-}
getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i +# 100#)
-- Bump the unique by a lot, to get it out of the neighbourhood
-- of its friends
incrUnique (MkUnique i) = MkUnique (i +# 1#)
-- deriveUnique uses an 'X' tag so that it won't clash with
-- any of the uniques produced any other way
deriveUnique (MkUnique i) delta = mkUnique 'X' (I# i + delta)
-- pop the Char in the top 8 bits of the Unique(Supply)
......@@ -255,12 +259,15 @@ i2w x = int2Word# x
i2w_s x = (x::Int#)
mkUnique (C# c) (I# i)
= MkUnique (w2i (((i2w (ord# c)) `shiftL#` (i2w_s 24#)) `or#` (i2w i)))
= MkUnique (w2i (tag `or#` bits))
where
tag = i2w (ord# c) `shiftL#` i2w_s 24#
bits = i2w i `and#` (i2w 16777215#){-``0x00ffffff''-}
unpkUnique (MkUnique u)
= let
tag = C# (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
i = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
i = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
in
(tag, i)
where
......@@ -406,6 +413,7 @@ Allocation of unique supply characters:
other a-z: lower case chars for unique supplies (see Main.lhs)
B: builtin
C-E: pseudo uniques (used in native-code generator)
X: uniques derived by deriveUnique
_: unifiable tyvars (above)
0-9: prelude things below
......
......@@ -7,4 +7,3 @@ _declarations_
1 type Id = Var ;
1 data Var ;
1 setIdName _:_ Id -> Name.Name -> Id ;;
......@@ -22,7 +22,7 @@ module VarSet (
import CmdLineOpts ( opt_PprStyle_Debug )
import Var ( Var, Id, TyVar, IdOrTyVar, setVarUnique )
import Unique ( Unique, Uniquable(..), incrUnique )
import Unique ( Unique, Uniquable(..), incrUnique, deriveUnique )
import UniqSet
import UniqFM ( delFromUFM_Directly )
import Outputable
......@@ -91,7 +91,7 @@ uniqAway set var
| not (var `elemVarSet` set) = var -- Nothing to do
| otherwise
= try 1 (incrUnique (getUnique var))
= try 1 (deriveUnique (getUnique var) (hashUniqSet set))
where
try n uniq | uniq `elemUniqSet_Directly` set = try ((n+1)::Int) (incrUnique uniq)
#ifdef DEBUG
......
__interface CgBindery 1 0 where
__export CgBindery CgBindings CgIdInfo{MkCgIdInfo} VolatileLoc StableLoc nukeVolatileBinds maybeStkLoc;
1 type CgBindings = VarEnv.IdEnv CgIdInfo;
1 data CgIdInfo = MkCgIdInfo Var.Id VolatileLoc StableLoc ClosureInfo!LambdaFormInfo;
1 data CgIdInfo = MkCgIdInfo Var.Id VolatileLoc StableLoc ClosureInfo.LambdaFormInfo;
1 data VolatileLoc;
1 data StableLoc;
1 nukeVolatileBinds :: CgBindings -> CgBindings ;
......
_interface_ CgExpr 1
_exports_
CgExpr cgExpr;
CgExpr cgExpr ;
_declarations_
1 cgExpr _:_ StgSyn.StgExpr -> CgMonad.Code ;;
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgHeapery.lhs,v 1.16 1999/05/13 17:30:56 simonm Exp $
% $Id: CgHeapery.lhs,v 1.17 1999/05/26 14:12:13 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
......@@ -310,6 +310,9 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code
CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
-- The SEQ case (polymophic/function typed case branch)
-- We need this case because the closure in Node won't return
-- directly when we enter it (it could be a function), so the
-- heap check code needs to push a seq frame on top of the stack.
[VanillaReg rep ILIT(1)]
| rep == PtrRep
&& is_fun ->
......
......@@ -7,7 +7,7 @@
module CoreUtils (
coreExprType, coreAltsType,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap, exprIsValue,
exprOkForSpeculation,
FormSummary(..), mkFormSummary, whnfOrBottom, exprArity,
cheapEqExpr, eqExpr, applyTypeToArgs
......@@ -133,6 +133,8 @@ whnfOrBottom OtherForm = False
\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
......@@ -143,7 +145,7 @@ mkFormSummary expr
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
go n (Let _ e) = OtherForm
-- We want selectors to look like values
-- e.g. case x of { (a,b) -> a }
......@@ -229,6 +231,9 @@ which aren't WHNF but are ``cheap'' are:
where op is a cheap primitive operator
Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once.
\begin{code}
exprIsCheap :: CoreExpr -> Bool
exprIsCheap (Type _) = True
......@@ -318,13 +323,35 @@ 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.
\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 (Lam b e) = isId b || exprIsValue e
exprIsValue (Note _ e) = exprIsValue e
exprIsValue (Let _ e) = False
exprIsValue (Case _ _ _) = False
exprIsValue (Con con _) = isWHNFCon con
exprIsValue e@(App _ _) = case collectArgs e of
(Var v, args) -> fun_arity > valArgCount args
where
fun_arity = arityLowerBound (getIdArity v)
_ -> 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
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
......@@ -337,10 +364,10 @@ 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 ||
v_uniq == buildIdKey ||
v_uniq == augmentIdKey
(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)
......
......@@ -4,4 +4,3 @@ HsExpr HsExpr pprExpr;
_declarations_
1 data HsExpr i p;
1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
......@@ -241,7 +241,7 @@ loadDecl mod decls_map (version, decl)
let
main_name = availName avail
new_decls_map = foldl add_decl decls_map
[ (name, (version, avail, name==main_name, (mod, decl)))
[ (name, (version, avail, name==main_name, (mod, decl')))
| name <- sys_bndrs ++ availNames avail]
add_decl decls_map (name, stuff)
= WARN( name `elemNameEnv` decls_map, ppr name )
......
......@@ -45,7 +45,7 @@ import PrelInfo ( derivingOccurrences, numClass_RDR,
bindIO_NAME
)
import Bag ( bagToList )
import List ( partition )
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
......@@ -559,6 +559,8 @@ checkConstraints explicit_forall doc forall_tyvars ctxt ty
False
tys
freeRdrTyVars :: RdrNameHsType -> [RdrName]
freeRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
......@@ -568,31 +570,37 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
let
mentioned_tyvars = filter isRdrTyVar (extractHsTyRdrNames ty)
forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_tyvars
mentioned_in_tau = freeRdrTyVars ty
forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
in
checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' ->
rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty)
rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- Explicit quantification.
-- Check that the forall'd tyvars are a subset of the
-- free tyvars in the tau-type part
-- That's only a warning... unless the tyvar is constrained by a
-- context in which case it's an error
= let
mentioned_tyvars = filter isRdrTyVar (extractHsTyRdrNames ty)
constrained_tyvars = [tv | (_,tys) <- ctxt,
mentioned_in_tau = freeRdrTyVars tau
mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
ty <- tys,
tv <- mentioned_tyvars]
dubious_guys = filter (`notElem` mentioned_tyvars) forall_tyvar_names
(bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys
tv <- freeRdrTyVars ty]
dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
-- dubious = explicitly quantified but not mentioned in tau type
(bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
-- bad = explicitly quantified and constrained, but not mentioned in tau
-- warn = explicitly quantified but not mentioned in ctxt or tau
forall_tyvar_names = map getTyVarName forall_tyvars
in
mapRn_ (forAllErr doc ty) bad_guys `thenRn_`
mapRn_ (forAllWarn doc ty) warn_guys `thenRn_`
checkConstraints True doc forall_tyvar_names ctxt ty `thenRn` \ ctxt' ->
rnForAll doc forall_tyvars ctxt' ty
mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
checkConstraints True doc forall_tyvar_names ctxt tau `thenRn` \ ctxt' ->
rnForAll doc forall_tyvars ctxt' tau
rnHsType doc (MonoTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
......@@ -878,12 +886,12 @@ forAllErr doc ty tyvar
(ptext SLIT("In") <+> doc))
ctxtErr explicit_forall doc tyvars constraint ty
= sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
= sep [ptext SLIT("None of the type variable(s) in the constraint") <+> quotes (pprClassAssertion constraint) <+>
ptext SLIT("does not mention any of"),
if explicit_forall then
nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars))
nest 4 (ptext SLIT("is universally quantified (i.e. bound by the forall)"))
else
nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty))
nest 4 (ptext SLIT("appears in the type") <+> quotes (ppr ty))
]
$$
(ptext SLIT("In") <+> doc)
......
......@@ -21,7 +21,8 @@ import CoreSyn
import CoreLint ( beginPass, endPass )
import Const ( isDataCon )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf )
import Var ( Id, idType )
import Id ( isOneShotLambda )
import Var ( Id, idType, isTyVar )
import Type ( isUnLiftedType )
import VarSet
import Util ( zipEqual )
......@@ -158,12 +159,13 @@ fiExpr to_drop (_,AnnApp fun arg)
[drop_here, fun_drop, arg_drop] = sepBindsByDropPoint [freeVarsOf fun, freeVarsOf arg] to_drop
\end{code}
We are careful about lambdas:
We are careful about lambdas:
* We never float inside a value lambda. That risks losing laziness.
* We must be careful about floating inside inside a value lambda.
That risks losing laziness.
The float-out pass might rescue us, but then again it might not.
* We don't float inside type lambdas either. At one time we did, and
* We must be careful about type lambdas too. At one time we did, and
there is no risk of duplicating work thereby, but we do need to be
careful. In particular, here is a bad case (it happened in the
cichelli benchmark:
......@@ -174,13 +176,24 @@ We are careful about lambdas:
This is bad as now f is an updatable closure (update PAP)
and has arity 0.
So the simple thing is never to float inside big lambda either.
Maybe we'll find cases when that loses something important; if
so we can modify the decision.
So we treat lambda in groups, using the following rule:
Float inside a group of lambdas only if
they are all either type lambdas or one-shot lambdas.
Otherwise drop all the bindings outside the group.
\begin{code}
fiExpr to_drop (_, AnnLam b body)
= mkCoLets' to_drop (Lam b (fiExpr [] body))
= case collect [b] body of
(bndrs, real_body)
| all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
| otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
where
collect bs (_, AnnLam b body) = collect (b:bs) body
collect bs body = (reverse bs, body)
is_ok bndr = isTyVar bndr || isOneShotLambda bndr
\end{code}
We don't float lets inwards past an SCC.
......
......@@ -34,7 +34,7 @@ import CoreSyn
import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom )
import CoreFVs -- all of it
import Id ( Id, idType, mkSysLocal )
import Id ( Id, idType, mkSysLocal, isOneShotLambda )
import Var ( IdOrTyVar, Var, setVarUnique )
import VarEnv
import VarSet
......@@ -301,8 +301,11 @@ lvlExpr ctxt_lvl env (_, AnnLam bndr rhs)
bndr_is_tyvar = isTyVar bndr
(bndrs, body) = go rhs
incd_lvl | bndr_is_id = incMajorLvl ctxt_lvl
| otherwise = incMinorLvl ctxt_lvl
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)]
new_env = extendLvlEnv env lvld_bndrs
......
......@@ -324,22 +324,6 @@ Several tasks are performed by the post-simplification pass
way of the above scheme. And anyway, IO is the only guaranteed
way to enforce ordering --SDM.
3. Mangle cases involving seq# in the discriminant. Up to this
point, seq# will appear like this:
case seq# e of
0# -> seqError#
_ -> ...
where the 0# branch is purely to bamboozle the strictness analyser
(see case 4 above). This code comes from an unfolding for 'seq'
in Prelude.hs. We translate this into
case e of
_ -> ...
Now that the evaluation order is safe.
4. Do eta reduction for lambda abstractions appearing in:
- the RHS of case alternatives
- the body of a let
......@@ -474,21 +458,6 @@ postSimplExpr (Note note body)
= postSimplExprEta body `thenPM` \ body' ->
returnPM (Note note body')
-- seq#: see notes above.
-- NB: seq# :: forall a. a -> Int#
postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
= postSimplExpr e `thenPM` \ e' ->
let
-- The old binder can't have been used, so we
-- can gaily re-use it (yuk!)
new_bndr = setIdType bndr ty
in
postSimplExprEta default_rhs `thenPM` \ rhs' ->
returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
where
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
-- par#: see notes above.
postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
| funnyParallelOp op && maybeToBool maybe_default
......
......@@ -27,7 +27,8 @@ import Id ( Id, idType, idInfo, idUnique,
getIdDemandInfo, setIdDemandInfo,
getIdArity, setIdArity,
getIdStrictness,
setInlinePragma, getInlinePragma, idMustBeINLINEd
setInlinePragma, getInlinePragma, idMustBeINLINEd,
setOneShotLambda
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
......@@ -45,7 +46,7 @@ import CoreFVs ( exprFreeVars )
import CoreUnfold ( Unfolding(..), mkUnfolding, callSiteInline,
isEvaldUnfolding, blackListed )
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
coreExprType, coreAltsType, exprArity,
coreExprType, coreAltsType, exprArity, exprIsValue,
exprOkForSpeculation
)
import Rules ( lookupRule )
......@@ -370,12 +371,12 @@ mkLamBndrZapper :: CoreExpr -- Function
-> Int -- Number of args
-> Id -> Id -- Use this to zap the binders
mkLamBndrZapper fun n_args
| saturated fun n_args = \b -> b
| otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
| n_args >= n_params fun = \b -> b -- Enough args
| otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
where
saturated (Lam b e) 0 = False
saturated (Lam b e) n = saturated e (n-1)
saturated e n = True
n_params (Lam b e) | isId b = 1 + n_params e
| otherwise = n_params e
n_params other = 0::Int
\end{code}
......@@ -849,10 +850,10 @@ completeApp fun args cont
-- Value argument
go (Lam bndr fun) (arg:args)
| preInlineUnconditionally bndr && not opt_SimplNoPreInlining
| preInlineUnconditionally zapped_bndr && not opt_SimplNoPreInlining
= tick (BetaReduction bndr) `thenSmpl_`
tick (PreInlineUnconditionally bndr) `thenSmpl_`
extendSubst bndr (DoneEx arg)
extendSubst zapped_bndr (DoneEx arg)
(go fun args)
| otherwise
= tick (BetaReduction bndr) `thenSmpl_`
......@@ -916,9 +917,8 @@ preInlineUnconditionally :: InId -> Bool
-- for the trivial bindings introduced by SimplUtils.mkRhsTyLam
preInlineUnconditionally bndr
= case getInlinePragma bndr of
IMustBeINLINEd -> True
ICanSafelyBeINLINEd InsideLam _ -> False
ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
IMustBeINLINEd -> True
ICanSafelyBeINLINEd NotInsideLam True -> True -- Not inside a lambda,
-- one occurrence ==> safe!
other -> False
......@@ -957,23 +957,6 @@ postInlineUnconditionally bndr rhs
-- from desugaring, with both a and b marked NOINLINE.
\end{code}
\begin{code}
inlineCase bndr scrut
= exprIsTrivial scrut -- Duplication is free
&& ( isUnLiftedType (idType bndr)
|| scrut_is_evald_var -- So dropping the case won't change termination
|| isStrict (getIdDemandInfo bndr) -- It's going to get evaluated later, so again
-- termination doesn't change
|| not opt_SimplPedanticBottoms) -- Or we don't care!
where
-- Check whether or not scrut is known to be evaluted
-- It's not going to be a visible value (else the previous
-- blob would apply) so we just check the variable case
scrut_is_evald_var = case scrut of
Var v -> isEvaldUnfolding (getIdUnfolding v)
other -> False
\end{code}
%************************************************************************
......@@ -1016,39 +999,51 @@ rebuild expr@(Con con args) (Select _ bndr alts se cont)
| conOkForAlt con -- Knocks out PrimOps and NoRepLits
= knownCon expr con args bndr alts se cont
-- Case of other value (e.g. a partial application or lambda)
-- Turn it back into a let
rebuild scrut (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
| isUnLiftedType (idType bndr) && exprOkForSpeculation scrut
|| exprIsWHNF scrut
= ASSERT( null bs && null alts )
setSubstEnv se $
simplBinder bndr $ \ bndr' ->
completeBinding bndr bndr' scrut $
simplExprF rhs cont
---------------------------------------------------------
-- The other Select cases
rebuild scrut (Select _ bndr alts se cont)
| all (cheapEqExpr rhs1) other_rhss
&& inlineCase bndr scrut
&& all binders_unused alts
| -- Check that the RHSs are all the same, and
-- don't use the binders in the alternatives
-- This test succeeds rapidly in the common case of
-- a single DEFAULT alternative
all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
-- 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
-- || not opt_SimplPedanticBottoms) -- Or we don't care!
-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
-- its argument: case x of { y -> dataToTag# y }
-- Here we must *not* discard the case, because dataToTag# just fetches the tag from
-- the info pointer. So we'll be pedantic all the time, and see if that gives any
-- other problems
)
&& opt_SimplDoCaseElim
= -- Get rid of the case altogether
-- See the extensive notes on case-elimination below
-- Remember to bind the binder though!
tick (CaseElim bndr) `thenSmpl_`
setSubstEnv se (
extendSubst bndr (DoneEx scrut) $
simplExprF rhs1 cont
)
tick (CaseElim bndr) `thenSmpl_` (
setSubstEnv se $
simplBinder bndr $ \ bndr' ->
completeBinding bndr bndr' scrut $
simplExprF rhs1 cont)
| otherwise