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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 4f75769..715a2c2 100644 (file)
--- 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 (file)
--- 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