Fix Trac #2861: bogus eta expansion

Urghlhl!  I "tided up" the treatment of the "state hack" in CoreUtils, but
missed an unexpected interaction with the way that a bottoming function
simply swallows excess arguments.  There's a long
     Note [State hack and bottoming functions]
to explain (which accounts for most of the new lines of code).

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 415f5f7..8889282 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -884,7 +884,7 @@ exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
 -- exprEtaExpandArity is used when eta expanding
 --     e  ==>  \xy -> e x y
 exprEtaExpandArity dflags e
-    = applyStateHack (exprType e) (arityDepth (arityType dicts_cheap e))
+    = applyStateHack e (arityType dicts_cheap e)
   where
     dicts_cheap = dopt Opt_DictsCheap dflags
 
@@ -898,7 +898,6 @@ exprBotStrictness_maybe e
        AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes))
 \end{code}     
 
-
 Note [Definition of arity]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 The "arity" of an expression 'e' is n if
@@ -1005,11 +1004,13 @@ Then we expect that if f is applied to one arg, it'll be applied to two
 See also Id.isOneShotBndr.
 
 \begin{code}
-applyStateHack :: Type -> Arity -> Arity
-applyStateHack ty arity                -- Note [The state-transformer hack]
-  | opt_NoStateHack = arity
-  | otherwise       = go ty arity
-  where
+applyStateHack :: CoreExpr -> ArityType -> Arity
+applyStateHack e (AT orig_arity is_bot)
+  | opt_NoStateHack = orig_arity
+  | ABot <- is_bot  = orig_arity   -- Note [State hack and bottoming functions]
+  | otherwise       = go orig_ty orig_arity
+  where                        -- Note [The state-transformer hack]
+    orig_ty = exprType e
     go :: Type -> Arity -> Arity
     go ty arity                -- This case analysis should match that in eta_expand
        | Just (_, ty') <- splitForAllTy_maybe ty   = go ty' arity
@@ -1023,20 +1024,59 @@ applyStateHack ty arity         -- Note [The state-transformer hack]
 
        | Just (arg,res) <- splitFunTy_maybe ty
        , arity > 0 || isStateHackType arg = 1 + go res (arity-1)
-                                                        
+{-
+       = if arity > 0 then 1 + go res (arity-1)
+         else if isStateHackType arg then
+               pprTrace "applystatehack" (vcat [ppr orig_arity, ppr orig_ty,
+                                               ppr ty, ppr res, ppr e]) $
+               1 + go res (arity-1)
+          else WARN( arity > 0, ppr arity ) 0
+-}                                              
        | otherwise = WARN( arity > 0, ppr arity ) 0
 \end{code}
 
+Note [State hack and bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's a terrible idea to use the state hack on a bottoming function.
+Here's what happens (Trac #2861):
+
+  f :: String -> IO T
+  f = \p. error "..."
+
+Eta-expand, using the state hack:
+
+  f = \p. (\s. ((error "...") |> g1) s) |> g2
+  g1 :: IO T ~ (S -> (S,T))
+  g2 :: (S -> (S,T)) ~ IO T
+
+Extrude the g2
+
+  f' = \p. \s. ((error "...") |> g1) s
+  f = f' |> (String -> g2)
+
+Discard args for bottomming function
+
+  f' = \p. \s. ((error "...") |> g1 |> g3
+  g3 :: (S -> (S,T)) ~ (S,T)
+
+Extrude g1.g3
+
+  f'' = \p. \s. (error "...")
+  f' = f'' |> (String -> S -> g1.g3)
+
+And now we can repeat the whole loop.  Aargh!  The bug is in applying the
+state hack to a function which then swallows the argument.
+
 
 -------------------- Main arity code ----------------------------
 \begin{code}
--- If e has ArityType (AT as r), then the term 'e'
---  * Must be applied to at least (length as) *value* args 
+-- If e has ArityType (AT n r), then the term 'e'
+--  * Must be applied to at least n *value* args 
 --     before doing any significant work
---  * It will not diverge before being applied to (length as) 
+--  * It will not diverge before being applied to n
 --     value arguments
---  * If 'r' is ABot, then it guarantees to eventually diverge if 
---     applied to enough arguments (perhaps more than (length as)
+--  * If 'r' is ABot, then it guarantees to diverge if 
+--     applied to n arguments (or more)
 
 data ArityType = AT Arity ArityRes
 data ArityRes  = ATop                  -- Know nothing
@@ -1045,9 +1085,6 @@ data ArityRes  = ATop                     -- Know nothing
 vanillaArityType :: ArityType
 vanillaArityType = AT 0 ATop   -- Totally uninformative
 
-arityDepth :: ArityType -> Arity
-arityDepth (AT a _) = a
-
 incArity :: ArityType -> ArityType
 incArity (AT a r) = AT (a+1) r