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.

5 files changed, 115 insertions, 73 deletions

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 3229b58d65..249861a4e4 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -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}
   
   
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 2c0cccb0ba..8de96d80b3 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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 ),
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index f38b720632..3c4091650c 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -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]
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index e765525c13..1245d25fde 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -1538,6 +1538,15 @@
 	    </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>
 	      <entry>dynamic</entry>
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index 4cace1ee88..2837842a0e 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -1856,6 +1856,20 @@ f "2"    = 2
 
 	<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>
 	    <indexterm><primary><option>-fomit-interface-pragmas</option></primary></indexterm>
           </term>