summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSimon Marlow <marlowsd@gmail.com>2012-01-16 12:41:56 +0000
committerSimon Marlow <marlowsd@gmail.com>2012-01-16 13:27:57 +0000
commit395ef284545bb5e7a57c180cc1f2a1b66fa30f37 (patch)
treef98b8e581c6122f6c86a2b3241c9bdf7550e6270 /compiler
parentfac8ecbbafde17dd92439c41747223c43e9d2b80 (diff)
downloadhaskell-395ef284545bb5e7a57c180cc1f2a1b66fa30f37.tar.gz
Revert "Add -faggressive-primops plus refactoring in CoreUtils" (#5780)
This reverts commit 601c983dd0bada6b49bdadd8f172fd4eacac4b0c.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/coreSyn/CoreArity.lhs4
-rw-r--r--compiler/coreSyn/CoreUtils.lhs237
-rw-r--r--compiler/main/StaticFlagParser.hs1
-rw-r--r--compiler/main/StaticFlags.hs6
-rw-r--r--compiler/prelude/PrimOp.lhs59
-rw-r--r--compiler/simplCore/FloatIn.lhs10
-rw-r--r--compiler/simplCore/OccurAnal.lhs4
-rw-r--r--compiler/simplCore/SimplUtils.lhs10
-rw-r--r--compiler/simplCore/Simplify.lhs20
9 files changed, 137 insertions, 214 deletions
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index ce22f80fa8..249861a4e4 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -473,7 +473,7 @@ vanillaArityType = ATop [] -- Totally uninformative
-- ^ The Arity returned is the number of value args the
-- expression can be applied to without doing much work
-exprEtaExpandArity :: DynFlags -> FunAppAnalyser -> CoreExpr -> Arity
+exprEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
exprEtaExpandArity dflags cheap_app e
@@ -497,7 +497,7 @@ getBotArity :: ArityType -> Maybe Arity
getBotArity (ABot n) = Just n
getBotArity _ = Nothing
-mk_cheap_fn :: DynFlags -> FunAppAnalyser -> CheapFun
+mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun
mk_cheap_fn dflags cheap_app
| not (dopt Opt_DictsCheap dflags)
= \e _ -> exprIsCheap' cheap_app e
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index b91125d5dd..198ac7e610 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -20,10 +20,10 @@ module CoreUtils (
-- * Properties of expressions
exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
- exprIsCheap, exprIsExpandable, exprIsCheap', FunAppAnalyser,
+ exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
- exprIsBig, exprIsConLike, exprCertainlyTerminates,
- rhsIsStatic, isHNFApp, isConLikeApp,
+ exprIsBig, exprIsConLike,
+ rhsIsStatic, isCheapApp, isExpandableApp,
-- * Expression and bindings size
coreBindsSize, exprSize,
@@ -553,63 +553,6 @@ dupAppSize = 8 -- Size of term we are prepared to duplicate
%************************************************************************
%* *
- FunAppAnalyser
-%* *
-%************************************************************************
-
-\begin{code}
--- | Given a function and the number of _value_ arguments,
--- return a boolean
-type FunAppAnalyser = Id -> Int -> Bool
-
-isHNFApp :: FunAppAnalyser
-isHNFApp fn n_val_args
- = isDataConWorkId fn
- || n_val_args < idArity fn
- || (n_val_args == 0 && (isEvaldUnfolding (idUnfolding fn)
- || isUnLiftedType (idType fn)))
-
-isConLikeApp :: FunAppAnalyser
-isConLikeApp fn n_val_args
- = isConLikeId fn
- || n_val_args < idArity fn
- || (if n_val_args == 0
- then isConLikeUnfolding (idUnfolding fn)
- || isUnLiftedType (idType fn)
- else hack_me n_val_args (idType fn))
- where
- -- See if all the arguments are PredTys (implicit params or classes)
- -- If so we'll regard it as expandable; see Note [Expandable overloadings]
- hack_me 0 _ = True
- hack_me n_val_args ty
- | Just (_, ty) <- splitForAllTy_maybe ty = hack_me n_val_args ty
- | Just (arg, ty) <- splitFunTy_maybe ty
- , isPredTy arg = hack_me (n_val_args-1) ty
- | otherwise = False
-
-isTerminatingApp :: FunAppAnalyser
-isTerminatingApp fn n_val_args
- | isPrimOpId fn = not (isBottomingId fn)
- | otherwise = isHNFApp fn n_val_args
- -- Primops terminate, with the exception of, well, exceptions.
- -- Their strictness signature tells us about them
-\end{code}
-
-Note [Expandable overloadings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose the user wrote this
- {-# RULE forall x. foo (negate x) = h x #-}
- f x = ....(foo (negate x))....
-He'd expect the rule to fire. But since negate is overloaded, we might
-get this:
- f = \d -> let n = negate d in \x -> ...foo (n x)...
-So we treat the application of a function (negate in this case) to a
-*dictionary* as expandable. In effect, every function is CONLIKE when
-it's applied only to dictionaries.
-
-
-%************************************************************************
-%* *
exprIsCheap, exprIsExpandable
%* *
%************************************************************************
@@ -653,14 +596,15 @@ False to exprIsCheap.
\begin{code}
exprIsCheap :: CoreExpr -> Bool
-exprIsCheap = exprIsCheap' isHNFApp
+exprIsCheap = exprIsCheap' isCheapApp
exprIsExpandable :: CoreExpr -> Bool
-exprIsExpandable = exprIsCheap' isConLikeApp -- See Note [CONLIKE pragma] in BasicTypes
+exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
-exprIsCheap' :: FunAppAnalyser -> CoreExpr -> Bool
+type CheapAppFun = Id -> Int -> Bool
+exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
exprIsCheap' _ (Lit _) = True
-exprIsCheap' _ (Type _) = True
+exprIsCheap' _ (Type _) = True
exprIsCheap' _ (Coercion _) = True
exprIsCheap' _ (Var _) = True
exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e
@@ -736,8 +680,40 @@ exprIsCheap' good_app other_expr -- Applications and variables
-- lambda. Particularly for dictionary field selection.
-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
+
+isCheapApp :: CheapAppFun
+isCheapApp fn n_val_args
+ = isDataConWorkId fn
+ || n_val_args < idArity fn
+
+isExpandableApp :: CheapAppFun
+isExpandableApp fn n_val_args
+ = isConLikeId fn
+ || n_val_args < idArity fn
+ || go n_val_args (idType fn)
+ where
+ -- See if all the arguments are PredTys (implicit params or classes)
+ -- If so we'll regard it as expandable; see Note [Expandable overloadings]
+ go 0 _ = True
+ go n_val_args ty
+ | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty
+ | Just (arg, ty) <- splitFunTy_maybe ty
+ , isPredTy arg = go (n_val_args-1) ty
+ | otherwise = False
\end{code}
+Note [Expandable overloadings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose the user wrote this
+ {-# RULE forall x. foo (negate x) = h x #-}
+ f x = ....(foo (negate x))....
+He'd expect the rule to fire. But since negate is overloaded, we might
+get this:
+ f = \d -> let n = negate d in \x -> ...foo (n x)...
+So we treat the application of a function (negate in this case) to a
+*dictionary* as expandable. In effect, every function is CONLIKE when
+it's applied only to dictionaries.
+
%************************************************************************
%* *
@@ -879,11 +855,31 @@ isDivOp _ = False
Note [exprOkForSpeculation: case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We keep going for case expressions. This used to be vital,
-for the reason described in Note [exprCertainlyTerminates: case expressions],
-but exprOkForSpeculation isn't used for that any more. So now it
-probably doesn't matter if said False for case expressions... but it's
-also fine to continue to accept case expressions.
+It's always sound for exprOkForSpeculation to return False, and we
+don't want it to take too long, so it bales out on complicated-looking
+terms. Notably lets, which can be stacked very deeply; and in any
+case the argument of exprOkForSpeculation is usually in a strict context,
+so any lets will have been floated away.
+
+However, we keep going on case-expressions. An example like this one
+showed up in DPH code (Trac #3717):
+ foo :: Int -> Int
+ foo 0 = 0
+ foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
+
+If exprOkForSpeculation doesn't look through case expressions, you get this:
+ T.$wfoo =
+ \ (ww :: GHC.Prim.Int#) ->
+ case ww of ds {
+ __DEFAULT -> case (case <# ds 5 of _ {
+ GHC.Types.False -> lvl1;
+ GHC.Types.True -> lvl})
+ of _ { __DEFAULT ->
+ T.$wfoo (GHC.Prim.-# ds_XkE 1) };
+ 0 -> 0
+ }
+
+The inner case is redundant, and should be nuked.
Note [Exhaustive alts]
~~~~~~~~~~~~~~~~~~~~~~
@@ -968,53 +964,57 @@ We say "yes", even though 'x' may not be evaluated. Reasons
-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
-- unboxed type must be ok-for-speculation (or trivial).
exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
-exprIsHNF = exprIsHNFlike isHNFApp
+exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
+\end{code}
+\begin{code}
-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
-- data constructors. Conlike arguments are considered interesting by the
--- inliner. Like a HNF version of exprIsExpandable.
+-- inliner.
exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP
-exprIsConLike = exprIsHNFlike isConLikeApp
-
--- | Tests if an expression guarantees to terminate,
--- when evaluated to head normal form
-exprCertainlyTerminates :: CoreExpr -> Bool
-exprCertainlyTerminates = exprIsHNFlike isTerminatingApp
+exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
-- | Returns true for values or value-like expressions. These are lambdas,
-- constructors / CONLIKE functions (as determined by the function argument)
-- or PAPs.
--
-exprIsHNFlike :: FunAppAnalyser -> CoreExpr -> Bool
-exprIsHNFlike app_is_hnf e = go e
+exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
+exprIsHNFlike is_con is_con_unf = is_hnf_like
where
- go (Var v) = app_is_hnf v 0
- go (App e a)
- | isRuntimeArg a = go_app e 1
- | otherwise = go e
- go (Lit _) = True
- go (Type _) = True -- Types are honorary Values;
- -- we don't mind copying them
- go (Coercion _) = True -- Same for coercions
- go (Lam b e) = isRuntimeVar b || go e
- go (Tick tickish e) = not (tickishCounts tickish) && go e
+ is_hnf_like (Var v) -- NB: There are no value args at this point
+ = is_con v -- Catches nullary constructors,
+ -- so that [] and () are values, for example
+ || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
+ || is_con_unf (idUnfolding v)
+ -- Check the thing's unfolding; it might be bound to a value
+ -- We don't look through loop breakers here, which is a bit conservative
+ -- but otherwise I worry that if an Id's unfolding is just itself,
+ -- we could get an infinite loop
+
+ is_hnf_like (Lit _) = True
+ is_hnf_like (Type _) = True -- Types are honorary Values;
+ -- we don't mind copying them
+ is_hnf_like (Coercion _) = True -- Same for coercions
+ is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e
+ is_hnf_like (Tick tickish e) = not (tickishCounts tickish)
+ && is_hnf_like e
-- See Note [exprIsHNF Tick]
- go (Cast e _) = go e
- go (Let _ e) = go e -- Lazy let(rec)s don't affect us
- go (Case e _ _ alts) = go e && all (\(_,_,rhs) -> go rhs) alts
- -- Keep going for case expressions
- -- See Note [exprCertainlyTerminates: case expressions]
-
- -- Gather up value arguments
- go_app :: CoreExpr -> Int -> Bool
- go_app (Var f) n = app_is_hnf f n
- go_app (App f a) n
- | isRuntimeArg a = go_app f (n+1)
- | otherwise = go_app f n
- go_app (Tick _ f) n = go_app f n
- go_app (Cast f _) n = go_app f n
- go_app _ _ = False
-
+ is_hnf_like (Cast e _) = is_hnf_like e
+ is_hnf_like (App e (Type _)) = is_hnf_like e
+ is_hnf_like (App e (Coercion _)) = is_hnf_like e
+ is_hnf_like (App e a) = app_is_value e [a]
+ is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us
+ is_hnf_like _ = False
+
+ -- There is at least one value argument
+ app_is_value :: CoreExpr -> [CoreArg] -> Bool
+ app_is_value (Var fun) args
+ = idArity fun > valArgCount args -- Under-applied function
+ || is_con fun -- or constructor-like
+ app_is_value (Tick _ f) as = app_is_value f as
+ app_is_value (Cast f _) as = app_is_value f as
+ app_is_value (App f a) as = app_is_value f (a:as)
+ app_is_value _ _ = False
{-
Note [exprIsHNF Tick]
@@ -1032,33 +1032,6 @@ don't want to discard a seq on it.
-}
\end{code}
-Note [exprCertainlyTerminates: case expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's always sound for exprOkForSpeculation to return False, and we
-don't want it to take too long, so it bales out on complicated-looking
-terms. Notably lets, which can be stacked very deeply; and in any
-case the argument of exprOkForSpeculation is usually in a strict context,
-so any lets will have been floated away.
-
-However, we keep going on case-expressions. An example like this one
-showed up in DPH code (Trac #3717):
- foo :: Int -> Int
- foo 0 = 0
- foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
-
-If exprOkForSpeculation doesn't look through case expressions, you get this:
- T.$wfoo =
- \ (ww :: GHC.Prim.Int#) ->
- case ww of ds {
- __DEFAULT -> case (case <# ds 5 of _ {
- GHC.Types.False -> lvl1;
- GHC.Types.True -> lvl})
- of _ { __DEFAULT ->
- T.$wfoo (GHC.Prim.-# ds_XkE 1) };
- 0 -> 0
- }
-
-The inner case is redundant, and should be nuked.
%************************************************************************
%* *
diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
index e6b0d4cb94..07eb214f74 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -192,7 +192,6 @@ isStaticFlag f =
"static",
"fhardwire-lib-paths",
"funregisterised",
- "faggressive-primops",
"fcpr-off",
"ferror-spans",
"fPIC",
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 3c13e08372..c2f8674aa9 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -62,7 +62,6 @@ module StaticFlags (
opt_SimplExcessPrecision,
opt_NoOptCoercion,
opt_MaxWorkerArgs,
- opt_AggressivePrimOps,
-- Unfolding control
opt_UF_CreationThreshold,
@@ -322,11 +321,6 @@ opt_NoStateHack = lookUp (fsLit "-fno-state-hack")
opt_CprOff :: Bool
opt_CprOff = lookUp (fsLit "-fcpr-off")
-- Switch off CPR analysis in the new demand analyser
-
-opt_AggressivePrimOps :: Bool
-opt_AggressivePrimOps = lookUp (fsLit "-faggressive-primops")
- -- See Note [Aggressive PrimOps] in PrimOp
-
opt_MaxWorkerArgs :: Int
opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index 13d1498503..39bee1fb9d 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -356,19 +356,6 @@ Consequences:
the writeMutVar will be performed in both branches, which is
utterly wrong.
- Example of a worry about float-in:
- case (writeMutVar v i s) of s' ->
- if b then return s'
- else error "foo"
- Then, since s' is used only in the then-branch, we might float
- in to get
- if b then case (writeMutVar v i s) of s' -> returns s'
- else error "foo"
- So in the 'else' case the write won't happen. The same is
- true if instead of writeMutVar you had some I/O performing thing.
- Is this ok? Yes: if you care about this you should be using
- throwIO, not throw.
-
* You cannot duplicate a has_side_effect primop. You might wonder
how this can occur given the state token threading, but just look
at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like
@@ -386,14 +373,11 @@ Consequences:
However, it's fine to duplicate a can_fail primop. That is
the difference between can_fail and has_side_effects.
-
---------------- Summary table ------------------------
can_fail has_side_effects
Discard YES YES
Float in YES YES
Float out NO NO
Duplicate YES NO
--------------------------------------------------------
How do we achieve these effects?
@@ -411,17 +395,6 @@ Note [primOpOkForSpeculation]
* The no-duplicate thing is done via primOpIsCheap, by making
has_side_effects things (very very very) not-cheap!
-Note [Aggressive PrimOps]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We have a static flag opt_AggressivePrimOps, on by default,
-controlled by -fconservative-primops. When AggressivePrimOps is
-*off* we revert to the old behaviour in which
- a) we do not float in has_side_effect ops
- b) we never discard has_side_effect ops as dead code
-I now think that this more conservative behaviour is unnecessary,
-but having a static flag lets us recover it when we want, in case
-there are mysterious errors.
-
\begin{code}
primOpHasSideEffects :: PrimOp -> Bool
@@ -431,32 +404,28 @@ primOpCanFail :: PrimOp -> Bool
#include "primop-can-fail.hs-incl"
primOpOkForSpeculation :: PrimOp -> Bool
- -- ok-for-speculation means the primop can be let-bound
- -- and can float in and out freely
- -- See Note [PrimOp can_fail and has_side_effects]
+ -- See Note [primOpOkForSpeculation and primOpOkForFloatOut]
-- See comments with CoreUtils.exprOkForSpeculation
primOpOkForSpeculation op
- = not (primOpHasSideEffects op || primOpCanFail op)
+ = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op)
primOpOkForSideEffects :: PrimOp -> Bool
primOpOkForSideEffects op
= not (primOpHasSideEffects op)
+\end{code}
-primOpIsCheap :: PrimOp -> Bool
-primOpIsCheap op
- = not (primOpHasSideEffects op)
- -- This is vital; see Note [PrimOp can_fail and has_side_effects]
- && primOpCodeSize op <= primOpCodeSizeDefault
- && not (primOpOutOfLine op)
- -- The latter two conditions are a HACK; we should
- -- really have a proper property on primops that says
- -- when they are cheap to execute. For now we are using
- -- that the code size is small and not out-of-line.
- --
- -- NB that as things stand, array indexing operations
- -- have default-size code size, and hence will be regarded
- -- as cheap; we might want to make them more expensive!
+Note [primOpIsCheap]
+~~~~~~~~~~~~~~~~~~~~
+@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
+WARNING), we just borrow some other predicates for a
+what-should-be-good-enough test. "Cheap" means willing to call it more
+than once, and/or push it inside a lambda. The latter could change the
+behaviour of 'seq' for primops that can fail, so we don't treat them as cheap.
+
+\begin{code}
+primOpIsCheap :: PrimOp -> Bool
+primOpIsCheap op = primOpOkForSpeculation op
-- In March 2001, we changed this to
-- primOpIsCheap op = False
-- thereby making *no* primops seem cheap. But this killed eta
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index a25ed4037d..0601d7b7bf 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -33,7 +33,6 @@ import Type ( isUnLiftedType )
import VarSet
import Util ( zipEqual, zipWithEqual, count )
import UniqFM
-import StaticFlags ( opt_AggressivePrimOps )
import Outputable
\end{code}
@@ -358,14 +357,7 @@ alternatives/default [default FVs always {\em first}!].
\begin{code}
fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)])
| isUnLiftedType (idType case_bndr)
- , opt_AggressivePrimOps || exprOkForSideEffects (deAnnotate scrut)
--- It should be ok to float in ANY primop.
--- See Note [PrimOp can_fail and has_side_effects] in PrimOp
--- The AggressIvePrimOps flag lets us recover the earlier
--- more conservative behaviour. See Note [Aggressive PrimOps] in PrimOp
---
--- It would NOT be ok if a primop evaluated an unlifted
--- argument, but no primop does that.
+ , exprOkForSideEffects (deAnnotate scrut)
= wrapFloats shared_binds $
fiExpr (case_float : rhs_binds) rhs
where
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index ae02a1f2fc..8056c0eceb 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -28,7 +28,7 @@ module OccurAnal (
import CoreSyn
import CoreFVs
-import CoreUtils ( exprIsTrivial, isDefaultAlt, isConLikeApp, mkCast )
+import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCast )
import Id
import Name( localiseName )
import BasicTypes
@@ -1240,7 +1240,7 @@ occAnalApp env (Var fun, args)
where
fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0)
- is_exp = isConLikeApp fun (valArgCount args)
+ is_exp = isExpandableApp fun (valArgCount args)
-- See Note [CONLIKE pragma] in BasicTypes
-- The definition of is_exp should match that in
-- Simplify.prepareRhs
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 46f49fd1a6..86dc88ddd1 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1161,10 +1161,10 @@ findArity dflags bndr rhs old_arity
-- we stop right away (since arities should not decrease)
-- Result: the common case is that there is just one iteration
where
- init_cheap_app :: FunAppAnalyser
+ init_cheap_app :: CheapAppFun
init_cheap_app fn n_val_args
| fn == bndr = True -- On the first pass, this binder gets infinite arity
- | otherwise = isHNFApp fn n_val_args
+ | otherwise = isCheapApp fn n_val_args
go :: Arity -> Arity
go cur_arity
@@ -1178,10 +1178,10 @@ findArity dflags bndr rhs old_arity
where
new_arity = exprEtaExpandArity dflags cheap_app rhs
- cheap_app :: FunAppAnalyser
+ cheap_app :: CheapAppFun
cheap_app fn n_val_args
| fn == bndr = n_val_args < cur_arity
- | otherwise = isHNFApp fn n_val_args
+ | otherwise = isCheapApp fn n_val_args
\end{code}
Note [Eta-expanding at let bindings]
@@ -1244,7 +1244,7 @@ argument
type CheapFun = CoreExpr -> Maybe Type -> Bool
used to decide if an expression is cheap enough to push inside a
lambda. And exprIsCheap' in turn takes an argument
- type FunAppAnalyser = Id -> Int -> Bool
+ type CheapAppFun = Id -> Int -> Bool
which tells when an application is cheap. This makes it easy to
write the analysis loop.
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 9ad7dc79cc..4d1717f4ea 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -45,7 +45,6 @@ import TysPrim ( realWorldStatePrimTy )
import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM )
import Maybes ( orElse, isNothing )
-import StaticFlags ( opt_AggressivePrimOps )
import Data.List ( mapAccumL )
import Outputable
import FastString
@@ -478,7 +477,7 @@ prepareRhs top_lvl env0 _ rhs0
go n_val_args env (Var fun)
= return (is_exp, env, Var fun)
where
- is_exp = isConLikeApp fun n_val_args -- The fun a constructor or PAP
+ is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
-- See Note [CONLIKE pragma] in BasicTypes
-- The definition of is_exp should match that in
-- OccurAnal.occAnalApp
@@ -1658,7 +1657,7 @@ check that
or
(b) the scrutinee is a variable and 'x' is used strictly
or
- (c) 'x' is not used at all and e certainly terminates
+ (c) 'x' is not used at all and e is ok-for-speculation
For the (c), consider
case (case a ># b of { True -> (p,q); False -> (q,p) }) of
@@ -1779,21 +1778,18 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
-- The case binder is going to be evaluated later,
-- and the scrutinee is a simple variable
- || (is_plain_seq && expr_terminates)
+ || (is_plain_seq && ok_for_spec)
-- Note: not the same as exprIsHNF
elim_unlifted
- | is_plain_seq
- = if opt_AggressivePrimOps then expr_terminates
- else exprOkForSideEffects scrut
- -- The entire case is dead, so we can drop it
- -- But if AggressivePrimOps isn't on, only drop it
- -- if it has no side effects
- | otherwise = exprOkForSpeculation scrut
+ | is_plain_seq = exprOkForSideEffects scrut
+ -- The entire case is dead, so we can drop it,
+ -- _unless_ the scrutinee has side effects
+ | otherwise = exprOkForSpeculation scrut
-- The case-binder is alive, but we may be able
-- turn the case into a let, if the expression is ok-for-spec
- expr_terminates = exprCertainlyTerminates scrut
+ ok_for_spec = exprOkForSpeculation scrut
is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect
strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)