diff options
| -rw-r--r-- | compiler/coreSyn/CoreArity.lhs | 4 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 237 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 1 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 6 | ||||
| -rw-r--r-- | compiler/prelude/PrimOp.lhs | 59 | ||||
| -rw-r--r-- | compiler/simplCore/FloatIn.lhs | 10 | ||||
| -rw-r--r-- | compiler/simplCore/OccurAnal.lhs | 4 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.lhs | 10 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.lhs | 20 |
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) |