Revert "Refactoring in CoreUtils/CoreArity"

This reverts commit e3f8557c2aca04cf64eec6a1aacde6e01c0944ff.

Sigh. Seg fault.

5 files changed, 115 insertions, 143 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 d4abf0d05e..8ec132f993 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -21,10 +21,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,
@@ -636,63 +636,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
 %*                                                                      *
 %************************************************************************
@@ -736,14 +679,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
@@ -819,8 +763,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.
+
 
 %************************************************************************
 %*                                                                      *
@@ -962,11 +938,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]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -1051,53 +1047,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]
@@ -1115,33 +1115,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/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 7a0bf144a1..95a473e2ae 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
@@ -1334,7 +1334,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 0b6c66e126..7bb4289cd3 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
@@ -1180,10 +1180,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]
@@ -1246,7 +1246,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 d739932db9..0b95050e73 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