Commit 22b34988 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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
parent 0506cb7e
...@@ -623,7 +623,9 @@ addNonRecWithUnf :: SimplEnv ...@@ -623,7 +623,9 @@ addNonRecWithUnf :: SimplEnv
addNonRecWithUnf env new_bndr rhs unfolding wkr addNonRecWithUnf env new_bndr rhs unfolding wkr
= ASSERT( isId new_bndr ) = ASSERT( isId new_bndr )
WARN( new_arity < old_arity || new_arity < dmd_arity, 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, final_id `seq` -- This seq forces the Id, and hence its IdInfo,
-- and hence any inner substitutions -- and hence any inner substitutions
addNonRec env final_id rhs addNonRec env final_id rhs
...@@ -666,6 +668,28 @@ addNonRecWithUnf env new_bndr rhs unfolding wkr ...@@ -666,6 +668,28 @@ addNonRecWithUnf env new_bndr rhs unfolding wkr
final_id = new_bndr `setIdInfo` final_info final_id = new_bndr `setIdInfo` final_info
\end{code} \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.
%************************************************************************ %************************************************************************
......
...@@ -16,7 +16,7 @@ module Specialise ( specProgram ) where ...@@ -16,7 +16,7 @@ module Specialise ( specProgram ) where
import Id ( Id, idName, idType, mkUserLocal, idCoreRules, import Id ( Id, idName, idType, mkUserLocal, idCoreRules,
idInlineActivation, setInlineActivation, setIdUnfolding, idInlineActivation, setInlineActivation, setIdUnfolding,
isLocalId ) isLocalId, idArity, setIdArity )
import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
tyVarsOfTypes, tyVarsOfTheta, isClassPred, tyVarsOfTypes, tyVarsOfTheta, isClassPred,
tcCmpType, isUnLiftedType tcCmpType, isUnLiftedType
...@@ -826,6 +826,7 @@ specDefn subst calls fn rhs ...@@ -826,6 +826,7 @@ specDefn subst calls fn rhs
where where
fn_type = idType fn fn_type = idType fn
fn_arity = idArity fn
(tyvars, theta, _) = tcSplitSigmaTy fn_type (tyvars, theta, _) = tcSplitSigmaTy fn_type
n_tyvars = length tyvars n_tyvars = length tyvars
n_dicts = length theta n_dicts = length theta
...@@ -906,6 +907,10 @@ specDefn subst calls fn rhs ...@@ -906,6 +907,10 @@ specDefn subst calls fn rhs
spec_id_ty = mkPiTypes lam_args body_ty spec_id_ty = mkPiTypes lam_args body_ty
; spec_f <- newSpecIdSM fn spec_id_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) ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
; let ; let
-- The rule to put in the function's specialisation is: -- The rule to put in the function's specialisation is:
...@@ -917,13 +922,13 @@ specDefn subst calls fn rhs ...@@ -917,13 +922,13 @@ specDefn subst calls fn rhs
(idName fn) (idName fn)
(poly_tyvars ++ inst_dict_ids) (poly_tyvars ++ inst_dict_ids)
inst_args inst_args
(mkVarApps (Var spec_f) app_args) (mkVarApps (Var spec_f_w_arity) app_args)
-- Add the { d1' = dx1; d2' = dx2 } usage stuff -- Add the { d1' = dx1; d2' = dx2 } usage stuff
final_uds = foldr addDictBind rhs_uds dx_binds final_uds = foldr addDictBind rhs_uds dx_binds
spec_pr | inline_rhs = (spec_f `setInlineActivation` inline_act, Note InlineMe spec_rhs) spec_pr | inline_rhs = (spec_f_w_arity `setInlineActivation` inline_act, Note InlineMe spec_rhs)
| otherwise = (spec_f, spec_rhs) | otherwise = (spec_f_w_arity, spec_rhs)
; return (Just (spec_pr, final_uds, spec_env_rule)) } } ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
where where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment