Commit 601c983d authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add -faggressive-primops plus refactoring in CoreUtils

I'm experimenting with making GHC a bit more aggressive about
  a) dropping case expressions if the result is unused
        Simplify.rebuildCase, CaseElim equation

  b) floating case expressions inwards
        FloatIn.fiExpr, AnnCase

In both cases the new behaviour is gotten with a static (debug)
flag -faggressive-primops.  The extra "aggression" is to allow
discarding and floating in for side-effecting operations.  See
the new, extensive Note [PrimOp can_fail and has_side_effects]
in PrimoOp.

When discarding a case with unused binders, in the lifted-type
case it's definitely ok if the scrutinee terminates; previously
we were checking exprOkForSpeculation, which is significantly
worse.

So 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
parent c96022cb
......@@ -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
......
This diff is collapsed.
......@@ -192,6 +192,7 @@ isStaticFlag f =
"static",
"fhardwire-lib-paths",
"funregisterised",
"faggressive-primops",
"fcpr-off",
"ferror-spans",
"fPIC",
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment