Add -faggressive-primops plus refactoring in CoreUtils

I'm experimenting with making GHC a bit more aggressive about
  a) dropping case expressions if the result is unused
        Simplify.rebuildCase, CaseElim equation

  b) floating case expressions inwards
        FloatIn.fiExpr, AnnCase

In both cases the new behaviour is gotten with a static (debug)
flag -faggressive-primops.  The extra "aggression" is to allow
discarding and floating in for side-effecting operations.  See
the new, extensive Note [PrimOp can_fail and has_side_effects]
in PrimoOp.

When discarding a case with unused binders, in the lifted-type
case it's definitely ok if the scrutinee terminates; previously
we were checking exprOkForSpeculation, which is significantly
worse.

So I wanted a new function CoreUtils.exprCertainlyTerminates.
In doing this I ended up with a significant refactoring in
CoreUtils.  The new structure has quite a lot of nice sharing:

    exprIsCheap             = exprIsCheap' isHNFApp
    exprIsExpandable        = exprIsCheap' isConLikeApp

    exprIsHNF               = exprIsHNFlike isHNFApp
    exprIsConLike           = exprIsHNFlike isConLikeApp
    exprCertainlyTerminates = exprIsHNFlike isTerminatingApp

9 files changed, 214 insertions, 137 deletions

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 249861a4e4..ce22f80fa8 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 -> CheapAppFun -> CoreExpr -> Arity
+exprEtaExpandArity :: DynFlags -> FunAppAnalyser -> 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 -> CheapAppFun -> CheapFun
+mk_cheap_fn :: DynFlags -> FunAppAnalyser -> 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 198ac7e610..b91125d5dd 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', CheapAppFun,
+        exprIsCheap, exprIsExpandable, exprIsCheap', FunAppAnalyser,
         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
-        exprIsBig, exprIsConLike,
-        rhsIsStatic, isCheapApp, isExpandableApp,
+        exprIsBig, exprIsConLike, exprCertainlyTerminates,
+        rhsIsStatic, isHNFApp, isConLikeApp,
 
         -- * Expression and bindings size
         coreBindsSize, exprSize,
@@ -553,6 +553,63 @@ 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
 %*                                                                      *
 %************************************************************************
@@ -596,15 +653,14 @@ False to exprIsCheap.
 
 \begin{code}
 exprIsCheap :: CoreExpr -> Bool
-exprIsCheap = exprIsCheap' isCheapApp
+exprIsCheap = exprIsCheap' isHNFApp
 
 exprIsExpandable :: CoreExpr -> Bool
-exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
+exprIsExpandable = exprIsCheap' isConLikeApp -- See Note [CONLIKE pragma] in BasicTypes
 
-type CheapAppFun = Id -> Int -> Bool
-exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
+exprIsCheap' :: FunAppAnalyser -> 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
@@ -680,40 +736,8 @@ 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.
-
 
 %************************************************************************
 %*                                                                      *
@@ -855,31 +879,11 @@ isDivOp _                = False
 
 Note [exprOkForSpeculation: 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.
+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.
 
 Note [Exhaustive alts]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -964,57 +968,53 @@ 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 isDataConWorkId isEvaldUnfolding
-\end{code}
+exprIsHNF = exprIsHNFlike isHNFApp
 
-\begin{code}
 -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
 -- data constructors. Conlike arguments are considered interesting by the
--- inliner.
+-- inliner.  Like a HNF version of exprIsExpandable.
 exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP
-exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
+exprIsConLike = exprIsHNFlike isConLikeApp
+
+-- | Tests if an expression guarantees to terminate, 
+-- when evaluated to head normal form
+exprCertainlyTerminates :: CoreExpr -> Bool
+exprCertainlyTerminates = exprIsHNFlike isTerminatingApp
 
 -- | Returns true for values or value-like expressions. These are lambdas,
 -- constructors / CONLIKE functions (as determined by the function argument)
 -- or PAPs.
 --
-exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
-exprIsHNFlike is_con is_con_unf = is_hnf_like
+exprIsHNFlike :: FunAppAnalyser -> CoreExpr -> Bool
+exprIsHNFlike app_is_hnf e = go e
   where
-    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
+    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
                                       -- See Note [exprIsHNF Tick]
-    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
+    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
+
 
 {-
 Note [exprIsHNF Tick]
@@ -1032,6 +1032,33 @@ 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 07eb214f74..e6b0d4cb94 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -192,6 +192,7 @@ 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 c2f8674aa9..3c13e08372 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -62,6 +62,7 @@ module StaticFlags (
 	opt_SimplExcessPrecision,
 	opt_NoOptCoercion,
 	opt_MaxWorkerArgs,
+        opt_AggressivePrimOps,
 
 	-- Unfolding control
 	opt_UF_CreationThreshold,
@@ -321,6 +322,11 @@ 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 39bee1fb9d..13d1498503 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -356,6 +356,19 @@ 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
@@ -373,11 +386,14 @@ 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?
 
@@ -395,6 +411,17 @@ 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
@@ -404,28 +431,32 @@ primOpCanFail :: PrimOp -> Bool
 #include "primop-can-fail.hs-incl"
 
 primOpOkForSpeculation :: PrimOp -> Bool
-  -- See Note [primOpOkForSpeculation and primOpOkForFloatOut]
+  -- 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 comments with CoreUtils.exprOkForSpeculation
 primOpOkForSpeculation op
-  = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op)
+  = not (primOpHasSideEffects op || primOpCanFail op)
 
 primOpOkForSideEffects :: PrimOp -> Bool
 primOpOkForSideEffects op
   = not (primOpHasSideEffects op)
-\end{code}
-
 
-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
+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!
+
 -- 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 0601d7b7bf..a25ed4037d 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -33,6 +33,7 @@ import Type		( isUnLiftedType )
 import VarSet
 import Util		( zipEqual, zipWithEqual, count )
 import UniqFM
+import StaticFlags      ( opt_AggressivePrimOps )
 import Outputable
 \end{code}
 
@@ -357,7 +358,14 @@ alternatives/default [default FVs always {\em first}!].
 \begin{code}
 fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)])
   | isUnLiftedType (idType case_bndr)
-  , exprOkForSideEffects (deAnnotate scrut)
+  , 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.
   = wrapFloats shared_binds $
     fiExpr (case_float : rhs_binds) rhs
   where
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 8056c0eceb..ae02a1f2fc 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, isExpandableApp, mkCast )
+import CoreUtils        ( exprIsTrivial, isDefaultAlt, isConLikeApp, 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 = isExpandableApp fun (valArgCount args)
+    is_exp   = isConLikeApp 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 86dc88ddd1..46f49fd1a6 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 :: CheapAppFun
+    init_cheap_app :: FunAppAnalyser
     init_cheap_app fn n_val_args
       | fn == bndr = True   -- On the first pass, this binder gets infinite arity
-      | otherwise  = isCheapApp fn n_val_args
+      | otherwise  = isHNFApp 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 :: CheapAppFun
+        cheap_app :: FunAppAnalyser
         cheap_app fn n_val_args
           | fn == bndr = n_val_args < cur_arity
-          | otherwise  = isCheapApp fn n_val_args
+          | otherwise  = isHNFApp 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 CheapAppFun = Id -> Int -> Bool
+     type FunAppAnalyser = 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 4d1717f4ea..9ad7dc79cc 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -45,6 +45,7 @@ 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
@@ -477,7 +478,7 @@ prepareRhs top_lvl env0 _ rhs0
     go n_val_args env (Var fun)
         = return (is_exp, env, Var fun)
         where
-          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
+          is_exp = isConLikeApp 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
@@ -1657,7 +1658,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 is ok-for-speculation
+        (c) 'x' is not used at all and e certainly terminates
 
 For the (c), consider
    case (case a ># b of { True -> (p,q); False -> (q,p) }) of
@@ -1778,18 +1779,21 @@ 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 && ok_for_spec)
+     || (is_plain_seq && expr_terminates)
               -- Note: not the same as exprIsHNF
 
     elim_unlifted 
-      | is_plain_seq = exprOkForSideEffects scrut
-            -- The entire case is dead, so we can drop it,
-            -- _unless_ the scrutinee has side effects
-      | otherwise    = exprOkForSpeculation scrut
+      | 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
             -- The case-binder is alive, but we may be able
             -- turn the case into a let, if the expression is ok-for-spec
 
-    ok_for_spec      = exprOkForSpeculation scrut
+    expr_terminates  = exprCertainlyTerminates scrut
     is_plain_seq     = isDeadBinder case_bndr	-- Evaluation *only* for effect
     strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)