#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..) )
-import Id ( Id, idName, idType, mkUserLocal,
- idSpecialisation, modifyIdInfo
- )
+import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
tyVarsOfTypes, tyVarsOfTheta,
mkForAllTys, tcCmpType
import VarEnv
import CoreSyn
import CoreUtils ( applyTypeToArgs )
-import CoreUnfold ( certainlyWillInline )
import CoreFVs ( exprFreeVars, exprsFreeVars )
+import CoreTidy ( pprTidyIdRules )
import CoreLint ( showPass, endPass )
-import PprCore ( pprCoreRules )
import Rules ( addIdSpecialisations, lookupRule )
import UniqSupply ( UniqSupply,
import FiniteMap
import Maybes ( catMaybes, maybeToBool )
import ErrUtils ( dumpIfSet_dyn )
+import BasicTypes ( Activation( AlwaysActive ) )
import Bag
import List ( partition )
-import Util ( zipEqual, zipWithEqual, cmpList )
+import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
+ equalLength, lengthAtLeast, notNull )
import Outputable
endPass dflags "Specialise" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
- (vcat (map dump_specs (concat (map bindersOf binds'))))
+ (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
return binds'
where
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
specBind top_subst bind uds `thenSM` \ (bind', uds') ->
returnSM (bind' ++ binds', uds')
-
-dump_specs var = pprCoreRules var (idSpecialisation var)
\end{code}
%************************************************************************
specDefn subst calls (fn, rhs)
-- The first case is the interesting one
- | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
- && n_dicts <= length rhs_bndrs -- and enough dict args
- && not (null calls_for_me) -- And there are some calls to specialise
- && not (certainlyWillInline fn) -- And it's not small
+ | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas
+ && rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args
+ && notNull calls_for_me -- And there are some calls to specialise
+ && not (isDataConWrapId fn) -- And it's not a data con wrapper, which have
+ -- stupid overloading that simply discard the dictionary
+
+-- At one time I tried not specialising small functions
+-- but sometimes there are big functions marked INLINE
+-- that we'd like to specialise. In particular, dictionary
+-- functions, which Marcin is keen to inline
+-- && not (certainlyWillInline fn) -- And it's not small
-- If it's small, it's better just to inline
-- it than to construct lots of specialisations
= -- Specialise the body of the function
n_tyvars = length tyvars
n_dicts = length theta
- (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_me, rhs') = dropInline rhs
+ (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs'
+
rhs_dicts = take n_dicts rhs_ids
rhs_bndrs = rhs_tyvars ++ rhs_dicts
body = mkLams (drop n_dicts rhs_ids) rhs_body
UsageDetails, -- Usage details from specialised body
CoreRule) -- Info for the Id's SpecEnv
spec_call (CallKey call_ts, (call_ds, call_fvs))
- = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
+ = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts )
-- Calls are only recorded for properly-saturated applications
-- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs
-- The rule to put in the function's specialisation is:
-- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d
spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+ AlwaysActive
(poly_tyvars ++ rhs_dicts')
inst_args
(mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
+
+ -- NOTE: we don't add back in any INLINE pragma on the RHS, so even if
+ -- the original function said INLINE, the specialised copies won't.
+ -- The idea is that the point of inlining was precisely to specialise
+ -- the function at its call site, and that's not so important for the
+ -- specialised copies. But it still smells like an ad hoc decision.
+
in
- returnSM ((spec_f, spec_rhs),
+ returnSM ((spec_f, spec_rhs),
final_uds,
spec_env_rule)
where
my_zipEqual doc xs ys
- | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
- | otherwise = zipEqual doc xs ys
+ | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+ | otherwise = zipEqual doc xs ys
+
+dropInline :: CoreExpr -> (Bool, CoreExpr)
+dropInline (Note InlineMe rhs) = (True, rhs)
+dropInline rhs = (False, rhs)
\end{code}
%************************************************************************
mkCallUDs subst f args
| null theta
- || length spec_tys /= n_tyvars
- || length dicts /= n_dicts
- || maybeToBool (lookupRule (substInScope subst) f args)
+ || not (spec_tys `lengthIs` n_tyvars)
+ || not ( dicts `lengthIs` n_dicts)
+ || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
-- There's already a rule covering this call. A typical case
-- is where there's an explicit user-provided rule. Then
-- we don't want to create a specialised version
%************************************************************************
\begin{code}
-lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupVarEnv env id of
- Nothing -> id
- Just id' -> id'
-
-----------------------------------------
type SpecM a = UniqSM a
thenSM = thenUs
projects / ghc-hetmet.git / blobdiff