Refactoring in CoreUtils/CoreArity
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 27 Apr 2012 15:28:02 +0000 (16:28 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 27 Apr 2012 15:28:02 +0000 (16:28 +0100)
In the previous commit about "aggressive primops" 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

This patch also does some renaming

    CheapAppFun      -->   FunAppAnalyser
    isCheapApp       -->   isHNFApp
    isExpandableApp  -->   isConLikeApp

compiler/coreSyn/CoreArity.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs

index 249861a..ce22f80 100644 (file)
@@ -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
index 8ec132f..d4abf0d 100644 (file)
@@ -21,10 +21,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,
@@ -636,6 +636,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
 %*                                                                      *
 %************************************************************************
@@ -679,15 +736,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
@@ -763,40 +819,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.
-
 
 %************************************************************************
 %*                                                                      *
@@ -938,31 +962,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]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -1047,57 +1051,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]
@@ -1115,6 +1115,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.
 
 %************************************************************************
 %*                                                                      *
index 95a473e..7a0bf14 100644 (file)
@@ -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
@@ -1334,7 +1334,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
index 0af0b7f..d83a67e 100644 (file)
@@ -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.
 
index 0b95050..d739932 100644 (file)
@@ -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