#include "HsVersions.h"
-import Id ( Id, idName, idType, mkUserLocal, idCoreRules,
- idInlinePragma, setInlinePragma, setIdUnfolding,
- isLocalId, idUnfolding )
+import Id ( Id, idName, idType, mkUserLocal, idCoreRules, idUnfolding,
+ idInlineActivation, setInlineActivation, setIdUnfolding,
+ isLocalId, isDataConWorkId, idArity, setIdArity )
import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
tyVarsOfTypes, tyVarsOfTheta, isClassPred,
tcCmpType, isUnLiftedType
cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
extendIdSubst
)
-import CoreUnfold ( mkUnfolding, mkInlineRule )
-import SimplUtils ( interestingArg )
+import CoreUnfold ( mkUnfolding )
import Var ( DictId )
import VarSet
import VarEnv
import MkId ( voidArgId, realWorldPrimId )
import FiniteMap
import Maybes ( catMaybes, isJust )
-import BasicTypes ( Arity )
import Bag
import Util
import Outputable
where
fn_type = idType fn
+ fn_arity = idArity fn
(tyvars, theta, _) = tcSplitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
- inline_prag = idInlinePragma fn
+ inline_act = idInlineActivation fn
- -- Figure out whether the function has an INLINE pragma
- -- See Note [Inline specialisations]
- fn_has_inline_rule :: Maybe Arity -- Gives arity of the *specialised* inline rule
- fn_has_inline_rule = case idUnfolding fn of
- InlineRule { uf_arity = arity } -> Just (arity - n_dicts)
- _other -> Nothing
-
- (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
+ -- It's important that we "see past" any INLINE pragma
+ -- else we'll fail to specialise an INLINE thing
+ (inline_rhs, rhs_inside) = dropInline rhs
+ (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside
rhs_dict_ids = take n_dicts rhs_ids
body = mkLams (drop n_dicts rhs_ids) rhs_body
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:
rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
spec_env_rule = mkLocalRule
rule_name
- inline_prag -- Note [Auto-specialisation and RULES]
+ inline_act -- Note [Auto-specialisation and RULES]
(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
- -- See Note [Inline specialisations]
- final_spec_f | Just spec_arity <- fn_has_inline_rule
- = spec_f `setInlinePragma` inline_prag
- `setIdUnfolding` mkInlineRule spec_rhs spec_arity
- | otherwise
- = spec_f
- ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
+ 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
my_zipEqual xs ys zs
| debugIsOn && not (equalLength xs ys && equalLength ys zs)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We transfer to the specialised function any INLINE stuff from the
original. This means (a) the Activation in the IdInfo, and (b) any
-InlineMe on the RHS.
+InlineMe on the RHS. We do not, however, transfer the RuleMatchInfo
+since we do not expect the specialisation to occur in rewrite rules.
This is a change (Jun06). Previously the idea is that the point of
inlining was precisely to specialise the function at its call site,
A case in point is dictionary functions, which are current marked
INLINE, but which are worth specialising.
+\begin{code}
+dropInline :: CoreExpr -> (Bool, CoreExpr)
+dropInline (Note InlineMe rhs) = (True, rhs)
+dropInline rhs = (False, rhs)
+\end{code}
%************************************************************************
%* *
-- *don't* say what the value of the implicit param is!
|| not (spec_tys `lengthIs` n_tyvars)
|| not ( dicts `lengthIs` n_dicts)
- || not (any interestingArg dicts) -- Note [Interesting dictionary arguments]
+ || not (any interestingDict dicts) -- Note [Interesting dictionary arguments]
-- See also Note [Specialisations already covered]
- = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)])
+ = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
emptyUDs -- Not overloaded, or no specialisation wanted
| otherwise
- = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)])
+ = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
singleCall f spec_tys dicts
where
(tyvars, theta, _) = tcSplitSigmaTy (idType f)
because the code for the specialised f is not improved at all, because
d is lambda-bound. We simply get junk specialisations.
-We re-use the function SimplUtils.interestingArg function to determine
-what sort of dictionary arguments have *some* information in them.
+What is "interesting"? Just that it has *some* structure.
+\begin{code}
+interestingDict :: CoreExpr -> Bool
+-- A dictionary argument is interesting if it has *some* structure
+interestingDict (Var v) = hasSomeUnfolding (idUnfolding v)
+ || isDataConWorkId v
+interestingDict (Type _) = False
+interestingDict (App fn (Type _)) = interestingDict fn
+interestingDict (Note _ a) = interestingDict a
+interestingDict (Cast e _) = interestingDict e
+interestingDict _ = True
+\end{code}
\begin{code}
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
projects / ghc-hetmet.git / blobdiff