diff options
-rw-r--r-- | compiler/coreSyn/CoreArity.lhs | 4 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 237 | ||||
-rw-r--r-- | compiler/simplCore/OccurAnal.lhs | 4 | ||||
-rw-r--r-- | compiler/simplCore/SimplUtils.lhs | 10 | ||||
-rw-r--r-- | compiler/simplCore/Simplify.lhs | 3 |
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 |