Ensure that arity is accurate in back end

See Note [exprArity invariant] in CoreUtils.  In code generated by Happy
I was seeing this after TidyPgm and CorePrep

	f :: Any
	f {arity 1} = id `cast` unsafe-co

So f claimed to have arity 1 (because exprArity looked inside), but
did not have any top-level lambdas (because its type is Any).

This triggered a slightly-obscure ASSERT failure in CoreToStg

This patch
	- makes exprArity trim the arity if the type is not a function
	- adds a stronger ASSERT in TidyPgm

It's not the only way to solve this problem (see Note [exprArity invariant])
but it's enough for now.

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index f0c2d9f..68fd530 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -634,7 +634,7 @@ mkBinds (Floats _ binds) body
 etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr
 etaExpandRhs bndr rhs = do
        -- Eta expand to match the arity claimed by the binder
-       -- Remember, after CorePrep we must not change arity
+       -- Remember, CorePrep must not change arity
        --
        -- Eta expansion might not have happened already, 
        -- because it is done by the simplifier only when 
@@ -663,7 +663,12 @@ etaExpandRhs bndr rhs = do
        --              f = /\a -> \y -> let s = h 3 in g s y
        --
     us <- getUniquesM
-    return (etaExpand arity us rhs (idType bndr))
+    let eta_rhs = etaExpand arity us rhs (idType bndr)
+
+    ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs)) 
+                                             $$ ppr rhs $$ ppr eta_rhs )
+       -- Assertion checks that eta expansion was successful
+      return eta_rhs
   where
        -- For a GlobalId, take the Arity from the Id.
        -- It was set in CoreTidy and must not change

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index a4b0e6e..c8d6611 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1204,6 +1204,7 @@ eta_expand n us expr ty
        -- This *can* legitmately happen: e.g.  coerce Int (\x. x)
        -- Essentially the programmer is playing fast and loose with types
        -- (Happy does this a lot).  So we simply decline to eta-expand.
+       -- Otherwise we'd end up with an explicit lambda having a non-function type
        expr
        }}}
 \end{code}
@@ -1232,23 +1233,51 @@ And in any case it seems more robust to have exprArity be a bit more intelligent
 But note that  (\x y z -> f x y z)
 should have arity 3, regardless of f's arity.
 
+Note [exprArity invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+exprArity has the following invariant:
+       (exprArity e) = n, then manifestArity (etaExpand e n) = n
+
+That is, if exprArity says "the arity is n" then etaExpand really can get
+"n" manifest lambdas to the top.
+
+Why is this important?  Because 
+  - In TidyPgm we use exprArity to fix the *final arity* of 
+    each top-level Id, and in
+  - In CorePrep we use etaExpand on each rhs, so that the visible lambdas
+    actually match that arity, which in turn means
+    that the StgRhs has the right number of lambdas
+
+An alternative would be to do the eta-expansion in TidyPgm, at least
+for top-level bindings, in which case we would not need the trim_arity
+in exprArity.  That is a less local change, so I'm going to leave it for today!
+
+
 \begin{code}
 exprArity :: CoreExpr -> Arity
 exprArity e = go e
-           where
-             go (Var v)                   = idArity v
-             go (Lam x e) | isId x        = go e + 1
-                          | otherwise     = go e
-              go (Note _ e)                = go e
-              go (Cast e _)                = go e
-              go (App e (Type _))          = go e
-             go (App f a) | exprIsCheap a = (go f - 1) `max` 0
-               -- NB: exprIsCheap a!  
-               --      f (fac x) does not have arity 2, 
-               --      even if f has arity 3!
-               -- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
-               --               unknown, hence arity 0
-             go _                         = 0
+  where
+    go (Var v)                          = idArity v
+    go (Lam x e) | isId x       = go e + 1
+                | otherwise     = go e
+    go (Note _ e)                = go e
+    go (Cast e co)               = trim_arity (go e) 0 (snd (coercionKind co))
+    go (App e (Type _))          = go e
+    go (App f a) | exprIsCheap a = (go f - 1) `max` 0
+       -- NB: exprIsCheap a!  
+       --      f (fac x) does not have arity 2, 
+       --      even if f has arity 3!
+       -- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
+       --               unknown, hence arity 0
+    go _                          = 0
+
+       -- Note [exprArity invariant]
+    trim_arity n a ty
+       | n==a                                        = a
+       | Just (_, ty') <- splitForAllTy_maybe ty     = trim_arity n a     ty'
+       | Just (_, ty') <- splitFunTy_maybe ty        = trim_arity n (a+1) ty'
+       | Just (ty',_)  <- splitNewTypeRepCo_maybe ty = trim_arity n a     ty'
+       | otherwise                                   = a
 \end{code}
 
 %************************************************************************

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index dbb785b..4956ccc 100644 (file)
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -189,7 +189,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
        bind = StgNonRec id stg_rhs
     in
     ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
-    ASSERT2(consistentCafInfo id bind, ppr id)
+    ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)