import CoreSubst
import MkCore
import CoreUtils
+import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
ar_env = mkArityEnv binds
do_one (lcl_id, rhs)
| Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
- = ASSERT( null spec_prags ) -- Not overloaded
- makeCorePair gbl_id (lookupArity ar_env lcl_id) $
- addAutoScc auto_scc gbl_id rhs
+ = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded
+ makeCorePair gbl_id (lookupArity ar_env lcl_id)
+ (addAutoScc auto_scc gbl_id rhs)
| otherwise = (lcl_id, rhs)
do_one lg_binds (lcl_id, rhs)
| Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
- = ASSERT( null spec_prags ) -- Not overloaded
- let rhs' = addAutoScc auto_scc gbl_id $
- mkLams id_tvs $
- mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
- | tv <- tyvars, not (tv `elem` id_tvs)] $
- add_lets lg_binds rhs
+ = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded
+ (let rhs' = addAutoScc auto_scc gbl_id $
+ mkLams id_tvs $
+ mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
+ | tv <- tyvars, not (tv `elem` id_tvs)] $
+ add_lets lg_binds rhs
in return (mk_lg_bind lcl_id gbl_id id_tvs,
- makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs')
+ makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs'))
| otherwise
= do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
------------------------
makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair gbl_id arity rhs
- = (addInline gbl_id arity rhs, rhs)
+ | isInlinePragma (idInlinePragma gbl_id)
+ -- Add an Unfolding for an INLINE (but not for NOINLINE)
+ -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+ = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity,
+ etaExpand arity rhs)
+ | otherwise
+ = (gbl_id, rhs)
------------------------
type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag])
lookupArity :: IdEnv Arity -> Id -> Arity
lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
-
-addInline :: Id -> Arity -> CoreExpr -> Id
-addInline id arity rhs
- | isInlinePragma (idInlinePragma id)
- -- Add an Unfolding for an INLINE (but not for NOINLINE)
- = id `setIdUnfolding` mkInlineRule InlSat rhs arity
- | otherwise
- = id
\end{code}
-Nested arities
-~~~~~~~~~~~~~~
+Note [Eta-expanding INLINE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ foo :: Eq a => a -> a
+ {-# INLINE foo #-}
+ foo x = ...
+
+If (foo d) ever gets floated out as a common sub-expression (which can
+happen as a result of method sharing), there's a danger that we never
+get to do the inlining, which is a Terribly Bad thing given that the
+user said "inline"!
+
+To avoid this we pre-emptively eta-expand the definition, so that foo
+has the arity with which it is declared in the source code. In this
+example it has arity 2 (one for the Eq and one for x). Doing this
+should mean that (foo d) is a PAP and we don't share it.
+
+Note [Nested arities]
+~~~~~~~~~~~~~~~~~~~~~
For reasons that are not entirely clear, method bindings come out looking like
this:
It might be better to have just one level of AbsBinds, but that requires more
thought!
+Note [Implementing SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example:
+ f :: (Eq a, Ix b) => a -> b -> Bool
+ {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+
+From this the typechecker generates
+
+ AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
+
+ SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
+ -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
+
+Note that wrap_fn can transform *any* function with the right type prefix
+ forall ab. (Eq a, Ix b) => <blah>
+regardless of <blah>. It's sort of polymorphic in <blah>. This is
+useful: we use the same wrapper to transform each of the class ops, as
+well as the dict.
+
+From these we generate:
+
+ Rule: forall p, q, (dp:Ix p), (dq:Ix q).
+ f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
+
+ Spec bind: f_spec = wrap_fn (/\ab \d1 d2. Let binds in f_mono)
+
+Note that
+
+ * The LHS of the rule may mention dictionary *expressions* (eg
+ $dfIxPair dp dq), and that is essential because the dp, dq are
+ needed on the RHS.
+
+ * The RHS of f_spec has a *copy* of 'binds', so that it can fully
+ specialise it.
\begin{code}
------------------------
-> CoreBind -> [LSpecPrag]
-> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids
, [CoreRule] ) -- Rules for the Global Ids
--- Example:
--- f :: (Eq a, Ix b) => a -> b -> b
--- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
---
--- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
---
--- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
--- (forall b. Ix b => Int -> b -> b)
---
--- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
---
--- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
--- /\b.\(d:Ix b). in f Int b dInt d
--- The idea is that f occurs just once, so it'll be
--- inlined and specialised
---
--- Given SpecPrag (/\as.\ds. f es) t, we have
--- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
--- in f es
--- and the RULE forall as, ds. f es = f_spec as ds
---
--- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
--- (a bit silly, because then the
-
+-- See Note [Implementing SPECIALISE pragmas]
dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
= do { pairs <- mapMaybeM spec_one prags
; let (spec_binds_s, rules) = unzip pairs
bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
| otherwise -> do
- { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id)
+ { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
; let f_body = fix_up (Let mono_bind (Var mono_id))
spec_ty = exprType ds_spec_expr
spec_id_arity = inl_arity + count isDictId bndrs
extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts]
- | d <- varSetElems (exprFreeVars ds_spec_expr)
- , isDictId d]
+ | d <- varSetElems (exprFreeVars ds_spec_expr)
+ , isDictId d]
-- Note [Const rule dicts]
rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))