diff options
Diffstat (limited to 'compiler')
| -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, 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) |