From: simonpj@microsoft.com <unknown>
Date: Thu, 10 Apr 2008 08:49:30 +0000 (+0000)
Subject: Ensure that arity is accurate in back end
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3dcb2a668e541eb0b04b5d22c2b86b2700766d46

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
--- 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
--- 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
--- 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)