From: simonpj@microsoft.com <unknown>
Date: Wed, 17 Sep 2008 16:24:34 +0000 (+0000)
Subject: Add extra WARN test
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a211dd24b1149cf3bc5262f775f63e4d1c9b60ce

Add extra WARN test

This warning tests that the arity of a function does not decrease.
And that it's at least as great as the strictness signature.

Failing this test isn't a disater, but it's distinctly odd and
usually indicates that not enough information is getting propagated
around, and hence you may get more simplifier iterations.
---

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index af0acab..f27bb43 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -21,7 +21,7 @@ import Coercion
 import FamInstEnv       ( topNormaliseType )
 import DataCon          ( dataConRepStrictness, dataConUnivTyVars )
 import CoreSyn
-import NewDemand        ( isStrictDmd )
+import NewDemand        ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreUnfold       ( mkUnfolding, callSiteInline, CallCtxt(..) )
 import CoreUtils
@@ -511,6 +511,13 @@ makeTrivial env expr
   = do  { var <- newId (fsLit "a") (exprType expr)
         ; env' <- completeNonRecX env False var var expr
         ; return (env', substExpr env' (Var var)) }
+	-- The substitution is needed becase we're constructing a new binding
+	--     a = rhs
+	-- And if rhs is of form (rhs1 |> co), then we might get
+	--     a1 = rhs1
+	--     a = a1 |> co
+	-- and now a's RHS is trivial and can be substituted out, and that
+	-- is what completeNonRecX will do
 \end{code}
 
 
@@ -606,13 +613,19 @@ addNonRecWithUnf :: SimplEnv
 -- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set
 addNonRecWithUnf env new_bndr rhs unfolding wkr
   = ASSERT( isId new_bndr )
+    WARN( new_arity < old_arity || new_arity < dmd_arity, 
+          (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
     final_id `seq`      -- This seq forces the Id, and hence its IdInfo,
 	                -- and hence any inner substitutions
     addNonRec env final_id rhs
 	-- The addNonRec adds it to the in-scope set too
   where
+	dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr
+	old_arity = idArity new_bndr
+
         --      Arity info
-        new_bndr_info = idInfo new_bndr `setArityInfo` exprArity rhs
+	new_arity = exprArity rhs
+        new_bndr_info = idInfo new_bndr `setArityInfo` new_arity
 
         --      Unfolding info
         -- Add the unfolding *only* for non-loop-breakers