From 22b34988e2b156593d7cfc9b72d6cc0ab471a1d2 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Mon, 23 Mar 2009 10:16:14 +0000
Subject: [PATCH] Improve arity propagation in the specialiser

This patch makes the specialiser propagate arities a bit more
eagerly, which avoids a spurious warning in the simplifier.

See Note [Arity decrease] in Simplify.lhs
---
 compiler/simplCore/Simplify.lhs    |   26 +++++++++++++++++++++++++-
 compiler/specialise/Specialise.lhs |   13 +++++++++----
 2 files changed, 34 insertions(+), 5 deletions(-)

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 4f75769..715a2c2 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -623,7 +623,9 @@ addNonRecWithUnf :: SimplEnv
 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 )
+          (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
+		<+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+	-- Note [Arity decrease]
     final_id `seq`      -- This seq forces the Id, and hence its IdInfo,
 	                -- and hence any inner substitutions
     addNonRec env final_id rhs
@@ -666,6 +668,28 @@ addNonRecWithUnf env new_bndr rhs unfolding wkr
         final_id = new_bndr `setIdInfo` final_info
 \end{code}
 
+Note [Arity decrease]
+~~~~~~~~~~~~~~~~~~~~~
+Generally speaking the arity of a binding should not decrease.  But it *can* 
+legitimately happen becuase of RULES.  Eg
+	f = g Int
+where g has arity 2, will have arity 2.  But if there's a rewrite rule
+	g Int --> h
+where h has arity 1, then f's arity will decrease.  Here's a real-life example,
+which is in the output of Specialise:
+
+     Rec {
+	$dm {Arity 2} = \d.\x. op d
+	{-# RULES forall d. $dm Int d = $s$dm #-}
+	
+	dInt = MkD .... opInt ...
+	opInt {Arity 1} = $dm dInt
+
+	$s$dm {Arity 0} = \x. op dInt }
+
+Here opInt has arity 1; but when we apply the rule its arity drops to 0.
+That's why Specialise goes to a little trouble to pin the right arity
+on specialised functions too.
 
 
 %************************************************************************
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 015332f..037db7a 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -16,7 +16,7 @@ module Specialise ( specProgram ) where
 
 import Id		( Id, idName, idType, mkUserLocal, idCoreRules,
 			  idInlineActivation, setInlineActivation, setIdUnfolding,
-                          isLocalId ) 
+                          isLocalId, idArity, setIdArity ) 
 import TcType		( Type, mkTyVarTy, tcSplitSigmaTy, 
 			  tyVarsOfTypes, tyVarsOfTheta, isClassPred,
 			  tcCmpType, isUnLiftedType
@@ -826,6 +826,7 @@ specDefn subst calls fn rhs
   
   where
     fn_type	       = idType fn
+    fn_arity	       = idArity fn
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars	       = length tyvars
     n_dicts	       = length theta
@@ -906,6 +907,10 @@ specDefn subst calls fn rhs
 	         spec_id_ty = mkPiTypes lam_args body_ty
 	
            ; spec_f <- newSpecIdSM fn spec_id_ty
+  	   ; let spec_f_w_arity = setIdArity spec_f (max 0 (fn_arity - n_dicts))
+		-- Adding arity information just propagates it a bit faster
+		-- See Note [Arity decrease] in Simplify
+
            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
 	   ; let
 		-- The rule to put in the function's specialisation is:
@@ -917,13 +922,13 @@ specDefn subst calls fn rhs
 			 	  (idName fn)
 			          (poly_tyvars ++ inst_dict_ids)
 				  inst_args 
-				  (mkVarApps (Var spec_f) app_args)
+				  (mkVarApps (Var spec_f_w_arity) app_args)
 
 		-- Add the { d1' = dx1; d2' = dx2 } usage stuff
 	   	final_uds = foldr addDictBind rhs_uds dx_binds
 
-	   	spec_pr | inline_rhs = (spec_f `setInlineActivation` inline_act, Note InlineMe spec_rhs)
-		        | otherwise  = (spec_f, 		 	      spec_rhs)
+	   	spec_pr | inline_rhs = (spec_f_w_arity `setInlineActivation` inline_act, Note InlineMe spec_rhs)
+		        | otherwise  = (spec_f_w_arity, 	 	                 spec_rhs)
 
 	   ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
       where
-- 
1.7.10.4