Commit 1790dbe4 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add -fpedantic-bottoms, and document it

I did a bit of refactoring (of course) at the same time.
See the discussion in Trac #5587.  Most of the real change
is in CoreArity.
parent 9c48a3c3
......@@ -34,6 +34,7 @@ import TyCon ( isRecursiveTyCon, isClassTyCon )
import Coercion
import BasicTypes
import Unique
import DynFlags ( DynFlags, DynFlag(..), dopt )
import Outputable
import FastString
import Pair
......@@ -128,11 +129,12 @@ exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
-- and gives them a suitable strictness signatures. It's used during
-- float-out
exprBotStrictness_maybe e
= case getBotArity (arityType [] is_cheap e) of
= case getBotArity (arityType env e) of
Nothing -> Nothing
Just ar -> Just (ar, mkStrictSig (mkTopDmdType (replicate ar topDmd) BotRes))
where
is_cheap _ _ = False -- Irrelevant for this purpose
env = AE { ae_bndrs = [], ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
-- For this purpose we can be very simple
\end{code}
Note [exprArity invariant]
......@@ -273,8 +275,9 @@ This isn't really right in the presence of seq. Consider
(f bot) `seq` 1
This should diverge! But if we eta-expand, it won't. We ignore this
"problem", because being scrupulous would lose an important
transformation for many programs.
"problem" (unless -fpedantic-bottoms is on), because being scrupulous
would lose an important transformation for many programs. (See
Trac #5587 for an example.)
Consider also
f = \x -> error "foo"
......@@ -470,17 +473,21 @@ vanillaArityType = ATop [] -- Totally uninformative
-- ^ The Arity returned is the number of value args the
-- expression can be applied to without doing much work
exprEtaExpandArity :: CheapFun -> CoreExpr -> Arity
exprEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
exprEtaExpandArity cheap_fun e
= case (arityType [] cheap_fun e) of
exprEtaExpandArity dflags cheap_app e
= case (arityType env e) of
ATop (os:oss)
| os || has_lam e -> 1 + length oss -- Note [Eta expanding thunks]
| otherwise -> 0
ATop [] -> 0
ABot n -> n
where
env = AE { ae_bndrs = []
, ae_cheap_fn = mk_cheap_fn dflags cheap_app
, ae_ped_bot = dopt Opt_PedanticBottoms dflags }
has_lam (Tick _ e) = has_lam e
has_lam (Lam b e) = isId b || has_lam e
has_lam _ = False
......@@ -489,8 +496,40 @@ getBotArity :: ArityType -> Maybe Arity
-- Arity of a divergent function
getBotArity (ABot n) = Just n
getBotArity _ = Nothing
mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun
mk_cheap_fn dflags cheap_app
| not (dopt Opt_DictsCheap dflags)
= \e _ -> exprIsCheap' cheap_app e
| otherwise
= \e mb_ty -> exprIsCheap' cheap_app e
|| case mb_ty of
Nothing -> False
Just ty -> isDictLikeTy ty
\end{code}
Note [Eta expanding through dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the experimental -fdicts-cheap flag is on, we eta-expand through
dictionary bindings. This improves arities. Thereby, it also
means that full laziness is less prone to floating out the
application of a function to its dictionary arguments, which
can thereby lose opportunities for fusion. Example:
foo :: Ord a => a -> ...
foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
-- So foo has arity 1
f = \x. foo dInt $ bar x
The (foo DInt) is floated out, and makes ineffective a RULE
foo (bar x) = ...
One could go further and make exprIsCheap reply True to any
dictionary-typed expression, but that's more work.
See Note [Dictionary-like types] in TcType.lhs for why we use
isDictLikeTy here rather than isDictTy
Note [Eta expanding thunks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
......@@ -565,13 +604,17 @@ type CheapFun = CoreExpr -> Maybe Type -> Bool
-- If the Maybe is Just, the type is the type
-- of the expression; Nothing means "don't know"
arityType :: [Id] -- Enclosing value-lambda Ids
-- See Note [Dealing with bottom (3)]
-> CheapFun
-> CoreExpr -> ArityType
data ArityEnv
= AE { ae_bndrs :: [Id] -- Enclosing value-lambda Ids
-- See Note [Dealing with bottom (3)]
, ae_cheap_fn :: CheapFun
, ae_ped_bot :: Bool -- True <=> be pedantic about bottoms
}
arityType under_lam cheap_fn (Cast e co)
= case arityType under_lam cheap_fn e of
arityType :: ArityEnv -> CoreExpr -> ArityType
arityType env (Cast e co)
= case arityType env e of
ATop os -> ATop (take co_arity os)
ABot n -> ABot (n `min` co_arity)
where
......@@ -583,7 +626,7 @@ arityType under_lam cheap_fn (Cast e co)
-- However, do make sure that ATop -> ATop and ABot -> ABot!
-- Casts don't affect that part. Getting this wrong provoked #5475
arityType _ _ (Var v)
arityType _ (Var v)
| Just strict_sig <- idStrictness_maybe v
, (ds, res) <- splitStrictSig strict_sig
, let arity = length ds
......@@ -596,17 +639,20 @@ arityType _ _ (Var v)
one_shots = typeArity (idType v)
-- Lambdas; increase arity
arityType under_lam cheap_fn (Lam x e)
| isId x = arityLam x (arityType (x:under_lam) cheap_fn e)
| otherwise = arityType under_lam cheap_fn e
arityType env (Lam x e)
| isId x = arityLam x (arityType env' e)
| otherwise = arityType env e
where
env' = env { ae_bndrs = x : ae_bndrs env }
-- Applications; decrease arity, except for types
arityType under_lam cheap_fn (App fun (Type _))
= arityType under_lam cheap_fn fun
arityType under_lam cheap_fn (App fun arg )
= arityApp (arityType under_lam' cheap_fn fun) (cheap_fn arg Nothing)
arityType env (App fun (Type _))
= arityType env fun
arityType env (App fun arg )
= arityApp (arityType env' fun) (ae_cheap_fn env arg Nothing)
where
under_lam' = case under_lam of { [] -> []; (_:xs) -> xs }
env' = env { ae_bndrs = case ae_bndrs env of
{ [] -> []; (_:xs) -> xs } }
-- Case/Let; keep arity if either the expression is cheap
-- or it's a 1-shot lambda
......@@ -616,7 +662,7 @@ arityType under_lam cheap_fn (App fun arg )
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
--
arityType under_lam cheap_fn (Case scrut _ _ alts)
arityType env (Case scrut _ _ alts)
| exprIsBottom scrut
= ABot 0 -- Do not eta expand
-- See Note [Dealing with bottom (1)]
......@@ -626,29 +672,30 @@ arityType under_lam cheap_fn (Case scrut _ _ alts)
| otherwise -> ABot 0 -- if RHS is bottomming
-- See Note [Dealing with bottom (2)]
ATop as | is_under scrut -> ATop as
ATop as | not (ae_ped_bot env) -- Check -fpedantic-bottoms
, is_under scrut -> ATop as
| exprOkForSpeculation scrut -> ATop as
| otherwise -> ATop (takeWhile id as)
where
-- is_under implements Note [Dealing with bottom (3)]
is_under (Var f) = f `elem` under_lam
is_under (Var f) = f `elem` ae_bndrs env
is_under (App f (Type {})) = is_under f
is_under (Cast f _) = is_under f
is_under _ = False
alts_type = foldr1 andArityType [arityType under_lam cheap_fn rhs | (_,_,rhs) <- alts]
alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]
arityType under_lam cheap_fn (Let b e)
= floatIn (cheap_bind b) (arityType under_lam cheap_fn e)
arityType env (Let b e)
= floatIn (cheap_bind b) (arityType env e)
where
cheap_bind (NonRec b e) = is_cheap (b,e)
cheap_bind (Rec prs) = all is_cheap prs
is_cheap (b,e) = cheap_fn e (Just (idType b))
is_cheap (b,e) = ae_cheap_fn env e (Just (idType b))
arityType under_lam cheap_fn (Tick t e)
| not (tickishIsCode t) = arityType under_lam cheap_fn e
arityType env (Tick t e)
| not (tickishIsCode t) = arityType env e
arityType _ _ _ = vanillaArityType
arityType _ _ = vanillaArityType
\end{code}
......
......@@ -244,6 +244,7 @@ data DynFlag
| Opt_Vectorise
| Opt_RegsGraph -- do graph coloring register allocation
| Opt_RegsIterative -- do iterative coalescing graph coloring register allocation
| Opt_PedanticBottoms -- Be picky about how we treat bottom
-- Interface files
| Opt_IgnoreInterfacePragmas
......@@ -1753,6 +1754,7 @@ fFlags = [
( "liberate-case", Opt_LiberateCase, nop ),
( "spec-constr", Opt_SpecConstr, nop ),
( "cse", Opt_CSE, nop ),
( "pedantic-bottoms", Opt_PedanticBottoms, nop ),
( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, nop ),
( "omit-interface-pragmas", Opt_OmitInterfacePragmas, nop ),
( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, nop ),
......
......@@ -1139,8 +1139,7 @@ tryEtaExpand env bndr rhs
= return (exprArity rhs, rhs)
| sm_eta_expand (getMode env) -- Provided eta-expansion is on
, let dicts_cheap = dopt Opt_DictsCheap dflags
new_arity = findArity dicts_cheap bndr rhs old_arity
, let new_arity = findArity dflags bndr rhs old_arity
, new_arity > manifest_arity -- And the curent manifest arity isn't enough
-- See Note [Eta expansion to manifes arity]
= do { tick (EtaExpansion bndr)
......@@ -1152,16 +1151,21 @@ tryEtaExpand env bndr rhs
old_arity = idArity bndr
_dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
findArity :: Bool -> Id -> CoreExpr -> Arity -> Arity
findArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
-- This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
findArity dicts_cheap bndr rhs old_arity
= go (exprEtaExpandArity (mk_cheap_fn dicts_cheap init_cheap_app) rhs)
findArity dflags bndr rhs old_arity
= go (exprEtaExpandArity dflags init_cheap_app rhs)
-- We always call exprEtaExpandArity once, but usually
-- that produces a result equal to old_arity, and then
-- 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 fn n_val_args
| fn == bndr = True -- On the first pass, this binder gets infinite arity
| otherwise = isCheapApp fn n_val_args
go :: Arity -> Arity
go cur_arity
| cur_arity <= old_arity = cur_arity
......@@ -1172,46 +1176,12 @@ findArity dicts_cheap bndr rhs old_arity
, ppr rhs])
go new_arity
where
new_arity = exprEtaExpandArity (mk_cheap_fn dicts_cheap cheap_app) rhs
new_arity = exprEtaExpandArity dflags cheap_app rhs
cheap_app :: CheapAppFun
cheap_app fn n_val_args
| fn == bndr = n_val_args < cur_arity
| otherwise = isCheapApp fn n_val_args
init_cheap_app :: CheapAppFun
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
mk_cheap_fn :: Bool -> CheapAppFun -> CheapFun
mk_cheap_fn dicts_cheap cheap_app
| not dicts_cheap
= \e _ -> exprIsCheap' cheap_app e
| otherwise
= \e mb_ty -> exprIsCheap' cheap_app e
|| case mb_ty of
Nothing -> False
Just ty -> isDictLikeTy ty
-- If the experimental -fdicts-cheap flag is on, we eta-expand through
-- dictionary bindings. This improves arities. Thereby, it also
-- means that full laziness is less prone to floating out the
-- application of a function to its dictionary arguments, which
-- can thereby lose opportunities for fusion. Example:
-- foo :: Ord a => a -> ...
-- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
-- -- So foo has arity 1
--
-- f = \x. foo dInt $ bar x
--
-- The (foo DInt) is floated out, and makes ineffective a RULE
-- foo (bar x) = ...
--
-- One could go further and make exprIsCheap reply True to any
-- dictionary-typed expression, but that's more work.
--
-- See Note [Dictionary-like types] in TcType.lhs for why we use
-- isDictLikeTy here rather than isDictTy
\end{code}
Note [Eta-expanding at let bindings]
......
......@@ -1537,6 +1537,15 @@
<entry>-</entry>
</row>
<row>
<entry><option>-fpedantic-bottoms</option></entry>
<entry>Make GHC be more precise about its treatment of bottom (but see also
<option>-fno-state-hack</option>). In particular, GHC will not
eta-expand through a case expression.</entry>
<entry>dynamic</entry>
<entry><option>-fno-pedantic-bottoms</option></entry>
</row>
<row>
<entry><option>-fomit-interface-pragmas</option></entry>
<entry>Don't generate interface pragmas</entry>
......
......@@ -1854,6 +1854,20 @@ f "2" = 2
</listitem>
</varlistentry>
<varlistentry>
<term>
<option>-fpedantic-bottoms</option>
<indexterm><primary><option>-fpedantic-bottoms</option></primary></indexterm>
</term>
<listitem>
<para>Make GHC be more precise about its treatment of bottom (but see also
<option>-fno-state-hack</option>). In particular, stop GHC
eta-expanding through a case expression, which is good for
performance, but bad if you are using <literal>seq</literal> on
partial applications.</para>
</listitem>
</varlistentry>
<varlistentry>
<term>
<option>-fomit-interface-pragmas</option>
......
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